diff options
| -rw-r--r-- | DSL.hs | 17 |
1 files changed, 11 insertions, 6 deletions
@@ -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 |