diff --git a/app/Check.hs b/app/Check.hs index 98547f8..d288cab 100644 --- a/app/Check.hs +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index 1cabb2c..bb1e142 100644 --- a/app/Main.hs +++ b/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 diff --git a/lambda-D.cabal b/lambda-D.cabal index 0626c19..1e70061 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.