From 7057209137185b0b18822a4f2156104eabd053c8 Mon Sep 17 00:00:00 2001
From: Matthew Hall <hallmatthew314@gmail.com>
Date: Wed, 15 Feb 2023 16:21:21 +1300
Subject: Implement ELSE branches

---
 DSL.hs | 34 ++++++++++++++++++++++++++++++----
 1 file changed, 30 insertions(+), 4 deletions(-)

(limited to 'DSL.hs')

diff --git a/DSL.hs b/DSL.hs
index 16fe92b..d3001fb 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -55,6 +55,7 @@ data StackModifier = StackModifier { smName :: String
 data Block
   = BLinear [Operation]
   | BIf [Block] [Block]
+  | BIfElse [Block] [Block] [Block]
     deriving (Show)
 
 type Program = [Block]
@@ -66,6 +67,7 @@ data Machine = Machine { ok :: Bool
 data TokenData
   = T_WHITESPACE
   | T_IF
+  | T_ELSE
   | T_DO
   | T_END
   | T_BOOL_LITERAL Bool
@@ -121,9 +123,10 @@ mainLexer = phrase $ mult1 $ firstOf subLexers
              ++ keywords
              ++ literals
              ++ intrinsics
-    keywords = map (uncurry keywordL) [ ("IF",  T_IF)
-                                      , ("DO",  T_DO)
-                                      , ("END", T_END)
+    keywords = map (uncurry keywordL) [ ("IF",   T_IF)
+                                      , ("ELSE", T_ELSE)
+                                      , ("DO",   T_DO)
+                                      , ("END",  T_END)
                                       ]
     literals = [ boolLiteralL
                , intLiteralL
@@ -196,8 +199,19 @@ ifP = do
     cond = mult blockP
     body = mult blockP
 
+ifElseP :: DSLParser Block
+ifElseP = do
+  c  <- satisfy ((==T_IF) . tData) *> cond <* satisfy ((==T_DO) . tData)
+  b1 <- body <* satisfy ((==T_ELSE) . tData)
+  b2 <- body <* satisfy ((==T_END) . tData)
+  return $ BIfElse c b1 b2
+  where
+    cond = mult blockP
+    body = mult blockP
+
 blockP :: DSLParser Block
-blockP = firstOf [ ifP
+blockP = firstOf [ ifElseP
+                 , ifP
                  , linearP
                  ]
 
@@ -388,11 +402,23 @@ applyIf c b m                     = do
     Machine{ stack=StackBool True:xs }  -> evalBlocks b m'{ stack=xs }
     Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
 
+applyIfElse :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine
+applyIfElse _ _ _ m@Machine{ ok=False } = return m
+applyIfElse c b1 b2 m                   = do
+  m' <- evalBlocks c m
+  case m' of
+    Machine{ ok=False }                 -> return m'
+    Machine{ stack=[] }                 -> hcf m' "IFELSE: stack underflow"
+    Machine{ stack=StackBool True:xs }  -> evalBlocks b1 m'{ stack=xs }
+    Machine{ stack=StackBool False:xs } -> evalBlocks b2 m'{ stack=xs }
+    Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
+
 evalBlocks :: [Block] -> Machine -> IO Machine
 evalBlocks _ m@Machine{ ok=False } = return m
 evalBlocks [] m                    = return m
 evalBlocks (BLinear b:bs) m        = applyLinear m b >>= evalBlocks bs
 evalBlocks (BIf c b:bs) m          = applyIf c b m >>= evalBlocks bs
+evalBlocks (BIfElse c b1 b2:bs) m  = applyIfElse c b1 b2 m >>= evalBlocks bs
 
 interpret :: Program -> IO ()
 interpret p = evalBlocks p newMachine >> return ()
-- 
cgit v1.2.1