perga/lib/Parser.hs

module Parser (pAll) where

import Control.Monad
import Control.Monad.State.Strict
import Data.Bifunctor (first)
import Data.Functor.Identity
import Data.List (elemIndex)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as T
import Expr (Expr (..), incIndices)
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

type InnerState = [Text]

data CustomErrors = UnboundVariable Text [Text] deriving (Eq, Ord, Show)

instance ShowErrorComponent CustomErrors where
    showErrorComponent (UnboundVariable var bound) =
        "Unbound variable: " ++ T.unpack var ++ ". Did you mean one of: " ++ T.unpack (T.unwords bound) ++ "?"

type Parser = ParsecT CustomErrors Text (State InnerState)

skipSpace :: Parser ()
skipSpace =
    L.space
        space1
        (L.skipLineComment "--")
        (L.skipBlockCommentNested "(*" "*)")

lexeme :: Parser a -> Parser a
lexeme = L.lexeme skipSpace

pIdentifier :: Parser Text
pIdentifier = label "identifier" $ lexeme $ do
    firstChar <- letterChar <|> char '_'
    rest <- many $ alphaNumChar <|> char '_'
    return $ T.pack (firstChar : rest) -- Still need T.pack here as we're building from chars

pVar :: Parser Expr
pVar = label "variable" $ lexeme $ do
    var <- pIdentifier
    binders <- get
    case elemIndex var binders of
        Just i -> return $ Var (fromIntegral i) var
        Nothing -> customFailure $ UnboundVariable var binders

defChoice :: NE.NonEmpty Text -> Parser ()
defChoice options = lexeme $ label (T.unpack $ NE.head options) $ void $ choice $ NE.map chunk options

pParamGroup :: Parser [(Text, Expr)]
pParamGroup = lexeme $ label "parameter group" $ between (char '(') (char ')') $ do
    idents <- some pIdentifier
    _ <- defChoice $ ":" :| []
    ty <- pExpr
    modify (flip (foldl $ flip (:)) idents)
    pure $ zip idents (iterate incIndices ty)

pParams :: Parser [(Text, Expr)]
pParams = concat <$> some pParamGroup

pLAbs :: Parser Expr
pLAbs = lexeme $ label "λ-abstraction" $ do
    _ <- defChoice $ "λ" :| ["lambda", "fun"]
    params <- pParams
    _ <- defChoice $ "." :| ["=>", "⇒"]
    body <- pExpr
    modify (drop $ length params)
    pure $ foldr (uncurry Abs) body params

pPAbs :: Parser Expr
pPAbs = lexeme $ label "Π-abstraction" $ do
    _ <- defChoice $ "∏" :| ["Pi", "forall", "∀"]
    params <- pParams
    _ <- defChoice $ "." :| [","]
    body <- pExpr
    modify (drop $ length params)
    pure $ foldr (uncurry Pi) body params

pArrow :: Parser Expr
pArrow = lexeme $ label "->" $ do
    a <- pAppTerm
    _ <- defChoice $ "->" :| ["→"]
    Pi "" a . incIndices <$> pExpr

pApp :: Parser Expr
pApp = foldl1 App <$> some pTerm

pStar :: Parser Expr
pStar = Star <$ defChoice ("*" :| [])

pSquare :: Parser Expr
pSquare = Square <$ defChoice ("□" :| ["[]"])

pTerm :: Parser Expr
pTerm =
    lexeme $
        label "term" $
            choice
                [ between (char '(') (char ')') pExpr
                , pVar
                , pStar
                , pSquare
                ]

pAppTerm :: Parser Expr
pAppTerm = lexeme $ pLAbs <|> pPAbs <|> pApp

pExpr :: Parser Expr
pExpr = lexeme $ try pArrow <|> pAppTerm

pAll :: Text -> Either Text Expr
pAll input = first (T.pack . errorBundlePretty) $ fst $ runIdentity $ runStateT (runParserT pExpr "" input) []