summaryrefslogtreecommitdiff
path: root/hs/Parser.hs
diff options
context:
space:
mode:
authorTom Smeding <tom@tomsmeding.com>2023-05-21 22:00:40 +0200
committerTom Smeding <tom@tomsmeding.com>2023-05-21 22:00:40 +0200
commit0ef6d707911b3cc57a0bee5db33a444237219c29 (patch)
tree0e0a8572924b5d944c77a32d962131a0fe5cbb75 /hs/Parser.hs
parent164a8d297429d58d216b9fa44e0cb42db5d23e2c (diff)
Find old Haskell implementation on backup diskHEADmaster
GHC 8.0.2 vintage, doesn't compile
Diffstat (limited to 'hs/Parser.hs')
-rw-r--r--hs/Parser.hs163
1 files changed, 163 insertions, 0 deletions
diff --git a/hs/Parser.hs b/hs/Parser.hs
new file mode 100644
index 0000000..d37f1cd
--- /dev/null
+++ b/hs/Parser.hs
@@ -0,0 +1,163 @@
+module Parser(parseProgram) where
+
+import Control.Monad
+import Data.Char
+import Text.Parsec
+import qualified Text.Parsec.Expr as E
+
+import AST
+
+
+type Parser = Parsec String ()
+
+
+(<<) :: (Monad m) => m a -> m b -> m a
+(<<) = (<*)
+
+parseProgram :: Maybe String -> String -> Either ParseError Program
+parseProgram fname src = parse pProgram (maybe "" id fname) src
+
+pProgram :: Parser Program
+pProgram = (pWhiteComment >> ((Program . Block) <$> pStatement `sepBy` pWhiteComment)) << eof
+
+pStatement :: Parser Statement
+pStatement = pCondition <|> pDeclarationAssignment <|> pDive <|> pExpressionStatement <?> "statement"
+
+pDeclarationAssignment :: Parser Statement
+pDeclarationAssignment = (do
+ (n, constr) <- try $ do -- after we've seen the assignment operator, there's no turning back
+ n' <- pName
+ constr' <- (symbol ":=" >> return Declaration) <|> (symbol "=" >> return Assignment)
+ return (n', constr')
+
+ e <- pExpression
+ symbol ";" <|> void (lookAhead (char '}'))
+ return $ constr n e) <?> "variable declaration or assignment"
+
+pCondition :: Parser Statement
+pCondition = do
+ symbol "if"
+ cond <- pExpression
+ e1 <- pBlock
+ e2 <- (symbol "else" >> pBlock) <|> return (Block [])
+ return $ Condition cond e1 e2
+
+pExpressionStatement :: Parser Statement
+pExpressionStatement = (Expr <$> pExpression) << symbol ";"
+
+pDive :: Parser Statement
+pDive = do
+ n <- try $ do
+ n' <- pName
+ void $ lookAhead (oneOf "({")
+ return n'
+
+ al <- option [] $ between (symbol "(") (symbol ")") $ pExpression `sepBy` symbol ","
+ (symbol ";" >> return (Dive n al (Block []))) <|> (Dive n al <$> pBlock)
+
+
+pExpression :: Parser Expression
+pExpression = E.buildExpressionParser table pExpressionTerm
+ where
+ table = [[E.Prefix (symbol "-" >> return (EUn UONeg)),
+ E.Prefix (symbol "!" >> return (EUn UONot))],
+ [E.Infix (symbol "**" >> return (EBin BOPow)) E.AssocRight],
+ [E.Infix (symbol "*" >> return (EBin BOMul)) E.AssocLeft,
+ E.Infix (symbol "/" >> return (EBin BODiv)) E.AssocLeft,
+ E.Infix (symbol "%" >> return (EBin BOMod)) E.AssocLeft],
+ [E.Infix (symbol "+" >> return (EBin BOPlus)) E.AssocLeft,
+ E.Infix (symbol "-" >> return (EBin BOMinus)) E.AssocLeft],
+ [E.Infix (symbol "<=" >> return (EBin BOLEq)) E.AssocNone,
+ E.Infix (symbol ">=" >> return (EBin BOGEq)) E.AssocNone,
+ E.Infix (symbol "==" >> return (EBin BOEqual)) E.AssocNone,
+ E.Infix (symbol "<" >> return (EBin BOLess)) E.AssocNone,
+ E.Infix (symbol ">" >> return (EBin BOGreater)) E.AssocNone],
+ [E.Infix (symbol "&&" >> return (EBin BOBoolAnd)) E.AssocLeft,
+ E.Infix (symbol "||" >> return (EBin BOBoolOr)) E.AssocLeft]]
+
+ pExpressionTerm :: Parser Expression
+ pExpressionTerm = pParenExpression <|> (ELit <$> pLiteral)
+
+pBlock :: Parser Block
+pBlock = Block <$> between (symbol "{") (symbol "}") (many pStatement)
+
+pParenExpression :: Parser Expression
+pParenExpression = between (symbol "(") (symbol ")") pExpression
+
+pLiteral :: Parser Literal
+pLiteral = (pLNil <|> pLStr <|> pLNum <|> pLBlock <|> (LVar <$> pName)
+ <?> "literal") << pWhiteComment
+
+pLNil :: Parser Literal
+pLNil = symbol "nil" >> return LNil
+
+pLBlock :: Parser Literal
+pLBlock = (LBlock BT0 [] <$> pBlock) <|> do
+ symbol "??"
+ al <- option [] $ between (symbol "(") (symbol ")") $ pName `sepBy` symbol ","
+ b <- pBlock
+ return $ LBlock BT2 al b
+
+pLNum :: Parser Literal
+pLNum = pDecimal <|> pHexa
+ where
+ pDecimal = do
+ pre <- many1 digit <|> (lookAhead (char '.') >> return "")
+ post <- ((:) <$> char '.' <*> many1 digit) <|> return ""
+ ex <- pExponent <|> return ""
+ return $ LNum $ read $ pre ++ post ++ ex
+
+ pHexa = do
+ void $ string "0x"
+ pre <- many1 hexDigit
+ return $ LNum $ read $ "0x" ++ pre
+
+ pExponent = do
+ void $ char 'e'
+ sgn <- (char '+' >> return "") <|> string "-" <|> return ""
+ dig <- many1 digit
+ return $ 'e' : sgn ++ dig
+
+pLStr :: Parser Literal
+pLStr = LStr <$> between (char '"') (char '"') pStrContents
+ where
+ pStrContents = many pStrChar
+ pStrChar = (char '\\' >> pEscape) <|> noneOf "\""
+ pEscape = (char 'n' >> return '\n') <|>
+ (char 'r' >> return '\r') <|>
+ (char 't' >> return '\t') <|>
+ char '"' <|> char '\\'
+
+
+pName :: Parser Name
+pName = do
+ c <- satisfy (isAlpha .||. (== '_'))
+ rest <- many (satisfy (isAlphaNum .||. (== '_')))
+ pWhiteComment
+ return $ c : rest
+
+
+pWhiteComment :: Parser ()
+pWhiteComment = void $ pWhite `sepBy` pComment
+
+pWhite :: Parser ()
+pWhite = void $ many (oneOf " \t\n")
+
+pComment :: Parser ()
+pComment = pLineComment <|> pBlockComment
+
+pLineComment :: Parser ()
+pLineComment = void $ try (string "//") >> manyTill anyChar (void (char '\n') <|> eof)
+
+pBlockComment :: Parser ()
+pBlockComment = void $ try (string "/*") >> manyTill anyChar (try (string "*/"))
+
+symbol :: String -> Parser ()
+symbol s = do
+ void $ try (string s)
+ when (not (null s) && isAlphaNum (last s)) $ notFollowedBy alphaNum
+ pWhiteComment
+
+infixr 2 .||.
+(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+f .||. g = \x -> f x || g x