1
1
mirror of https://github.com/github/semantic.git synced 2024-12-30 02:14:20 +03:00

Try letrec'ing a loop variable.

This commit is contained in:
Rob Rix 2018-03-14 10:24:13 -04:00
parent eb41c0886e
commit 63c88b8aa5

View File

@ -77,7 +77,7 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
toBool :: MonadValue term value m => value -> m Bool
toBool v = ifthenelse v (pure True) (pure False)
forLoop :: MonadValue term value m
forLoop :: (MonadAddressable (LocationFor value) value m, MonadEnvironment value m, MonadStore value m, MonadValue term value m)
=> m value -- | Initial statement
-> m value -- | Condition
-> m value -- | Increment/stepper
@ -89,17 +89,24 @@ forLoop initial cond step body = do
localEnv (mappend env) (while cond (body *> step))
-- | The fundamental looping primitive, built on top of ifthenelse.
while :: MonadValue term value m => m value -> m value -> m value
while cond body = do
while :: (MonadAddressable (LocationFor value) value m, MonadEnvironment value m, MonadStore value m, MonadValue term value m) => m value -> m value -> m value
while cond body = loop $ do
this <- cond
ifthenelse this (body *> while cond body) unit
ifthenelse this (body *> continue) unit
-- | Do-while loop, built on top of while.
doWhile :: MonadValue term value m => m value -> m value -> m value
doWhile body cond = do
void body
doWhile :: (MonadAddressable (LocationFor value) value m, MonadEnvironment value m, MonadStore value m, MonadValue term value m) => m value -> m value -> m value
doWhile body cond = loop $ body *> do
this <- cond
ifthenelse this (doWhile body cond) unit
ifthenelse this continue unit
loop :: (MonadAddressable (LocationFor value) value m, MonadEnvironment value m, MonadStore value m) => m value -> m value
loop = letrec (name "loop")
continue :: (MonadAddressable (LocationFor value) value m, MonadEnvironment value m, MonadStore value m, MonadValue term value m) => m value
continue = do
env <- askLocalEnv
maybe (fail "free loop variable") deref (envLookup (name "loop") env)
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( MonadAddressable location (Value location term) m