perga/lib/Parser.hs

{-# LANGUAGE TupleSections #-}

module Parser where

import Control.Monad.Except
import Data.List (foldl, 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

mkAbs :: Maybe IRExpr -> (Text, IRExpr) -> IRExpr -> IRExpr
mkAbs ascription (param, typ) = Abs param typ ascription

mkPi :: Maybe IRExpr -> (Text, IRExpr) -> IRExpr -> IRExpr
mkPi ascription (param, typ) = Pi param typ ascription

pLAbs :: Parser IRExpr
pLAbs = lexeme $ label "λ-abstraction" $ do
    _ <- defChoice $ "λ" :| ["fun"]
    params <- pSomeParams
    ascription <- optional pAscription
    _ <- defChoice $ "=>" :| ["⇒"]
    body <- pIRExpr
    pure $ foldr (mkAbs ascription) body params

pPAbs :: Parser IRExpr
pPAbs = lexeme $ label "Π-abstraction" $ do
    _ <- defChoice $ "∏" :| ["forall", "∀"]
    params <- pSomeParams
    ascription <- optional pAscription
    eat ","
    body <- pIRExpr
    pure $ foldr (mkPi ascription) 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 (mkPi Nothing)) params <$> ascription
        , foldr (mkAbs Nothing) 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 Nothing <$> pIRExpr

pApp :: Parser IRExpr
pApp = lexeme $ foldl1 App <$> some pTerm

pStar :: Parser IRExpr
pStar = lexeme $ Star <$ eat "*"

pSquare :: Parser IRExpr
pSquare = lexeme $ Level 0 <$ defChoice ("□" :| ["[]"])

subscriptDigit :: Parser Integer
subscriptDigit =
    choice
        [ chunk "₀" >> pure 0
        , chunk "₁" >> pure 1
        , chunk "₂" >> pure 2
        , chunk "₃" >> pure 3
        , chunk "₄" >> pure 4
        , chunk "₅" >> pure 5
        , chunk "₆" >> pure 6
        , chunk "₇" >> pure 7
        , chunk "₈" >> pure 8
        , chunk "₉" >> pure 9
        ]

subscriptInt :: Parser Integer
subscriptInt = foldl (\acc d -> acc * 10 + d) 0 <$> some subscriptDigit

pNumSort :: Parser IRExpr
pNumSort = lexeme $ pSquare >> Level <$> (L.decimal <|> subscriptInt)

pSort :: Parser IRExpr
pSort = lexeme $ pStar <|> try pNumSort <|> pSquare

pAxiom :: Parser IRDef
pAxiom = lexeme $ label "axiom" $ do
    eat "axiom"
    ident <- pIdentifier
    params <- pManyParams
    ascription <- fmap (flip (foldr (mkPi Nothing)) 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 (mkPi Nothing)) params) <$> optional pAscription
    eat ":="
    body <- pIRExpr
    eat ";"
    pure $ Def ident ascription $ foldr (mkAbs Nothing) 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