diff options
Diffstat (limited to 'DSL.hs')
| -rw-r--r-- | DSL.hs | 34 |
1 files changed, 29 insertions, 5 deletions
@@ -61,6 +61,7 @@ data Block = BLinear [Operation] | BIf [Block] [Block] | BIfElse [Block] [Block] [Block] + | BWhile [Block] [Block] deriving (Show) type Program = [Block] @@ -73,6 +74,7 @@ data TokenData = T_WHITESPACE | T_IF | T_ELSE + | T_WHILE | T_DO | T_END | T_BOOL_LITERAL Bool @@ -128,10 +130,11 @@ mainLexer = phrase $ mult1 $ firstOf subLexers ++ keywords ++ literals ++ intrinsics - keywords = map (uncurry keywordL) [ ("IF", T_IF) - , ("ELSE", T_ELSE) - , ("DO", T_DO) - , ("END", T_END) + keywords = map (uncurry keywordL) [ ("IF", T_IF) + , ("ELSE", T_ELSE) + , ("WHILE", T_WHILE) + , ("DO", T_DO) + , ("END", T_END) ] literals = [ boolLiteralL , intLiteralL @@ -207,8 +210,15 @@ ifElseP = do b2 <- mult blockP <* tokenDataP T_END return $ BIfElse c b1 b2 +whileP :: DSLParser Block +whileP = do + c <- tokenDataP T_WHILE *> mult blockP <* tokenDataP T_DO + b <- mult blockP <* tokenDataP T_END + return $ BWhile c b + blockP :: DSLParser Block -blockP = firstOf [ ifElseP +blockP = firstOf [ whileP + , ifElseP , ifP , linearP ] @@ -435,12 +445,26 @@ applyIfElse c b1 b2 m = do Machine{ stack=StackBool False:xs } -> evalBlocks b2 m'{ stack=xs } Machine{ stack=_:_ } -> hcf m' "IF: type mis-match" +applyWhile :: [Block] -> [Block] -> Machine -> IO Machine +applyWhile _ _ m@Machine{ ok=False } = return m +applyWhile c b m = do + m' <- evalBlocks c m + case m' of + Machine{ ok=False } -> return m' + Machine{ stack=[] } -> hcf m' "WHILE: stack underflow" + Machine{ stack=StackBool False:xs } -> return m'{ stack=xs } + Machine{ stack=StackBool True:xs } -> do + m'' <- evalBlocks b m'{ stack=xs } + applyWhile c b m'' + Machine{ stack=_:_ } -> hcf m' "WHILE: 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 +evalBlocks (BWhile c b:bs) m = applyWhile c b m >>= evalBlocks bs interpret :: Program -> IO () interpret p = evalBlocks p newMachine >> return () |