implement while and dowhile

src/Control/Abstract/Value.hs

@@ -73,6 +73,9 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Eliminate boolean values. TODO: s/boolean/truthy
   ifthenelse :: value -> m a -> m a -> m a
 
+  -- | Simple control flow
+  while :: m value -> m value -> m value
+
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
   abstract :: [Name] -> Subterm term (m value) -> m value
   -- | Evaluate an application (like a function call).
@@ -89,6 +92,10 @@ toBool v = ifthenelse v (pure True) (pure False)
 evalToBool :: MonadValue term value m => Subterm t (m value) -> m Bool
 evalToBool = subtermValue >=> toBool
 
+-- | Do-while loop, built on top of while.
+doWhile :: MonadValue term value m => m value -> m value -> m value
+doWhile body cond = body *> while cond body
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
 instance ( MonadAddressable location (Value location term) m
          , MonadAnalysis term (Value location term) m
@@ -111,6 +118,13 @@ instance ( MonadAddressable location (Value location term) m
     | Just (Boolean b) <- prjValue cond = if b then if' else else'
     | otherwise = fail ("not defined for non-boolean conditions: " <> show cond)
 
+  while cond body = do
+    this <- cond
+    case prjValue this of
+      Just (Boolean True)  -> body *> while cond body
+      Just (Boolean False) -> unit
+      Nothing              -> fail ("type error: non-boolean condition " <> show this)
+
   liftNumeric f arg
     | Just (Integer i)     <- prjValue arg = pure . injValue . Integer     $ f i
     | Just (Value.Float i) <- prjValue arg = pure . injValue . Value.Float $ f i
@@ -190,6 +204,8 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue
 
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
+  while _ _ = pure Type.Unit
+
   liftNumeric _ Type.Float = pure Type.Float
   liftNumeric _ Int        = pure Int
   liftNumeric _ _          = fail "Invalid type in unary numeric operation"

src/Data/Syntax/Statement.hs

@@ -220,9 +220,8 @@ instance Eq1 While where liftEq = genericLiftEq
 instance Ord1 While where liftCompare = genericLiftCompare
 instance Show1 While where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for While
-instance Evaluatable While
-
+instance Evaluatable While where
+  eval While{..} = while (subtermValue whileCondition)  (subtermValue whileBody)
 
 data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@@ -231,9 +230,8 @@ instance Eq1 DoWhile where liftEq = genericLiftEq
 instance Ord1 DoWhile where liftCompare = genericLiftCompare
 instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for DoWhile
-instance Evaluatable DoWhile
-
+instance Evaluatable DoWhile where
+  eval DoWhile{..} = doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
 
 -- Exception handling