diff options
| -rw-r--r-- | DSL.hs | 34 |
1 files changed, 30 insertions, 4 deletions
@@ -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 () |