Add ELIF statements and refactor IF blocks

3 files changed, 35 insertions, 30 deletions

diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs
index 02f741d..e68b64f 100644
--- a/DSL/Interpretation.hs
+++ b/DSL/Interpretation.hs
@@ -61,26 +61,15 @@ applyOperation m (OpCall name)           = applyCall name m
 applyLinear :: Machine -> [Operation] -> IO Machine
 applyLinear = foldlM applyOperation
 
-applyIf :: [Block] -> [Block] -> Machine -> IO Machine
-applyIf _ _ m@Machine{ ok=False } = return m
-applyIf c b m                     = do
+applyIf :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine
+applyIf _ _ _ m@Machine{ ok=False } = return m
+applyIf c t f m                     = do
   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=_:_ }                -> 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=StackBool True:xs }  -> evalBlocks t m'{ stack=xs }
+    Machine{ stack=StackBool False:xs } -> evalBlocks f m'{ stack=xs }
     Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
 
 applyWhile :: [Block] -> [Block] -> Machine -> IO Machine
@@ -100,8 +89,7 @@ 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
+evalBlocks (BIf c t f:bs) m        = applyIf c t f m >>= evalBlocks bs
 evalBlocks (BWhile c b:bs) m       = applyWhile c b m >>= evalBlocks bs
 
 interpret :: ([ProcSpec], Program) -> IO ()
diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs
index 6dcc4bf..e0017bb 100644
--- a/DSL/Parsing.hs
+++ b/DSL/Parsing.hs
@@ -1,6 +1,7 @@
 module DSL.Parsing where
 
 import Data.Char (isDigit, isSpace)
+import Data.Maybe (fromMaybe)
 
 import DSL.Types
 import DSL.BaseParsers
@@ -28,6 +29,7 @@ commentL = buildDSLLexer go T_COMMENT
 keywordL :: DSLLexer
 keywordL = fromTableL [ ("PROC",  T_PROC)
                       , ("IF",    T_IF)
+                      , ("ELIF",  T_ELIF)
                       , ("ELSE",  T_ELSE)
                       , ("WHILE", T_WHILE)
                       , ("DO",    T_DO)
@@ -144,16 +146,32 @@ linearP = BLinear <$> mult1 operationP
 
 ifP :: DSLParser Block
 ifP = do
-  c <- tagP T_IF *> mult blockP <* tagP T_DO
-  b <- mult blockP <* tagP T_END
-  return $ BIf c b
+  first <- (tagP T_IF *> bp <* tagP T_DO) `plus` bp
+  elifs <- mult $ (tagP T_ELIF *> bp <* tagP T_DO) `plus` bp
+  elze  <- optionalMaybe $ tagP T_ELSE >> bp
+  _     <- tagP T_END
+  return $ go $ first:elifs ++ [elseToPair elze]
+  where
+    bp = mult blockP
+    go []          = BLinear []
+    go ((c, b):xs) = BIf c b $ [go xs]
+    elseToPair Nothing   = ([BLinear [OpPushData $ StackBool True]], [])
+    elseToPair (Just bs) = ([BLinear [OpPushData $ StackBool True]], bs)
+
+--ifP = do
+--  c <- tagP T_IF *> mult blockP <* tagP T_DO
+--  b <- mult blockP <* tagP T_END
+--  return $ BIf c b
+
+{-
+exactly 1: IF   [blocks] DO [blocks]
+0 or many: ELIF [blocks] DO [blocks]
+0 or 1:    ELSE [blocks]
+exactly 1: END
+
+IF c1 DO b1 ELIF c2 DO b2 ELIF c3 DO b3 ELSE b4
+-}
 
-ifElseP :: DSLParser Block
-ifElseP = do
-  c <- tagP T_IF *> mult blockP <* tagP T_DO
-  b1 <- mult blockP <* tagP T_ELSE
-  b2 <- mult blockP <* tagP T_END
-  return $ BIfElse c b1 b2
 
 whileP :: DSLParser Block
 whileP = do
@@ -169,7 +187,6 @@ procP = front `plus` back
 
 blockP :: DSLParser Block
 blockP = firstOf [ whileP
-                 , ifElseP
                  , ifP
                  , linearP
                  ]
diff --git a/DSL/Types.hs b/DSL/Types.hs
index dbed203..431a361 100644
--- a/DSL/Types.hs
+++ b/DSL/Types.hs
@@ -59,8 +59,7 @@ data StackModifier = StackModifier { smName :: String
 
 data Block
   = BLinear [Operation]
-  | BIf [Block] [Block]
-  | BIfElse [Block] [Block] [Block]
+  | BIf [Block] [Block] [Block]
   | BWhile [Block] [Block]
     deriving (Show)
 
@@ -78,6 +77,7 @@ data TokenTag
   | T_COMMENT
   | T_PROC
   | T_IF
+  | T_ELIF
   | T_ELSE
   | T_WHILE
   | T_DO