diff options
Diffstat (limited to 'DSL/Parsing.hs')
| -rw-r--r-- | DSL/Parsing.hs | 146 |
1 files changed, 146 insertions, 0 deletions
diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs new file mode 100644 index 0000000..0b07679 --- /dev/null +++ b/DSL/Parsing.hs @@ -0,0 +1,146 @@ +module DSL.Parsing where + +import Data.Char (isDigit, isSpace) + +import DSL.Types +import DSL.BaseParsers + +buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer +buildDSLLexer p f = do + str <- p + return DSLToken { tStr=str + , tData=f str + } + +keywordL :: String -> TokenData -> DSLLexer +keywordL s d = buildDSLLexer (list s) (const d) + +intrinsicL :: String -> Intrinsic -> DSLLexer +intrinsicL s i = keywordL s $ T_INTRINSIC i + +wsL :: DSLLexer +wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE) + +boolLiteralL :: DSLLexer +boolLiteralL = t `alt` f + where + t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True) + f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False) + +intLiteralL :: DSLLexer +intLiteralL = buildDSLLexer go (T_INT_LITERAL . read) + where + go = do + sign <- optional $ token '-' + digits <- mult1 $ satisfy isDigit + result $ maybe digits (:digits) sign + +mainLexer :: Parser Char [DSLToken] +mainLexer = phrase $ mult1 $ firstOf subLexers + where + subLexers = [wsL] + ++ keywords + ++ literals + ++ intrinsics + keywords = map (uncurry keywordL) [ ("IF", T_IF) + , ("ELSE", T_ELSE) + , ("WHILE", T_WHILE) + , ("DO", T_DO) + , ("END", T_END) + ] + literals = [ boolLiteralL + , intLiteralL + ] + intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP) + , ("DROP", I_DROP) + , ("SWAP", I_SWAP) + , ("DUP", I_DUP) + , ("OVER", I_OVER) + , ("ROT", I_ROT) + , ("+", I_PLUS) + , ("-", I_MINUS) + , ("*", I_TIMES) + , ("/%", I_DIVMOD) + , ("!", I_NOT) + , ("&&", I_AND) + , ("||", I_OR) + , ("^", I_XOR) + , ("==", I_EQUAL) + , ("<", I_LESSTHAN) + , (">", I_GREATERTHAN) + ] + +stripWhitespace :: [DSLToken] -> [DSLToken] +stripWhitespace = filter $ not . (==T_WHITESPACE) . tData + +------------------------------------------------------------------------------ +-- Parsing +------------------------------------------------------------------------------ + +tokenDataP :: TokenData -> DSLParser DSLToken +tokenDataP t = satisfy $ (==t) . tData + +wsP :: DSLParser () +wsP = () <$ tokenDataP T_WHITESPACE + +dataLiteralP :: DSLParser StackData +dataLiteralP = do + t <- anyToken + case tData t of + T_INT_LITERAL x -> result $ StackInt x + T_BOOL_LITERAL x -> result $ StackBool x + _ -> flunk + +pushDataP :: DSLParser Operation +pushDataP = OpPushData <$> dataLiteralP + +intrinsicP :: DSLParser Operation +intrinsicP = do + t <- anyToken + case tData t of + T_INTRINSIC i -> result $ OpIntrinsic i + _ -> flunk + +operationP :: DSLParser Operation +operationP = firstOf [ pushDataP + , intrinsicP + ] + +linearP :: DSLParser Block +linearP = BLinear <$> mult1 operationP + +ifP :: DSLParser Block +ifP = do + c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO + b <- mult blockP <* tokenDataP T_END + return $ BIf c b + +ifElseP :: DSLParser Block +ifElseP = do + c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO + b1 <- mult blockP <* tokenDataP T_ELSE + 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 [ whileP + , ifElseP + , ifP + , linearP + ] + +programP :: DSLParser Program +programP = phrase $ mult1 blockP + +stringToProgram :: String -> Maybe Program +stringToProgram str = do + (_, tokens) <- parse mainLexer str + (_, program) <- parse programP $ stripWhitespace tokens + return program + |