starting type checking again

app/Check.hs

@@ -1,37 +1,54 @@
--- {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
 module Check where
 
-import Control.Monad (guard)
-import Data.List ((!?))
+import Control.Monad.Except
+import Data.List (intercalate, (!?))
 
--- import Debug.Trace (trace)
+import Control.Monad (unless)
 import Expr
+import Debug.Trace
 
 type Context = [Expr]
 
-findType :: Context -> Expr -> Maybe Expr
-findType g (Var k) = do
-    t <- g !? fromInteger k
-    kind <- findType g t
-    guard $ isSort kind
+data TypeCheckError = Err | SquareUntyped | UnboundVariable | NotASort Expr | ExpectedFunctionType Expr | NotEquivalent Expr Expr
+    deriving (Show)
+
+type CheckResult = Either TypeCheckError
+
+matchPi :: Expr -> CheckResult (Expr, Expr)
+matchPi (Pi _ a b) = Right (a, b)
+matchPi e = Left $ ExpectedFunctionType e
+
+showContext :: Context -> String
+showContext g = "[" ++ intercalate ", " (map show g) ++ "]"
+
+findType :: Context -> Expr -> CheckResult Expr
+findType _ Star = Right Square
+findType _ Square = Left SquareUntyped
+findType g (Var n _) = do
+    !_ <- trace ("var:\t" ++ showContext g ++ "\n  n:\t" ++ show n) (Right Star)
+    t <- maybe (Left UnboundVariable) Right $ g !? fromInteger n
+    s <- findType g t
+    unless (isSort s) $ throwError $ NotASort s
     pure t
-findType _ Star = Just Square
-findType _ Square = Nothing
 findType g (App m n) = do
-    Pi a b <- findType g m
+    !_ <- trace ("app:\t" ++ showContext g ++ "\n  m:\t" ++ show m ++ "\n  n: \t" ++ show n) (Right Star)
+    (a, b) <- findType g m >>= matchPi
     a' <- findType g n
-    guard $ betaEquiv a a'
+    unless (betaEquiv a a') $ throwError $ NotEquivalent a a'
     pure $ subst n b
-findType g (Abs t v) = do
-    argType <- findType g t
-    guard $ isSort argType
-    bodyType <- findType (incIndices t : map incIndices g) v
-    resType <- findType g (Pi t bodyType)
-    guard $ isSort resType
-    pure $ Pi t bodyType
-findType g (Pi t v) = do
-    argType <- findType g t
-    guard $ isSort argType
-    bodyType <- findType (incIndices t : map incIndices g) v
-    guard $ isSort bodyType
-    pure bodyType
+findType g (Abs x a m) = do
+    !_ <- trace ("abs:\t" ++ showContext g ++ "\n  a:\t" ++ show a ++ "\n  m:\t" ++ show m) (Right Star)
+    s1 <- findType g a
+    unless (isSort s1) $ throwError $ NotASort s1
+    b <- findType (incIndices a : map incIndices g) m
+    s2 <- findType g (Pi x a b)
+    unless (isSort s2) $ throwError $ NotASort s2
+    pure $ if occursFree 0 b then Pi x a b else Pi "" a b
+findType g (Pi _ a b) = do
+    !_ <- trace ("pi:\t" ++ showContext g ++ "\n  a:\t" ++ show a ++ "\n  b:\t" ++ show b) (Right Star)
+    s1 <- findType g a
+    unless (isSort s1) $ throwError $ NotASort s1
+    s2 <- findType (incIndices a : map incIndices g) b
+    unless (isSort s2) $ throwError $ NotASort s2
+    pure s2

app/Main.hs

@@ -1,11 +1,10 @@
 module Main where
 
+import Check
 import Expr
 import Parser
 import System.IO
 
--- import Check
-
 main :: IO ()
 main = do
     _ <- putStr "> "
@@ -13,8 +12,8 @@ main = do
     input <- getLine
     case pAll input of
         Left err -> putStrLn err
-        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 ++ "!"
+        -- Right expr -> putStrLn (pretty expr)
+        Right expr -> case findType [] expr of
+            Right ty -> putStrLn $ pretty expr ++ " : " ++ pretty ty
+            Left err -> print err
     main

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.