added state to parser

app/Main.hs

@@ -1,4 +1,13 @@
 module Main where
 
+import Parser
+import System.IO
+
 main :: IO ()
-main = putStrLn "Hello, Haskell!"
+main = do
+  _ <- putStr "> "
+  _ <- hFlush stdout
+  input <- getLine
+  case pAll input of
+    Left err -> putStrLn err
+    Right expr -> print expr

app/Parser.hs

@@ -1,28 +1,26 @@
 module Parser where
 
-import Control.Monad (void)
+import Control.Monad
-import Data.Bifunctor (first)
+import Control.Monad.State.Strict
-import Data.Void (Void)
+import Data.Functor.Identity
+import Data.List (elemIndex)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NE
 import Expr (Expr (..))
-import Text.Megaparsec
+import Text.Megaparsec hiding (State)
-  ( MonadParsec (eof, label),
-    Parsec,
-    between,
-    choice,
-    errorBundlePretty,
-    parse,
-    (<|>),
-  )
-import Control.Applicative.Combinators.NonEmpty (some)
 import Text.Megaparsec.Char
-  ( char,
-    space1,
-    string,
-  )
 import qualified Text.Megaparsec.Char.Lexer as L
-import Data.Either (fromRight)
+import Data.Bifunctor (first)
 
-type Parser = Parsec Void String
+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 =
@@ -34,40 +32,52 @@ skipSpace =
 lexeme :: Parser a -> Parser a
 lexeme = L.lexeme skipSpace
 
-pVar :: Parser Integer
+pIdentifier :: Parser String
-pVar = label "variable" $ lexeme L.decimal
+pIdentifier = label "identifier" $ lexeme $ do
+  firstChar <- letterChar <|> char '_'
+  rest <- many $ alphaNumChar <|> char '_'
+  return $ firstChar : rest
 
--- pVar :: Parser String
+pVar :: Parser Expr
--- pVar = label "variable" $ lexeme $ do
+pVar = label "variable" $ lexeme $ do
---     firstChar <- letterChar <|> char '_'
+  var <- pIdentifier
---     rest <- many $ alphaNumChar <|> char '_'
+  binders <- get
---     return $ firstChar : rest
+  case elemIndex var binders of
+    Just i -> return $ Var $ fromIntegral i
+    Nothing -> customFailure $ UnboundVariable var binders
 
-pLambda :: Parser ()
+defChoice :: NE.NonEmpty String -> Parser ()
-pLambda = lexeme $ label "λ" $ void $ string "lambda" <|> string "λ"
+defChoice options = lexeme $ label labelText $ void $ choice $ NE.map string options
-
+  where labelText = NE.head options
-pPi :: Parser ()
-pPi = lexeme $ label "Π" $ void $ string "Pi" <|> string "Π"
 
 pLAbs :: Parser Expr
 pLAbs = lexeme $ label "λ-abstraction" $ do
-  Abs <$> between pLambda pDot pExpr <*> pExpr
+  _ <- defChoice $ "λ" :| ["lambda"]
+  ident <- pIdentifier
+  _ <- defChoice $ ":" :| []
+  ty <- pExpr
+  _ <- defChoice $ "." :| []
+  modify (ident :)
+  Abs ty <$> pExpr
 
 pPAbs :: Parser Expr
 pPAbs = lexeme $ label "Π-abstraction" $ do
-  Pi <$> between pPi pDot pExpr <*> pExpr
+  _ <- defChoice $ "∏" :| ["Pi"]
+  ident <- pIdentifier
+  _ <- defChoice $ ":" :| []
+  ty <- pExpr
+  _ <- defChoice $ "." :| []
+  modify (ident :)
+  Pi ty <$> pExpr
 
 pApp :: Parser Expr
 pApp = foldl1 App <$> some pTerm
 
-pDot :: Parser ()
-pDot = lexeme $ label "." $ void $ char '.'
-
 pStar :: Parser Expr
-pStar = lexeme $ label "∗" $ Star <$ (string "*" <|> string "∗")
+pStar = Star <$ defChoice ("*" :| [])
 
 pSquare :: Parser Expr
-pSquare = lexeme $ label "□" $ Square <$ (string "□" <|> string "[]")
+pSquare = Square <$ defChoice ("□" :| ["[]"])
 
 pTerm :: Parser Expr
 pTerm =
@@ -75,16 +85,13 @@ pTerm =
     label "term" $
       choice
         [ between (char '(') (char ')') pExpr,
-          Var <$> pVar,
+          pVar,
           pStar,
           pSquare
         ]
 
 pExpr :: Parser Expr
-pExpr = lexeme $ pLAbs <|> pApp <|> pPAbs
+pExpr = lexeme $ pLAbs <|> pPAbs <|> pApp
 
 pAll :: String -> Either String Expr
-pAll = first errorBundlePretty . parse (between skipSpace eof pExpr) ""
+pAll input = first errorBundlePretty $ fst $ runIdentity $ runStateT (runParserT pExpr "" input) []
-
-p :: String -> Expr
-p = fromRight Star . pAll

lambda-D.cabal

@@ -74,6 +74,7 @@ executable lambda-D
                     , megaparsec
                     , text
                     , parser-combinators
+                    , mtl
 
     -- Directories containing source files.
     hs-source-dirs:   app