169 lines
3.2 KiB
Haskell
169 lines
3.2 KiB
Haskell
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
|