diff options
| -rw-r--r-- | DSL.hs | 51 | ||||
| -rw-r--r-- | Parsers.hs | 3 |
2 files changed, 46 insertions, 8 deletions
@@ -54,6 +54,7 @@ data StackModifier = StackModifier { smName :: String data Block = BLinear [Operation] + | BIf Block Block deriving (Show) type Program = [Block] @@ -64,6 +65,9 @@ data Machine = Machine { ok :: Bool data TokenData = T_WHITESPACE + | T_IF + | T_DO + | T_END | T_BOOL_LITERAL Bool | T_INT_LITERAL Integer | T_INTRINSIC Intrinsic @@ -87,8 +91,11 @@ buildDSLLexer p f = do , tData=f str } +keywordL :: String -> TokenData -> DSLLexer +keywordL s d = buildDSLLexer (list s) (const d) + intrinsicL :: String -> Intrinsic -> DSLLexer -intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i) +intrinsicL s i = keywordL s $ T_INTRINSIC i wsL :: DSLLexer wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE) @@ -110,7 +117,14 @@ intLiteralL = buildDSLLexer go (T_INT_LITERAL . read) mainLexer :: Parser Char [DSLToken] mainLexer = phrase $ mult1 $ firstOf subLexers where - subLexers = [wsL] ++ literals ++ intrinsics + subLexers = [wsL] + ++ keywords + ++ literals + ++ intrinsics + keywords = map (uncurry keywordL) [ ("IF", T_IF) + , ("DO", T_DO) + , ("END", T_END) + ] literals = [ boolLiteralL , intLiteralL ] @@ -130,6 +144,9 @@ mainLexer = phrase $ mult1 $ firstOf subLexers , ("^", I_XOR) ] +stripWhitespace :: [DSLToken] -> [DSLToken] +stripWhitespace = filter $ not . (==T_WHITESPACE) . tData + ------------------------------------------------------------------------------ -- Parsing ------------------------------------------------------------------------------ @@ -165,13 +182,19 @@ operationP = firstOf [ pushDataP ] linearP :: DSLParser Block -linearP = do - ops <- optional wsP *> operationP `sepBy1` wsP <* optional wsP - eof - return $ BLinear ops +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) + return $ BIf c b blockP :: DSLParser Block -blockP = firstOf [linearP] +blockP = firstOf [ ifP + , linearP + ] programP :: DSLParser Program programP = phrase $ mult1 blockP @@ -179,7 +202,7 @@ programP = phrase $ mult1 blockP stringToProgram :: String -> Maybe Program stringToProgram str = do (_, tokens) <- parse mainLexer str - (_, program) <- parse programP tokens + (_, program) <- parse programP $ stripWhitespace tokens return program ------------------------------------------------------------------------------ @@ -349,10 +372,22 @@ applyOperation m (OpIntrinsic i) = applyIntrinsic i 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 + 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" + 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 interpret :: Program -> IO () interpret p = evalBlocks p newMachine >> return () @@ -39,6 +39,9 @@ instance Alternative (Parser t) where instance MonadPlus (Parser t) +instance MonadFail (Parser t) where + fail _ = mzero + ----------------------------------------------------------------------------- flunk :: Parser t a |