From 0ef6d707911b3cc57a0bee5db33a444237219c29 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 21 May 2023 22:00:40 +0200
Subject: Find old Haskell implementation on backup disk

GHC 8.0.2 vintage, doesn't compile
---
 hs/Parser.hs | 163 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 163 insertions(+)
 create mode 100644 hs/Parser.hs

(limited to 'hs/Parser.hs')

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
-- 
cgit v1.2.3-70-g09d2