From a29e29bbae82c25bc3677fa287c76d844c0d7799 Mon Sep 17 00:00:00 2001
From: Matthew Hall <hallmatthew314@gmail.com>
Date: Wed, 15 Feb 2023 16:05:47 +1300
Subject: More flexible IF statements

---
 DSL.hs | 17 +++++++++++------
 1 file changed, 11 insertions(+), 6 deletions(-)

(limited to 'DSL.hs')

diff --git a/DSL.hs b/DSL.hs
index b91d2dd..16fe92b 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -54,7 +54,7 @@ data StackModifier = StackModifier { smName :: String
 
 data Block
   = BLinear [Operation]
-  | BIf Block Block 
+  | BIf [Block] [Block]
     deriving (Show)
 
 type Program = [Block]
@@ -187,9 +187,14 @@ linearP = BLinear <$> mult1 operationP
 ifP :: DSLParser Block
 ifP = do
   _ <- satisfy $ (==T_IF) . tData
-  c <- recover (BLinear []) blockP <* satisfy ((==T_DO) . tData)
-  b <- blockP <* satisfy ((==T_END) . tData)
+  c <- cond
+  _ <- satisfy $ (==T_DO) . tData
+  b <- body
+  _ <- satisfy $ (==T_END) . tData
   return $ BIf c b
+  where
+    cond = mult blockP
+    body = mult blockP
 
 blockP :: DSLParser Block
 blockP = firstOf [ ifP
@@ -372,15 +377,15 @@ applyOperation m (OpIntrinsic i)         = applyIntrinsic i m
 applyLinear :: Machine -> [Operation] -> IO Machine
 applyLinear = foldlM applyOperation
 
-applyIf :: Block -> Block -> Machine -> IO Machine
+applyIf :: [Block] -> [Block] -> Machine -> IO Machine
 applyIf _ _ m@Machine{ ok=False } = return m
 applyIf c b m                     = do
-  m' <- evalBlocks [c] m
+  m' <- evalBlocks c m
   case m' of
     Machine{ ok=False }                 -> return m'
     Machine{ stack=[] }                 -> hcf m' "IF: stack underflow"
     Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
-    Machine{ stack=StackBool True:xs }  -> evalBlocks [b] m'{ stack=xs }
+    Machine{ stack=StackBool True:xs }  -> evalBlocks b m'{ stack=xs }
     Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
 
 evalBlocks :: [Block] -> Machine -> IO Machine
-- 
cgit v1.2.1