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