🤡

a5/src/APL/Parser.hs

@@ -0,0 +1,168 @@
+module APL.Parser (parseAPL, keywords) where
+
+import APL.AST (Exp (..), VName)
+import Control.Monad (void)
+import Data.Char (isAlpha, isAlphaNum, isDigit)
+import Data.Void (Void)
+import Text.Megaparsec
+  ( Parsec,
+    choice,
+    chunk,
+    eof,
+    errorBundlePretty,
+    many,
+    notFollowedBy,
+    parse,
+    satisfy,
+    some,
+    try,
+  )
+import Text.Megaparsec.Char (space)
+
+type Parser = Parsec Void String
+
+lexeme :: Parser a -> Parser a
+lexeme p = p <* space
+
+keywords :: [String]
+keywords =
+  [ "if",
+    "then",
+    "else",
+    "true",
+    "false",
+    "let",
+    "in",
+    "try",
+    "catch"
+  ]
+
+lVName :: Parser VName
+lVName = lexeme $ try $ do
+  c <- satisfy isAlpha
+  cs <- many $ satisfy isAlphaNum
+  let v = c : cs
+  if v `elem` keywords
+    then fail "Unexpected keyword"
+    else pure v
+
+lInteger :: Parser Integer
+lInteger =
+  lexeme $ read <$> some (satisfy isDigit) <* notFollowedBy (satisfy isAlphaNum)
+
+lString :: String -> Parser ()
+lString s = lexeme $ void $ chunk s
+
+lKeyword :: String -> Parser ()
+lKeyword s = lexeme $ void $ try $ chunk s <* notFollowedBy (satisfy isAlphaNum)
+
+lBool :: Parser Bool
+lBool =
+  lexeme . try . choice $
+    [ const True <$> lKeyword "true",
+      const False <$> lKeyword "false"
+    ]
+
+pAtom :: Parser Exp
+pAtom =
+  choice
+    [ CstInt <$> lInteger,
+      CstBool <$> lBool,
+      Var <$> lVName,
+      lString "(" *> pExp <* lString ")"
+    ]
+
+pFExp :: Parser Exp
+pFExp = chain =<< pAtom
+  where
+    chain x =
+      choice
+        [ do
+            y <- pAtom
+            chain $ Apply x y,
+          pure x
+        ]
+
+pLExp :: Parser Exp
+pLExp =
+  choice
+    [ If
+        <$> (lKeyword "if" *> pExp)
+        <*> (lKeyword "then" *> pExp)
+        <*> (lKeyword "else" *> pExp),
+      Lambda
+        <$> (lString "\\" *> lVName)
+        <*> (lString "->" *> pExp),
+      TryCatch
+        <$> (lKeyword "try" *> pExp)
+        <*> (lKeyword "catch" *> pExp),
+      Let
+        <$> (lKeyword "let" *> lVName)
+        <*> (lString "=" *> pExp)
+        <*> (lKeyword "in" *> pExp),
+      pFExp
+    ]
+
+pExp4 :: Parser Exp
+pExp4 = pLExp >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "**"
+            y <- pLExp
+            Pow x <$> chain y,
+          pure x
+        ]
+
+pExp3 :: Parser Exp
+pExp3 = pExp4 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "*"
+            y <- pExp4
+            chain $ Mul x y,
+          do
+            lString "/"
+            y <- pExp4
+            chain $ Div x y,
+          pure x
+        ]
+
+pExp2 :: Parser Exp
+pExp2 = pExp3 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "+"
+            y <- pExp3
+            chain $ Add x y,
+          do
+            lString "-"
+            y <- pExp3
+            chain $ Sub x y,
+          pure x
+        ]
+
+pExp1 :: Parser Exp
+pExp1 = pExp2 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "=="
+            y <- pExp2
+            chain $ Eql x y,
+          pure x
+        ]
+
+pExp :: Parser Exp
+pExp = pExp1
+
+parseAPL :: FilePath -> String -> Either String Exp
+parseAPL fname s = case parse (space *> pExp <* eof) fname s of
+  Left err -> Left $ errorBundlePretty err
+  Right x -> Right x