{-# LANGUAGE FlexibleInstances #-}
module Language.Elsa.Parser
( parse
, parseFile
) where
import qualified Control.Exception as Ex
import Control.Monad (void)
import Text.Megaparsec hiding (parse)
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Char
import Text.Megaparsec.Stream ()
import qualified Data.List as L
import Language.Elsa.Types
import Language.Elsa.UX
import Data.List.NonEmpty as NE
type Parser = Parsec SourcePos Text
parse :: FilePath -> Text -> SElsa
parse = parseWith elsa
parseWith :: Parser a -> FilePath -> Text -> a
parseWith p f s = case runParser (whole p) f s of
Left pErrs -> Ex.throw (mkErrors pErrs)
Right e -> e
mkErrors :: ParseErrorBundle Text SourcePos -> [UserError]
mkErrors b = [ mkError (parseErrorPretty e) (sp b) | e <- NE.toList (bundleErrors b)]
where
sp = posSpan . pstateSourcePos . bundlePosState
instance ShowErrorComponent SourcePos where
showErrorComponent = show
parseFile :: FilePath -> IO SElsa
parseFile f = parse f <$> readFile f
whole :: Parser a -> Parser a
whole p = sc *> p <* eof
sc :: Parser ()
sc = L.space (void spaceChar) lineCmnt blockCmnt
where
lineCmnt = L.skipLineComment "--"
blockCmnt = L.skipBlockComment "{-" "-}"
symbol :: String -> Parser String
symbol = L.symbol sc
arrow :: Parser String
arrow = symbol "->"
colon :: Parser String
colon = symbol ":"
equal :: Parser String
equal = symbol "="
lam :: Parser String
lam = symbol "\\"
parens :: Parser a -> Parser a
parens = betweenS "(" ")"
betweenS :: String -> String -> Parser a -> Parser a
betweenS l r = between (symbol l) (symbol r)
lexeme :: Parser a -> Parser (a, SourceSpan)
lexeme p = L.lexeme sc (withSpan p)
rWord :: String -> Parser SourceSpan
rWord w = snd <$> (withSpan (string w) <* notFollowedBy alphaNumChar <* sc)
keywords :: [Text]
keywords = [ "let" , "eval" ]
identifier :: Parser (String, SourceSpan)
identifier = lexeme (p >>= check)
where
p = (:) <$> letterChar <*> many identChar
check x = if x `elem` keywords
then fail $ "keyword " ++ show x ++ " cannot be an identifier"
else return x
identChar :: Parser Char
identChar = alphaNumChar
<|> oneOf ['_', '#', '\'']
binder :: Parser SBind
binder = uncurry Bind <$> identifier
withSpan' :: Parser (SourceSpan -> a) -> Parser a
withSpan' p = do
p1 <- getSourcePos
f <- p
p2 <- getSourcePos
return (f (SS p1 p2))
withSpan :: Parser a -> Parser (a, SourceSpan)
withSpan p = do
p1 <- getSourcePos
x <- p
p2 <- getSourcePos
return (x, SS p1 p2)
elsa :: Parser SElsa
elsa = Elsa <$> many defn <*> many eval
defn :: Parser SDefn
defn = do
rWord "let"
b <- binder <* equal
e <- expr
return (Defn b e)
eval :: Parser SEval
eval = do
rWord "eval"
name <- binder
colon
root <- expr
steps <- many step
return $ Eval name root steps
step :: Parser SStep
step = Step <$> eqn <*> expr
eqn :: Parser SEqn
eqn = try (withSpan' (symbol "=a>" >> return AlphEq))
<|> try (withSpan' (symbol "=b>" >> return BetaEq))
<|> try (withSpan' (symbol "<b=" >> return UnBeta))
<|> try (withSpan' (symbol "=d>" >> return DefnEq))
<|> try (withSpan' (symbol "=*>" >> return TrnsEq))
<|> try (withSpan' (symbol "<*=" >> return UnTrEq))
<|> (withSpan' (symbol "=~>" >> return NormEq))
expr :: Parser SExpr
expr = try lamExpr
<|> try appExpr
<|> try idExpr
<|> parenExpr
parenExpr :: Parser SExpr
parenExpr = parens expr
idExpr :: Parser SExpr
idExpr = uncurry EVar <$> identifier
appExpr :: Parser SExpr
appExpr = apps <$> funExpr <*> sepBy1 funExpr sc
where
apps = L.foldl' (\e1 e2 -> EApp e1 e2 (tag e1 `mappend` tag e2))
funExpr :: Parser SExpr
funExpr = try idExpr <|> parenExpr
lamExpr :: Parser SExpr
lamExpr = do
lam
xs <- sepBy binder sc <* arrow
e <- expr
return (mkLam xs e)