record identifier names for better printing

app/Expr.hs

@@ -3,48 +3,38 @@
 module Expr where
 
 import Data.Function (on)
-import Data.List (genericDrop)
 
 data Expr where
-    Var :: Integer -> Expr
+    Var :: Integer -> String -> Expr
     Star :: Expr
     Square :: Expr
     App :: Expr -> Expr -> Expr
-    Abs :: Expr -> Expr -> Expr
+    Abs :: String -> Expr -> Expr -> Expr
-    Pi :: Expr -> Expr -> Expr
+    Pi :: String -> Expr -> Expr -> Expr
     deriving (Show, Eq)
 
 occursFree :: Integer -> Expr -> Bool
-occursFree n (Var k) = n == k
+occursFree n (Var k _) = n == k
 occursFree _ Star = False
 occursFree _ Square = False
 occursFree n (App a b) = on (||) (occursFree n) a b
-occursFree n (Abs a b) = occursFree n a || occursFree (n + 1) b
+occursFree n (Abs _ a b) = occursFree n a || occursFree (n + 1) b
-occursFree n (Pi a b) = occursFree n a || occursFree (n + 1) b
+occursFree n (Pi _ a b) = occursFree n a || occursFree (n + 1) b
 
 {- --------------------- PRETTY PRINTING ----------------------------- -}
 
 -- TODO : store parsed identifiers for better printing
-genName :: Integer -> String
-genName k = case genericDrop k ["x", "y", "z", "w", "u", "v"] of
-    [] -> 'x' : show (k - 6)
-    (v : _) -> v
-
 pretty :: Expr -> String
-pretty = helper 0
+pretty (Var _ s) = s
-  where
+pretty Star = "*"
-    helper :: Integer -> Expr -> String
+pretty Square = "□"
-    helper k (Var n) = genName $ k - n - 1
+pretty (App e1 e2) = "(" ++ pretty e1 ++ " " ++ pretty e2 ++ ")"
-    helper _ Star = "*"
+pretty (Abs x ty b) = "(λ" ++ x ++ " : " ++ pretty ty ++ " . " ++ pretty b ++ ")"
-    helper _ Square = "□"
+pretty (Pi x ty b) = 
-    helper k (App e1 e2) = "(" ++ helper k e1 ++ " " ++ helper k e2 ++ ")"
+    if occursFree 0 b then
-    helper k (Abs ty b) =
+        "(∏" ++ x ++ " : " ++ pretty ty ++ " . " ++ pretty b ++ ")"
-        "(λ" ++ genName k ++ " : " ++ helper k ty ++ " . " ++ helper (k + 1) b ++ ")"
+    else
-    helper k (Pi ty b) =
+        "(" ++ pretty ty ++ " -> " ++ pretty b ++ ")"
-        if occursFree 0 b
-            then
-                "(∏" ++ genName k ++ " : " ++ helper k ty ++ " . " ++ helper (k + 1) b ++ ")"
-            else "(" ++ helper k ty ++ " -> " ++ helper (k + 1) b ++ ")"
 
 {- --------------- ACTUAL MATH STUFF ---------------- -}
 
@@ -53,46 +43,41 @@ isSort Star = True
 isSort Square = True
 isSort _ = False
 
-mapIndices :: (Integer -> Expr) -> Expr -> Expr
-mapIndices f (Var n) = f n
-mapIndices _ Star = Star
-mapIndices _ Square = Square
-mapIndices f (App m n) = App (mapIndices f m) (mapIndices f n)
-mapIndices f (Abs m n) = Abs (mapIndices f m) (mapIndices f n)
-mapIndices f (Pi m n) = Pi (mapIndices f m) (mapIndices f n)
-
 incIndices :: Expr -> Expr
-incIndices = mapIndices (Var . (+ 1))
+incIndices (Var n x) = Var (n + 1) x
-
+incIndices Star = Star
-decIndices :: Expr -> Expr
+incIndices Square = Square
-decIndices = mapIndices (Var . subtract 1)
+incIndices (App m n) = App (incIndices m) (incIndices n)
+incIndices (Abs x m n) = Abs x (incIndices m) (incIndices n)
+incIndices (Pi x m n) = Pi x (incIndices m) (incIndices n)
 
 -- substitute s for 0 *AND* decrement indices; only use after reducing a redex.
 subst :: Expr -> Expr -> Expr
-subst s (Var 0) = s
+subst s (Var 0 _) = s
-subst _ (Var n) = Var $ n - 1
+subst _ (Var n s) = Var (n - 1) s
 subst _ Star = Star
 subst _ Square = Square
 subst s (App m n) = App (subst s m) (subst s n)
-subst s (Abs m n) = Abs (subst s m) (subst s n)
+subst s (Abs x m n) = Abs x (subst s m) (subst s n)
-subst s (Pi m n) = Pi (subst s m) (subst s n)
+subst s (Pi x m n) = Pi x (subst s m) (subst s n)
 
 substnd :: Expr -> Expr -> Expr
-substnd s (Var n) = if n == 0 then s else Var n
+substnd s (Var 0 _) = s
+substnd _ (Var n s) = Var (n - 1) s
 substnd _ Star = Star
 substnd _ Square = Square
 substnd s (App m n) = App (substnd s m) (substnd s n)
-substnd s (Abs m n) = Abs (substnd s m) (substnd s n)
+substnd s (Abs x m n) = Abs x (substnd s m) (substnd s n)
-substnd s (Pi m n) = Pi (substnd s m) (substnd s n)
+substnd s (Pi x m n) = Pi x (substnd s m) (substnd s n)
 
 betaReduce :: Expr -> Expr
-betaReduce (Var k) = Var k
+betaReduce (Var k s) = Var k s
 betaReduce Star = Star
 betaReduce Square = Square
-betaReduce (App (Abs _ v) n) = subst n v
+betaReduce (App (Abs _ _ v) n) = subst n v
 betaReduce (App m n) = App (betaReduce m) (betaReduce n)
-betaReduce (Abs t v) = Abs (betaReduce t) (betaReduce v)
+betaReduce (Abs x t v) = Abs x (betaReduce t) (betaReduce v)
-betaReduce (Pi t v) = Pi (betaReduce t) (betaReduce v)
+betaReduce (Pi x t v) = Pi x (betaReduce t) (betaReduce v)
 
 betaNF :: Expr -> Expr
 betaNF e = if e == e' then e else betaNF e'

app/Main.hs

@@ -3,7 +3,7 @@ module Main where
 import Expr
 import Parser
 import System.IO
-import Check
+-- import Check
 
 main :: IO ()
 main = do
@@ -12,7 +12,8 @@ main = do
     input <- getLine
     case pAll input of
         Left err -> putStrLn err
-        Right expr -> case findType [] expr of
+        Right expr -> putStrLn $ pretty expr
-            Just ty -> putStrLn $ pretty expr ++ " : " ++ pretty ty
+        -- Right expr -> case findType [] expr of
-            Nothing -> putStrLn $ "Unable to find type for " ++ pretty expr ++ "!"
+        --     Just ty -> putStrLn $ pretty expr ++ " : " ++ pretty ty
+        --     Nothing -> putStrLn $ "Unable to find type for " ++ pretty expr ++ "!"
     main

app/Parser.hs

@@ -43,7 +43,7 @@ pVar = label "variable" $ lexeme $ do
   var <- pIdentifier
   binders <- get
   case elemIndex var binders of
-    Just i -> return $ Var $ fromIntegral i
+    Just i -> return $ Var (fromIntegral i) var
     Nothing -> customFailure $ UnboundVariable var binders
 
 defChoice :: NE.NonEmpty String -> Parser ()
@@ -60,7 +60,7 @@ pLAbs = lexeme $ label "λ-abstraction" $ do
   modify (ident :)
   body <- pExpr
   modify $ drop 1
-  pure $ Abs ty body
+  pure $ Abs ident ty body
 
 pPAbs :: Parser Expr
 pPAbs = lexeme $ label "Π-abstraction" $ do
@@ -72,7 +72,7 @@ pPAbs = lexeme $ label "Π-abstraction" $ do
   modify (ident :)
   body <- pExpr
   modify $ drop 1
-  pure $ Pi ty body
+  pure $ Pi ident ty body
 
 pApp :: Parser Expr
 pApp = foldl1 App <$> some pTerm

lambda-D.cabal

@@ -63,7 +63,7 @@ executable lambda-D
 
     -- Modules included in this executable, other than Main.
     other-modules:    Expr
-                      Check
+                      -- Check
                       Parser
 
     -- LANGUAGE extensions used by modules in this package.