perga/lib/Parser.hs

module Parser 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 Expr (Expr (..), incIndices, (.->))
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

type InnerState = [String]

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

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

type Parser = ParsecT CustomErrors String (State InnerState)

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

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

pIdentifier :: Parser String
pIdentifier = label "identifier" $ lexeme $ do
    firstChar <- letterChar <|> char '_'
    rest <- many $ alphaNumChar <|> char '_'
    return $ firstChar : rest

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 String -> Parser ()
defChoice options = lexeme $ label labelText $ void $ choice $ NE.map string options
  where
    labelText = NE.head options

pParamGroup :: Parser [(String, 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 [(String, 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 $ "->" :| ["→"]
    b <- pExpr
    pure $ a .-> b

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 :: String -> Either String Expr
pAll input = first errorBundlePretty $ fst $ runIdentity $ runStateT (runParserT pExpr "" input) []