diff --git a/app/Expr.hs b/app/Expr.hs index 4723aa2..035b294 100644 --- a/app/Expr.hs +++ b/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 - Pi :: Expr -> Expr -> Expr + Abs :: String -> 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 (Pi 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 {- --------------------- 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 - where - helper :: Integer -> Expr -> String - helper k (Var n) = genName $ k - n - 1 - helper _ Star = "*" - helper _ Square = "□" - helper k (App e1 e2) = "(" ++ helper k e1 ++ " " ++ helper k e2 ++ ")" - helper k (Abs ty b) = - "(λ" ++ genName k ++ " : " ++ helper k ty ++ " . " ++ helper (k + 1) b ++ ")" - helper k (Pi ty b) = - if occursFree 0 b - then - "(∏" ++ genName k ++ " : " ++ helper k ty ++ " . " ++ helper (k + 1) b ++ ")" - else "(" ++ helper k ty ++ " -> " ++ helper (k + 1) b ++ ")" +pretty (Var _ s) = s +pretty Star = "*" +pretty Square = "□" +pretty (App e1 e2) = "(" ++ pretty e1 ++ " " ++ pretty e2 ++ ")" +pretty (Abs x ty b) = "(λ" ++ x ++ " : " ++ pretty ty ++ " . " ++ pretty b ++ ")" +pretty (Pi x ty b) = + if occursFree 0 b then + "(∏" ++ x ++ " : " ++ pretty ty ++ " . " ++ pretty b ++ ")" + else + "(" ++ pretty ty ++ " -> " ++ pretty 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)) - -decIndices :: Expr -> Expr -decIndices = mapIndices (Var . subtract 1) +incIndices (Var n x) = Var (n + 1) x +incIndices Star = Star +incIndices Square = Square +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 _ (Var n) = Var $ n - 1 +subst s (Var 0 _) = s +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 (Pi m n) = Pi (subst s m) (subst s n) +subst s (Abs x m n) = Abs x (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 (Pi m n) = Pi (substnd s m) (substnd s n) +substnd s (Abs x m n) = Abs x (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 (Pi t v) = Pi (betaReduce t) (betaReduce v) +betaReduce (Abs x t v) = Abs x (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' diff --git a/app/Main.hs b/app/Main.hs index 0e8822e..06381d4 100644 --- a/app/Main.hs +++ b/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 - Just ty -> putStrLn $ pretty expr ++ " : " ++ pretty ty - Nothing -> putStrLn $ "Unable to find type for " ++ pretty expr ++ "!" + Right expr -> putStrLn $ pretty expr + -- Right expr -> case findType [] expr of + -- Just ty -> putStrLn $ pretty expr ++ " : " ++ pretty ty + -- Nothing -> putStrLn $ "Unable to find type for " ++ pretty expr ++ "!" main diff --git a/app/Parser.hs b/app/Parser.hs index 1edc893..d6c75ea 100644 --- a/app/Parser.hs +++ b/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 diff --git a/lambda-D.cabal b/lambda-D.cabal index 1e70061..0626c19 100644 --- a/lambda-D.cabal +++ b/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.