diff options
Diffstat (limited to 'DSL')
| -rw-r--r-- | DSL/BaseParsers.hs | 3 | ||||
| -rw-r--r-- | DSL/Interpretation.hs | 13 | ||||
| -rw-r--r-- | DSL/Parsing.hs | 30 | ||||
| -rw-r--r-- | DSL/Types.hs | 8 |
4 files changed, 46 insertions, 8 deletions
diff --git a/DSL/BaseParsers.hs b/DSL/BaseParsers.hs index b4b5234..4da9c38 100644 --- a/DSL/BaseParsers.hs +++ b/DSL/BaseParsers.hs @@ -81,6 +81,9 @@ chain p q = do phrase :: Parser t a -> Parser t a phrase = (<* eof) +plus :: Parser t a -> Parser t b -> Parser t (a, b) +plus = liftA2 (,) + recover :: a -> Parser t a -> Parser t a recover x p = p <|> pure x diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs index a53be8b..e02bc74 100644 --- a/DSL/Interpretation.hs +++ b/DSL/Interpretation.hs @@ -7,7 +7,7 @@ import DSL.Util import DSL.Intrinsics newMachine :: Machine -newMachine = Machine { ok=True, stack=[] } +newMachine = Machine { ok=True, stack=[], pTable=[] } pushData :: Machine -> StackData -> Machine pushData m@Machine{ stack=xs } x = m{ stack=x:xs } @@ -43,11 +43,18 @@ applyIntrinsic i m = do I_LESSTHAN -> lessThan I_GREATERTHAN -> greaterThan +applyCall :: ProcName -> Machine -> IO Machine +applyCall _ m@Machine{ ok=False } = return m +applyCall name m@Machine{ pTable=t } = case lookup name t of + Nothing -> hcf m $ "PROCCALL: undefined proc: " ++ name + Just bs -> evalBlocks bs m + applyOperation :: Machine -> Operation -> IO Machine -- take no action if a previous step failed applyOperation m@Machine{ ok=False } _ = return m applyOperation m (OpPushData x) = return $ pushData m x applyOperation m (OpIntrinsic i) = applyIntrinsic i m +applyOperation m (OpCall name) = applyCall name m applyLinear :: Machine -> [Operation] -> IO Machine applyLinear = foldlM applyOperation @@ -95,6 +102,6 @@ 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 () +interpret :: ([ProcSpec], Program) -> IO () +interpret (t, p) = evalBlocks p newMachine{ pTable=t } >> return () diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs index 76acacd..d255c35 100644 --- a/DSL/Parsing.hs +++ b/DSL/Parsing.hs @@ -20,7 +20,8 @@ wsL :: DSLLexer wsL = buildDSLLexer (mult1 $ satisfy isSpace) T_WHITESPACE keywordL :: DSLLexer -keywordL = fromTableL [ ("IF", T_IF) +keywordL = fromTableL [ ("PROC", T_PROC) + , ("IF", T_IF) , ("ELSE", T_ELSE) , ("WHILE", T_WHILE) , ("DO", T_DO) @@ -53,6 +54,11 @@ literalL = firstOf [ intLiteralL , stringLiteralL ] +identifierL :: DSLLexer +identifierL = buildDSLLexer go T_IDENTIFIER + where + go = mult1 $ satisfy $ not . isSpace + intrinsicL :: DSLLexer intrinsicL = fromTableL [ (".", T_INTRINSIC I_DUMP) , ("DROP", T_INTRINSIC I_DROP) @@ -77,6 +83,7 @@ lexemeL :: DSLLexer lexemeL = firstOf [ keywordL , literalL , intrinsicL + , identifierL ] tokenizer :: Parser Char [Token] @@ -112,9 +119,13 @@ intrinsicP = do T_INTRINSIC i -> result $ OpIntrinsic i _ -> flunk +callP :: DSLParser Operation +callP = OpCall . tStr <$> tagP T_IDENTIFIER + operationP :: DSLParser Operation operationP = firstOf [ pushDataP , intrinsicP + , callP ] linearP :: DSLParser Block @@ -139,6 +150,12 @@ whileP = do b <- mult blockP <* tagP T_END return $ BWhile c b +procP :: DSLParser ProcSpec +procP = front `plus` back + where + front = tagP T_PROC >> tStr <$> tagP T_IDENTIFIER + back = mult blockP <* tagP T_END + blockP :: DSLParser Block blockP = firstOf [ whileP , ifElseP @@ -146,9 +163,12 @@ blockP = firstOf [ whileP , linearP ] -programP :: DSLParser Program -programP = phrase $ mult1 blockP +programP :: DSLParser ([ProcSpec], Program) +programP = phrase $ procs `plus` code + where + procs = mult procP + code = mult1 blockP -stringToProgram :: String -> Maybe Program -stringToProgram = fmap snd . parse (chain tokenizer programP) +stringToProgram :: String -> Maybe ([ProcSpec], Program) +stringToProgram = fmap snd . parse (tokenizer `chain` programP) diff --git a/DSL/Types.hs b/DSL/Types.hs index bb1f862..0a4de3f 100644 --- a/DSL/Types.hs +++ b/DSL/Types.hs @@ -42,9 +42,12 @@ data Intrinsic | I_GREATERTHAN deriving (Show, Eq) +type ProcName = String + data Operation = OpPushData StackData | OpIntrinsic Intrinsic + | OpCall ProcName deriving (Show) data StackModifier = StackModifier { smName :: String @@ -59,14 +62,18 @@ data Block | BWhile [Block] [Block] deriving (Show) +type ProcSpec = (ProcName, [Block]) + type Program = [Block] data Machine = Machine { ok :: Bool , stack :: Stack + , pTable :: [(ProcName, [Block])] } data TokenTag = T_WHITESPACE + | T_PROC | T_IF | T_ELSE | T_WHILE @@ -76,6 +83,7 @@ data TokenTag | T_BOOL_LITERAL | T_STRING_LITERAL | T_INTRINSIC Intrinsic + | T_IDENTIFIER deriving (Show, Eq) data Token = Token { tStr :: String -- original text |