module Language.SystemF.Parser (
parseExpr,
parseType
) where
import Control.Monad
import Prelude hiding (abs)
import Text.Parsec
import Text.Parsec.String
import Language.SystemF.Expression
parseExpr :: String -> Either ParseError (SystemFExpr String String)
parseExpr = parse (whitespace *> expr <* eof) ""
parseType :: String -> Either ParseError (Ty String)
parseType = parse (whitespace *> ty <* eof) ""
expr :: Parser (SystemFExpr String String)
expr = try tyapp <|> try app <|> term
app :: Parser (SystemFExpr String String)
app = chainl1 term (return App)
tyapp :: Parser (SystemFExpr String String)
tyapp = TyApp
<$> term
<*> ty'
where ty' = symbol '[' *> ty <* symbol ']'
term :: Parser (SystemFExpr String String)
term = try abs <|> tyabs <|> var <|> parens expr
var :: Parser (SystemFExpr String String)
var = Var <$> exprId
abs :: Parser (SystemFExpr String String)
abs = curry
<$> (symbol '\\' *> many1 args <* symbol '.')
<*> expr
where args = (,) <$> (exprId <* symbol ':') <*> ty
curry = flip . foldr . uncurry $ Abs
tyabs :: Parser (SystemFExpr String String)
tyabs = curry <$> args <*> expr
where args = symbol '\\' *> many1 typeId <* symbol '.'
curry = flip (foldr TyAbs)
ty :: Parser (Ty String)
ty = try arrow
arrow :: Parser (Ty String)
arrow = chainr1 tyterm (symbol' "->" *> return TyArrow)
tyterm :: Parser (Ty String)
tyterm = tyvar <|> parens ty
tyvar :: Parser (Ty String)
tyvar = TyVar <$> typeId
parens :: Parser a -> Parser a
parens p = symbol '(' *> p <* symbol ')'
identifier :: Parser Char -> Parser String
identifier firstChar = lexeme ((:) <$> first <*> many rest)
where first = firstChar <|> char '_'
rest = first <|> digit
typeId, exprId :: Parser String
typeId = identifier upper
exprId = identifier lower
whitespace :: Parser ()
whitespace = void . many . oneOf $ " \t"
symbol :: Char -> Parser ()
symbol = void . lexeme . char
symbol' :: String -> Parser ()
symbol' = void . lexeme . string
lexeme :: Parser a -> Parser a
lexeme p = p <* whitespace