183 lines
5 KiB
Haskell
183 lines
5 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Parser where
|
|
|
|
import Control.Monad.Except
|
|
import Data.List (foldl1)
|
|
import qualified Data.Text as T
|
|
import Errors (Error (..))
|
|
import IR
|
|
import Preprocessor
|
|
import Text.Megaparsec (Parsec, ShowErrorComponent (..), between, choice, chunk, errorBundlePretty, label, runParser, try)
|
|
import Text.Megaparsec.Char
|
|
import qualified Text.Megaparsec.Char.Lexer as L
|
|
|
|
newtype TypeError = TE Error
|
|
deriving (Eq, Ord)
|
|
|
|
type Parser = Parsec TypeError Text
|
|
|
|
instance ShowErrorComponent TypeError where
|
|
showErrorComponent (TE e) = toString e
|
|
|
|
skipSpace :: Parser ()
|
|
skipSpace =
|
|
L.space
|
|
space1
|
|
(L.skipLineComment "--")
|
|
(L.skipBlockCommentNested "[*" "*]")
|
|
|
|
lexeme :: Parser a -> Parser a
|
|
lexeme = L.lexeme skipSpace
|
|
|
|
eat :: Text -> Parser ()
|
|
eat = void . lexeme . chunk
|
|
|
|
keywords :: [Text]
|
|
keywords = ["forall", "let", "in", "end", "fun", "def", "axiom"]
|
|
|
|
reservedChars :: [Char]
|
|
reservedChars = "();:"
|
|
|
|
pIdentifier :: Parser Text
|
|
pIdentifier = try $ label "identifier" $ lexeme $ do
|
|
firstChar <- letterChar <|> char '_'
|
|
rest <- many $ alphaNumChar <|> char '_'
|
|
let ident = T.pack (firstChar : rest)
|
|
when (ident `elem` keywords) $
|
|
fail $
|
|
"Reserved word: " ++ T.unpack ident
|
|
pure ident
|
|
|
|
pVar :: Parser IRExpr
|
|
pVar = label "variable" $ lexeme $ Var <$> pIdentifier
|
|
|
|
defChoice :: NonEmpty Text -> Parser ()
|
|
defChoice options = lexeme $ label (T.unpack $ head options) $ void $ choice $ fmap chunk options
|
|
|
|
pParamGroup :: Parser [Param]
|
|
pParamGroup = lexeme $ label "parameter group" $ between (char '(') (char ')') $ do
|
|
idents <- some pIdentifier
|
|
eat ":"
|
|
ty <- pIRExpr
|
|
pure $ map (,ty) idents
|
|
|
|
pSomeParams :: Parser [Param]
|
|
pSomeParams = lexeme $ concat <$> some pParamGroup
|
|
|
|
pManyParams :: Parser [Param]
|
|
pManyParams = lexeme $ concat <$> many pParamGroup
|
|
|
|
pLAbs :: Parser IRExpr
|
|
pLAbs = lexeme $ label "λ-abstraction" $ do
|
|
_ <- defChoice $ "λ" :| ["fun"]
|
|
params <- pSomeParams
|
|
_ <- defChoice $ "=>" :| ["⇒"]
|
|
body <- pIRExpr
|
|
pure $ foldr (uncurry Abs) body params
|
|
|
|
pPAbs :: Parser IRExpr
|
|
pPAbs = lexeme $ label "Π-abstraction" $ do
|
|
_ <- defChoice $ "∏" :| ["forall", "∀"]
|
|
params <- pSomeParams
|
|
eat ","
|
|
body <- pIRExpr
|
|
pure $ foldr (uncurry Pi) body params
|
|
|
|
pBinding :: Parser (Text, Maybe IRExpr, IRExpr)
|
|
pBinding = lexeme $ label "binding" $ do
|
|
eat "("
|
|
ident <- pIdentifier
|
|
params <- pManyParams
|
|
ascription <- optional pAscription
|
|
eat ":="
|
|
value <- pIRExpr
|
|
eat ")"
|
|
pure
|
|
( ident
|
|
, flip (foldr (uncurry Pi)) params <$> ascription
|
|
, foldr (uncurry Abs) value params
|
|
)
|
|
|
|
pLet :: Parser IRExpr
|
|
pLet = lexeme $ label "let expression" $ do
|
|
eat "let"
|
|
bindings <- some pBinding
|
|
eat "in"
|
|
body <- try pIRExpr
|
|
eat "end"
|
|
pure $ foldr letTuple body bindings
|
|
where
|
|
letTuple :: (Text, Maybe IRExpr, IRExpr) -> IRExpr -> IRExpr
|
|
letTuple (name, ascription, value) = Let name ascription value
|
|
|
|
pArrow :: Parser IRExpr
|
|
pArrow = lexeme $ label "->" $ do
|
|
a <- pAppTerm
|
|
_ <- defChoice $ "->" :| ["→"]
|
|
Pi "" a <$> pIRExpr
|
|
|
|
pApp :: Parser IRExpr
|
|
pApp = lexeme $ foldl1 App <$> some pTerm
|
|
|
|
pStar :: Parser IRExpr
|
|
pStar = lexeme $ Level 0 <$ eat "*"
|
|
|
|
pNumSort :: Parser IRExpr
|
|
pNumSort = lexeme $ label "sort" $ eat "*" >> Level <$> L.decimal
|
|
|
|
pSort :: Parser IRExpr
|
|
pSort = lexeme $ try pNumSort <|> pStar
|
|
|
|
pAxiom :: Parser IRDef
|
|
pAxiom = lexeme $ label "axiom" $ do
|
|
eat "axiom"
|
|
ident <- pIdentifier
|
|
params <- pManyParams
|
|
ascription <- fmap (flip (foldr (uncurry Pi)) params) pAscription
|
|
eat ";"
|
|
pure $ Axiom ident ascription
|
|
|
|
pDef :: Parser IRDef
|
|
pDef = lexeme $ label "definition" $ do
|
|
eat "def"
|
|
ident <- pIdentifier
|
|
params <- pManyParams
|
|
ascription <- fmap (flip (foldr (uncurry Pi)) params) <$> optional pAscription
|
|
eat ":="
|
|
body <- pIRExpr
|
|
eat ";"
|
|
pure $ Def ident ascription $ foldr (uncurry Abs) body params
|
|
|
|
pIRDef :: Parser IRDef
|
|
pIRDef = pAxiom <|> pDef
|
|
|
|
pTerm :: Parser IRExpr
|
|
pTerm = lexeme $ label "term" $ choice [pSort, pVar, between (char '(') (char ')') pIRExpr]
|
|
|
|
pAppTerm :: Parser IRExpr
|
|
pAppTerm = lexeme $ choice [pLAbs, pPAbs, pLet, pApp]
|
|
|
|
pIRExpr :: Parser IRExpr
|
|
pIRExpr = lexeme $ try pArrow <|> pAppTerm
|
|
|
|
pAscription :: Parser IRExpr
|
|
pAscription = lexeme $ try $ eat ":" >> label "type" pIRExpr
|
|
|
|
pIRProgram :: Parser IRProgram
|
|
pIRProgram = skipSpace >> some pIRDef
|
|
|
|
parserWrapper :: Parser a -> String -> Text -> Either String a
|
|
parserWrapper p filename input = first errorBundlePretty $ runParser p filename input
|
|
|
|
parseProgram :: String -> Text -> Either String IRProgram
|
|
parseProgram = parserWrapper pIRProgram
|
|
|
|
parseDef :: String -> Text -> Either String IRDef
|
|
parseDef = parserWrapper pIRDef
|
|
|
|
parseExpr :: String -> Text -> Either String IRExpr
|
|
parseExpr = parserWrapper pIRExpr
|
|
|
|
handleFile :: String -> ExceptT String IO IRProgram
|
|
handleFile filename = toString `withExceptT` runPreprocessor filename >>= hoistEither . parseProgram filename
|