Wired in definitions for the interval algebra

3 years ago · a1a8a96fa9
--- a/cubical.cabal
+++ b/cubical.cabal
@ -25,8 +25,11 @@ executable cubical
 , containers ^>= 0.6
 , bytestring ^>= 0.10

 , prettyprinter ^>= 1.7
 , prettyprinter  ^>= 1.7
 , prettyprinter-ansi-terminal ^>= 1.1
 
 , haskeline ^>= 0.8
 , optparse-applicative ^>= 0.15

 other-modules: Presyntax.Lexer
 , Presyntax.Parser
@ -39,6 +42,7 @@ executable cubical
 , Elab
 , Elab.Eval
 , Elab.Monad
 , Elab.WiredIn

 build-tool-depends: alex:alex >= 3.2.4 && < 4.0
 , happy:happy >= 1.19.12 && < 2.0
--- a/src/Elab.hs
+++ b/src/Elab.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE TupleSections, OverloadedStrings #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Elab where

 import Control.Monad.Reader
@ -8,29 +9,22 @@ import Control.Exception
 import qualified Data.Map.Strict as Map
 import Data.Typeable

 import Elab.WiredIn
 import Elab.Monad
 import Elab.Eval

 import qualified Presyntax.Presyntax as P

 import Syntax
 import Prettyprinter

 infer :: P.Expr -> ElabM (Term, NFType)
 infer (P.Span ex a b) = do
 env <- ask
 liftIO $
 runElab (infer ex) env
 `catches` [ Handler $ \e@WhileChecking{} -> throwIO e
 , Handler $ \e -> throwIO (WhileChecking a b e)
 ]
 infer (P.Span ex a b) = withSpan a b $ infer ex

 infer (P.Var t) = do
 name <- getNameFor t
 case name of
 Builtin _ wi -> elabWiredIn wi name
 _ -> do
 nft <- getNfType name
 pure (Ref name, nft)
 nft <- getNfType name
 pure (Ref name, nft)

 infer (P.App p f x) = do
 (f, f_ty) <- infer f
@ -39,20 +33,6 @@ infer (P.App p f x) = do
 x_nf <- eval x
 pure (App p (w f) x, r x_nf)

 infer (P.Pi p s d r) = do
 d <- check d VType
 d_nf <- eval d
 assume (Bound s) d_nf $ do
 r <- check r VType
 pure (Pi p s d r, VType)

 infer (P.Sigma s d r) = do
 d <- check d VType
 d_nf <- eval d
 assume (Bound s) d_nf $ do
 r <- check r VType
 pure (Sigma s d r, VType)

 infer (P.Proj1 x) = do
 (tm, ty) <- infer x
 (d, _, wp) <- isSigmaType ty
@ -70,13 +50,7 @@ infer exp = do
 pure (tm, t)

 check :: P.Expr -> NFType -> ElabM Term
 check (P.Span ex a b) ty = do
 env <- ask
 liftIO $
 runElab (check ex ty) env
 `catches` [ Handler $ \e@WhileChecking{} -> throwIO e
 , Handler $ \e -> throwIO (WhileChecking a b e)
 ]
 check (P.Span ex a b) ty = withSpan a b $ check ex ty

 check (P.Lam p var body) (VPi p' dom (Closure _ rng)) | p == p' =
 assume (Bound var) dom $
@ -98,13 +72,32 @@ check (P.Pair a b) ty = do
 b <- check b (r a_nf)
 pure (wp (Pair a b))

 check (P.Pi p s d r) ty = do
 isSort ty
 d <- check d ty
 d_nf <- eval d
 assume (Bound s) d_nf $ do
 r <- check r ty
 pure (Pi p s d r)

 check (P.Sigma s d r) ty = do
 isSort ty
 d <- check d ty
 d_nf <- eval d
 assume (Bound s) d_nf $ do
 r <- check r ty
 pure (Sigma s d r)

 check exp ty = do
 (tm, has) <- switch $ infer exp
 unify has ty
 pure tm
 wp <- isConvertibleTo has ty
 pure (wp tm)

 elabWiredIn :: WiredIn -> Name -> ElabM (Term, NFType)
 elabWiredIn WiType _ = pure (Type, VType)
 isSort :: NFType -> ElabM ()
 isSort VType = pure ()
 isSort VTypeω = pure ()
 isSort vt@(VNe HMeta{} _) = unify vt VType
 isSort vt = liftIO . throwIO $ NotEqual vt VType

 isPiType :: P.Plicity -> NFType -> ElabM (Value, NFType -> NFType, Term -> Term)
 isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (d, k, id)
@ -130,10 +123,12 @@ identityTy :: NFType
 identityTy = VPi P.Im VType (Closure "A" $ \t -> VPi P.Ex t (Closure "_" (const t)))

 checkStatement :: P.Statement -> ElabM a -> ElabM a
 checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k

 checkStatement (P.Decl name ty) k = do
 ty <- check ty VType
 ty <- check ty VTypeω
 ty_nf <- eval ty
 assume (Defined name) ty_nf k
 assumes (Defined <$> name) ty_nf k

 checkStatement (P.Defn name rhs) k = do
 ty <- asks (Map.lookup (Defined name) . getEnv)
@ -150,12 +145,42 @@ checkStatement (P.Defn name rhs) k = do
 rhs_nf <- eval rhs
 define (Defined name) ty_nf rhs_nf k

 checkProgram :: [P.Statement] -> ElabM ElabEnv
 checkProgram [] = ask
 checkProgram (st:sts) = checkStatement st $ checkProgram sts
 checkStatement (P.Builtin winame var) k = do
 wi <-
 case Map.lookup winame wiredInNames of
 Just wi -> pure wi
 _ -> liftIO . throwIO $ NoSuchPrimitive winame

 newtype Redefinition = Redefinition { getRedefName :: Name }
 deriving (Show, Typeable, Exception)
 let
 check = do
 nm <- getNameFor var
 ty <- getNfType nm
 unify ty (wiType wi)
 `withNote` hsep [ "Previous definition of", pretty nm, "here" ]
 `seeAlso` nm

 data WhileChecking = WhileChecking { startPos :: P.Posn, endPos :: P.Posn, exc :: SomeException }
 env <- ask
 liftIO $
 runElab check env `catch` \(_ :: NotInScope) -> pure ()

 define (Defined var) (wiType wi) (wiValue wi) k

 checkStatement (P.ReplNf e) k = do
 (e, _) <- infer e
 e_nf <- eval e
 h <- asks commHook
 liftIO (h e_nf)
 k

 checkStatement (P.ReplTy e) k = do
 (_, ty) <- infer e
 h <- asks commHook
 liftIO (h ty)
 k

 checkProgram :: [P.Statement] -> ElabM a -> ElabM a
 checkProgram [] k = k
 checkProgram (st:sts) k = checkStatement st $ checkProgram sts k

 newtype Redefinition = Redefinition { getRedefName :: Name }
 deriving (Show, Typeable, Exception)
--- a/src/Elab/Eval.hs
+++ b/src/Elab/Eval.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Elab.Eval where

 import Control.Monad.Reader
@ -15,6 +16,7 @@ import Data.Foldable
 import Data.IORef
 import Data.Maybe

 import {-# SOURCE #-} Elab.WiredIn
 import Elab.Monad

 import Presyntax.Presyntax (Plicity(..))
@ -22,6 +24,7 @@ import Presyntax.Presyntax (Plicity(..))
 import Syntax

 import System.IO.Unsafe
 import Syntax.Pretty

 eval :: Term -> ElabM Value
 eval t = asks (flip evalWithEnv t)
@ -61,7 +64,18 @@ zonkIO (VLam p (Closure s k)) = pure $ VLam p (Closure s (zonk . k))
 zonkIO (VPi p d (Closure s k)) = VPi p <$> zonkIO d <*> pure (Closure s (zonk . k))
 zonkIO (VSigma d (Closure s k)) = VSigma <$> zonkIO d <*> pure (Closure s (zonk . k))
 zonkIO (VPair a b) = VPair <$> zonkIO a <*> zonkIO b

 -- Sorts
 zonkIO VType = pure VType
 zonkIO VTypeω = pure VTypeω

 zonkIO VI = pure VI
 zonkIO VI0 = pure VI0
 zonkIO VI1 = pure VI1

 zonkIO (VIAnd x y) = iand <$> zonkIO x <*> zonkIO y
 zonkIO (VIOr x y) = ior <$> zonkIO x <*> zonkIO y
 zonkIO (VINot x) = inot <$> zonkIO x

 zonk :: Value -> Value
 zonk = unsafePerformIO . zonkIO
@ -93,6 +107,14 @@ evalWithEnv e (Proj1 a) = vProj1 (evalWithEnv e a)
 evalWithEnv e (Proj2 a) = vProj2 (evalWithEnv e a)

 evalWithEnv _ Type = VType
 evalWithEnv _ Typeω = VTypeω
 evalWithEnv _ I = VI
 evalWithEnv _ I0 = VI0
 evalWithEnv _ I1 = VI1

 evalWithEnv e (IAnd x y) = iand (evalWithEnv e x) (evalWithEnv e y)
 evalWithEnv e (IOr x y) = ior (evalWithEnv e x) (evalWithEnv e y)
 evalWithEnv e (INot x) = inot (evalWithEnv e x)

 vApp :: Plicity -> Value -> Value -> Value
 vApp p (VLam p' k) arg = assert (p == p') $ clCont k arg
@ -112,58 +134,67 @@ vProj2 x = error $ "can't proj2 " ++ show x
 data NotEqual = NotEqual Value Value
 deriving (Show, Typeable, Exception)

 unify :: Value -> Value -> ElabM ()
 unify topa topb = join $ go <$> forceIO topa <*> forceIO topb where
 unify' :: Value -> Value -> ElabM ()
 unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
 go (VNe (HMeta mv) sp) rhs = solveMeta mv sp rhs
 go rhs (VNe (HMeta mv) sp) = solveMeta mv sp rhs

 go (VNe x a) (VNe x' a')
 | x == x', length a == length a' =
 traverse_ (uncurry unifySpine) (zip a a')
 traverse_ (uncurry unify'Spine) (zip a a')
 | otherwise = fail

 go (VLam p (Closure _ k)) vl = do
 t <- VVar . Bound <$> newName
 unify (k t) (vApp p vl t)
 unify' (k t) (vApp p vl t)

 go vl (VLam p (Closure _ k)) = do
 t <- VVar . Bound <$> newName
 unify (vApp p vl t) (k t)
 unify' (vApp p vl t) (k t)

 go (VPair a b) vl = unify a (vProj1 vl) *> unify b (vProj2 vl)
 go vl (VPair a b) = unify (vProj1 vl) a *> unify (vProj2 vl) b
 go (VPair a b) vl = unify' a (vProj1 vl) *> unify' b (vProj2 vl)
 go vl (VPair a b) = unify' (vProj1 vl) a *> unify' (vProj2 vl) b

 go (VPi p d (Closure _ k)) (VPi p' d' (Closure _ k')) | p == p' = do
 t <- VVar . Bound <$> newName
 unify d d'
 unify (k t) (k' t)
 unify' d d'
 unify' (k t) (k' t)

 go (VSigma d (Closure _ k)) (VSigma d' (Closure _ k')) = do
 t <- VVar . Bound <$> newName
 unify d d'
 unify (k t) (k' t)
 unify' d d'
 unify' (k t) (k' t)

 go VType VType = pure ()
 go VType VType = pure ()
 go VTypeω VTypeω = pure ()

 go VI VI = pure ()
 go VI0 VI0 = pure ()
 go VI1 VI1 = pure ()

 go _ _ = fail

 fail = liftIO . throwIO $ NotEqual topa topb

 unifySpine (PApp a v) (PApp a' v')
 | a == a' = unify v v'
 unify'Spine (PApp a v) (PApp a' v')
 | a == a' = unify' v v'

 unify'Spine PProj1 PProj1 = pure ()
 unify'Spine PProj2 PProj2 = pure ()

 unifySpine PProj1 PProj1 = pure ()
 unifySpine PProj2 PProj2 = pure ()
 unify'Spine _ _ = fail

 unifySpine _ _ = fail
 unify :: Value -> Value -> ElabM ()
 unify a b = unify' a b `catchElab` \(_ :: SomeException) -> liftIO $ throwIO (NotEqual a b)

 isConvertibleTo :: Value -> Value -> ElabM (Term -> Term)
 VPi Im d (Closure _v k) `isConvertibleTo` ty = do
 meta <- newMeta d
 cont <- k meta `isConvertibleTo` ty
 pure (\f -> cont (App Ex f (quote meta)))
 VType `isConvertibleTo` VTypeω = pure id
 isConvertibleTo a b = do
 unify a b
 unify' a b
 pure id

 newMeta :: Value -> ElabM Value
@ -193,7 +224,7 @@ _nameCounter = unsafePerformIO $ newIORef 0
 solveMeta :: MV -> [Projection] -> Value -> ElabM ()
 solveMeta m@(MV _ cell) sp rhs = do
 env <- ask
 liftIO $ print (m, sp, rhs)
 liftIO $ putStrLn (showValue (VNe (HMeta m) sp) ++ " ≡? " ++ showValue rhs)
 names <- checkSpine Set.empty sp
 checkScope (Set.fromList (Bound <$> names)) rhs
 let tm = quote rhs
@ -231,6 +262,15 @@ checkScope scope (VSigma d (Closure n k)) = do
 checkScope s (VPair a b) = traverse_ (checkScope s) [a, b]

 checkScope _ VType = pure ()
 checkScope _ VTypeω = pure ()

 checkScope _ VI = pure ()
 checkScope _ VI0 = pure ()
 checkScope _ VI1 = pure ()

 checkScope s (VIAnd x y) = traverse_ (checkScope s) [x, y]
 checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y]
 checkScope s (VINot x) = checkScope s x

 checkSpine :: Set Name -> [Projection] -> ElabM [T.Text]
 checkSpine scope (PApp Ex (VVar n@(Bound t)):xs)
--- a/src/Elab/Monad.hs
+++ b/src/Elab/Monad.hs
@ -7,35 +7,52 @@ module Elab.Monad where
 import Control.Monad.Reader
 import Control.Exception

 import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)
 import qualified Data.Map.Strict as Map
 import Data.Text.Prettyprint.Doc
 import Data.Map.Strict (Map)
 import Data.Text (Text)
 import Data.Typeable

 import Syntax
 import qualified Data.Text as T
 import qualified Presyntax.Presyntax as P

 data ElabEnv = ElabEnv { getEnv :: Map Name (NFType, Value), nameMap :: Map Text Name, pingPong :: Int }
 data ElabEnv =
 ElabEnv { getEnv :: Map Name (NFType, Value)

 , nameMap :: Map Text Name
 , pingPong :: Int
 , commHook :: Value -> IO ()

 , currentSpan :: Maybe (P.Posn, P.Posn)
 , whereBound :: Map Name (P.Posn, P.Posn)
 }

 newtype ElabM a = ElabM { runElab :: ElabEnv -> IO a }
 deriving (Functor, Applicative, Monad, MonadReader ElabEnv, MonadIO)
 via ReaderT ElabEnv IO

 newtype NotInScope = NotInScope { nameNotInScope :: Name }
 deriving (Show, Typeable)
 deriving anyclass (Exception)

 emptyEnv :: ElabEnv
 emptyEnv = ElabEnv mempty (Map.singleton (T.pack "Type") (Builtin (T.pack "Type") WiType)) 0
 emptyEnv = ElabEnv mempty mempty 0 (const (pure ())) Nothing mempty

 assume :: Name -> Value -> ElabM a -> ElabM a
 assume nm ty = local go where
 go x = x { getEnv = Map.insert nm (ty, VVar nm) (getEnv x), nameMap = Map.insert (getNameText nm) nm (nameMap x) }
 go x = x { getEnv = Map.insert nm (ty, VVar nm) (getEnv x)
 , nameMap = Map.insert (getNameText nm) nm (nameMap x)
 , whereBound = maybe (whereBound x) (flip (Map.insert nm) (whereBound x)) (currentSpan x)
 }

 assumes :: [Name] -> Value -> ElabM a -> ElabM a
 assumes nm ty = local go where
 go x = x { getEnv = Map.union (Map.fromList (map (\v -> (v, (ty, VVar v))) nm)) (getEnv x)
 , nameMap = Map.union (Map.fromList (map ((,) <$> getNameText <*> id) nm)) (nameMap x)
 , whereBound = maybe (whereBound x) (\l -> Map.union (Map.fromList (zip nm (repeat l))) (whereBound x)) (currentSpan x)
 }


 getNameText :: Name -> Text
 getNameText (Bound x) = x
 getNameText (Defined x) = x
 getNameText (Builtin x _) = x

 define :: Name -> Value -> Value -> ElabM a -> ElabM a
 define nm ty vl = local go where
@ -68,4 +85,48 @@ switch k =
 depth <- asks pingPong
 when (depth >= 128) $ liftIO $ throwIO StackOverflow
 local go k
 where go e = e { pingPong = pingPong e + 1 }
 where go e = e { pingPong = pingPong e + 1 }

 newtype NotInScope = NotInScope { nameNotInScope :: Name }
 deriving (Show, Typeable)
 deriving anyclass (Exception)

 data AttachedNote = AttachedNote { getNote :: Doc AnsiStyle, getExc :: SomeException }
 deriving (Show, Typeable)
 deriving anyclass (Exception)

 withNote :: ElabM a -> Doc AnsiStyle -> ElabM a
 withNote k note = do
 env <- ask
 liftIO $
 runElab k env
 `catch` \e -> throwIO (AttachedNote note e)

 data WhileChecking = WhileChecking { startPos :: P.Posn, endPos :: P.Posn, exc :: SomeException }
 deriving (Show, Typeable, Exception)

 withSpan :: P.Posn -> P.Posn -> ElabM a -> ElabM a
 withSpan a b k = do
 env <- ask
 liftIO $
 runElab k env{ currentSpan = Just (a, b) }
 `catches` [ Handler $ \e@WhileChecking{} -> throwIO e
 , Handler $ \e -> throwIO (WhileChecking a b e)
 ]

 data SeeAlso = SeeAlso { saStartPos :: P.Posn, saEndPos :: P.Posn, saExc :: SomeException }
 deriving (Show, Typeable, Exception)

 seeAlso :: ElabM a -> Name -> ElabM a
 seeAlso k nm = do
 env <- ask
 case Map.lookup nm (whereBound env) of
 Just l ->
 liftIO $ runElab k env
 `catch` \e -> throwIO (SeeAlso (fst l) (snd l) e)
 Nothing -> k

 catchElab :: Exception e => ElabM a -> (e -> ElabM a) -> ElabM a
 catchElab k h = do
 env <- ask
 liftIO $ runElab k env `catch` \e -> runElab (h e) env
--- a/src/Elab/WiredIn.hs
+++ b/src/Elab/WiredIn.hs
@ -0,0 +1,93 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DeriveAnyClass #-}
 module Elab.WiredIn where

 import Syntax
 import Data.Map.Strict (Map)
 import Data.Text (Text)
 import qualified Data.Map.Strict as Map
 import Control.Exception
 import Data.Typeable
 import qualified Presyntax.Presyntax as P
 import Elab.Eval

 wiType :: WiredIn -> NFType
 wiType WiType = VType
 wiType WiPretype = VTypeω

 wiType WiInterval = VTypeω
 wiType WiI0 = VI
 wiType WiI1 = VI

 wiType WiIAnd = VI ~> VI ~> VI
 wiType WiIOr = VI ~> VI ~> VI
 wiType WiINot = VI ~> VI

 wiValue :: WiredIn -> Value
 wiValue WiType = VType
 wiValue WiPretype = VTypeω

 wiValue WiInterval = VI
 wiValue WiI0 = VI0
 wiValue WiI1 = VI1

 wiValue WiIAnd = fun \x -> fun \y -> iand x y
 wiValue WiIOr = fun \x -> fun \y -> ior x y
 wiValue WiINot = fun inot

 (~>) :: Value -> Value -> Value
 a ~> b = VPi P.Ex a (Closure "_" (const b))
 infixr 7 ~>

 fun :: (Value -> Value) -> Value
 fun k = VLam P.Ex $ Closure "x" (k . force)

 dprod :: Value -> (Value -> Value) -> Value
 dprod a b = VPi P.Ex a (Closure "x" b)

 wiredInNames :: Map Text WiredIn
 wiredInNames = Map.fromList
 [ ("pretype", WiPretype)
 , ("type", WiType)
 , ("interval", WiInterval)
 , ("i0", WiI0)
 , ("i1", WiI1)
 , ("iand", WiIAnd)
 , ("ior", WiIOr)
 , ("inot", WiINot)
 ]

 newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
 deriving (Show, Typeable)
 deriving anyclass (Exception)

 -- Interval operations

 iand, ior :: Value -> Value -> Value
 iand = \case
 VI1 -> id
 VI0 -> const VI0
 x -> \case
 VI0 -> VI0
 VI1 -> x
 y -> VIAnd x y

 ior = \case
 VI0 -> id
 VI1 -> const VI1
 x -> \case
 VI1 -> VI1
 VI0 -> x
 y -> VIOr x y

 inot :: Value -> Value
 inot = \case
 VI0 -> VI1
 VI1 -> VI0
 VIOr x y -> VIAnd (inot x) (inot y)
 VIAnd x y -> VIOr (inot x) (inot y)
 VINot x -> x
 x -> VINot x
--- a/src/Elab/WiredIn.hs-boot
+++ b/src/Elab/WiredIn.hs-boot
@ -0,0 +1,9 @@
 module Elab.WiredIn where

 import Syntax

 wiType :: WiredIn -> NFType
 wiValue :: WiredIn -> NFType

 iand, ior :: Value -> Value -> Value
 inot :: Value -> Value
--- a/src/Main.hs
+++ b/src/Main.hs
@ -13,24 +13,92 @@ import qualified Data.Text as T
 import Data.Text ( Text )
 import Data.Foldable

 import Elab.Monad
 import Elab.Monad hiding (switch)
 import Elab.Eval
 import Elab

 import Presyntax.Presyntax (Posn(Posn))
 import Presyntax.Parser
 import Presyntax.Tokens
 import Presyntax.Lexer

 import System.Exit
 import Syntax.Pretty
 import Elab.WiredIn
 import Options.Applicative
 import Control.Monad
 import Syntax
 import Prettyprinter
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import System.Console.Haskeline

 main :: IO ()
 main = do
 t <- Bsl.readFile "test.tt"
 let Right tks = runAlex t parseProg
 env <- runElab (checkProgram tks) emptyEnv `catch` \e -> displayAndDie (T.decodeUtf8 (Bsl.toStrict t)) (e :: SomeException)
 for_ (Map.toList (getEnv env)) $ \(n, x) -> putStrLn $ show n ++ " : " ++ showValue (zonk (fst x))
 opts <- execParser parser
 case opts of
 Load files -> do
 env <- checkFiles files
 enterReplIn env
 Check files verbose -> do
 env <- checkFiles files
 when verbose $ dumpEnv (getEnv env)
 Repl -> enterReplIn emptyEnv

 enterReplIn :: ElabEnv -> IO ()
 enterReplIn env = runInputT defaultSettings (loop env') where
 env' = env { commHook = T.putStrLn . render . prettyTm . quote }

 loop :: ElabEnv -> InputT IO ()
 loop env = do
 inp <- fmap T.pack <$> getInputLine "% "
 case inp of
 Nothing -> pure ()
 Just inp ->
 case runAlex (Bsl.fromStrict (T.encodeUtf8 inp)) parseRepl of
 Left e -> do
 liftIO $ print e
 loop env
 Right st -> do
 env <- liftIO $
 runElab (checkStatement st ask) env
 `catch` \e -> do
 displayExceptions' inp (e :: SomeException)
 pure env
 loop env

 checkFiles :: [String] -> IO ElabEnv
 checkFiles files = runElab (go files ask) emptyEnv where
 go [] k = k
 go (x:xs) k = do
 code <- liftIO $ Bsl.readFile x
 case runAlex code parseProg of
 Left e -> liftIO $ print e *> error (show e)
 Right prog -> do
 env <- ask
 liftIO $ runElab (checkProgram prog (go xs k)) env
 `catch` \e -> displayAndDie (T.decodeUtf8 (Bsl.toStrict code)) (e :: SomeException)

 dumpEnv :: Map.Map Name (NFType, Value) -> IO ()
 dumpEnv env = for_ (Map.toList env) $ \(name, (nft, _)) ->
 T.putStrLn $ render (pretty name <+> colon <+> prettyTm (quote (zonk nft)))

 parser :: ParserInfo Opts
 parser = info (subparser (load <> check) <|> pure Repl <**> helper) (header "cubical - a cubical programming language")
 where
 load = command "load" $ info (fmap Load (some (argument str (metavar "file..."))) <**> helper) (progDesc "Check and load a list of files in the REPL")
 check = command "check" $
 info ((Check <$> some (argument str (metavar "file..."))
 <*> switch ( long "verbose"
 <> short 'v'
 <> help "Print the types of all declared/defined values"))
 <**> helper)
 (progDesc "Check a list of files")

 data Opts
 = Load { files :: [String] }
 | Check { files :: [String], verbose :: Bool }
 | Repl
 deriving (Eq, Show, Ord)

 displayAndDie :: Exception e => Text -> e -> IO a
 displayAndDie lines e = do
@ -42,12 +110,22 @@ displayExceptions lines =
 [ Handler \(WhileChecking a b e) -> do
 T.putStrLn $ squiggleUnder a b lines
 displayExceptions' lines e
 , Handler \(SeeAlso a b e) -> do
 displayExceptions' lines e
 T.putStrLn $ squiggleUnder a b lines
 , Handler \(NotEqual ta tb) -> do
 putStrLn . unlines $
 [ "\x1b[1;31merror\x1b[0m: Mismatch between actual and expected types:"
 , " * \x1b[1mActual\x1b[0m: " ++ showValue (zonk ta)
 , " * \x1b[1mExpected\x1b[0m: " ++ showValue (zonk tb)
 ]
 , Handler \(NoSuchPrimitive x) -> do
 putStrLn $ "Unknown primitive: " ++ T.unpack x
 , Handler \(NotInScope x) -> do
 putStrLn $ "Variable not in scope: " ++ show x
 , Handler \(AttachedNote n e) -> do
 displayExceptions' lines e
 T.putStrLn $ "\x1b[1;32mnote\x1b[0m: " <> render n
 ]

 displayExceptions' :: Exception e => Text -> e -> IO ()
--- a/src/Presyntax/Lexer.x
+++ b/src/Presyntax/Lexer.x
@ -16,9 +16,9 @@ $white_nol = $white # \n
 tokens :-
 $white_nol+ ;
 
 -- zero state: normal lexing
 <0> $alpha [$alpha $digit \_ \']* { yield TokVar }
 <0,prtext> $alpha [$alpha $digit \_ \']* { yield TokVar }

 -- zero state: normal lexing
 <0> \= { always TokEqual }
 <0> \: { always TokColon }
 <0> \, { always TokComma }
@ -37,7 +37,14 @@ tokens :-
 <0> \} { always TokCBrace }
 <0> \; { always TokSemi }

 <0> \n { just $ pushStartCode newline }
 <0> \n { just $ pushStartCode newline }

 <0> "{-#" { \i l -> pushStartCode prkw *> always TokOPragma i l }
 <prkw> "PRIMITIVE" { \i l -> popStartCode *> pushStartCode prtext *> always TokPrim i l }
 <prtext> "#-}" { \i l -> popStartCode *> always TokCPragma i l }

 <0> ":let" { always TokReplLet }
 <0> ":t"("y"|"yp"|"ype"|()) { yield TokReplT }

 -- newline: emit a semicolon when de-denting
 <newline> {
@ -45,7 +52,6 @@ tokens :-
 () { offsideRule }
 }


 {
 alexEOF :: Alex Token
 alexEOF = do
@ -53,6 +59,8 @@ alexEOF = do
 pure $ Token TokEof l c

 yield k (AlexPn _ l c, _, s, _) i = pure (Token (k $! (T.decodeUtf8 (Lbs.toStrict (Lbs.take i s)))) l c)

 always :: TokenClass -> AlexInput -> Int64 -> Alex Token
 always k x i = yield (const k) x i

 data AlexUserState = AlexUserState { layoutColumns :: [Int], startCodes :: [Int] }
@ -83,7 +91,7 @@ popStartCode = do
 alexSetStartCode x

 offsideRule :: AlexInput -> Int64 -> Alex Token
 offsideRule i@(AlexPn p line col, _, s, _) l = do
 offsideRule (AlexPn _ line col, _, _, _) _ = do
 ~(col':_) <- layoutColumns <$> getUserState
 case col `compare` col' of
 EQ -> do
--- a/src/Presyntax/Parser.y
+++ b/src/Presyntax/Parser.y
@ -15,6 +15,7 @@ import Prelude hiding (span)
 %name parseExp Exp
 %name parseStmt Statement
 %name parseProg Program
 %name parseRepl ReplStatement

 %tokentype { Token }

@ -25,24 +26,32 @@ import Prelude hiding (span)
 %error { parseError }

 %token
 var { $$@(Token (TokVar _) _ _) }
 '(' { Token TokOParen _ _ }
 ')' { Token TokCParen _ _ }
 var  { Token (TokVar _) _ _ }
 '('  { Token TokOParen _ _ }
 ')'  { Token TokCParen _ _ }

 '{' { Token TokOBrace _ _ }
 '}' { Token TokCBrace _ _ }
 '{'  { Token TokOBrace _ _ }
 '}'  { Token TokCBrace _ _ }

 '\\' { Token TokLambda _ _ }
 '{-#' { Token TokOPragma _ _ }
 '#-}' { Token TokCPragma _ _ }

 '\\' { Token TokLambda _ _ }
 
 '->' { Token TokArrow _ _ }
 ':' { Token TokColon _ _ }
 ';' { Token TokSemi _ _ }
 '=' { Token TokEqual _ _ }
 ',' { Token TokComma _ _ }
 '*' { Token TokStar _ _ }
 '->' { Token TokArrow _ _ }
 ':' { Token TokColon _ _ }
 ';' { Token TokSemi _ _ }
 '=' { Token TokEqual _ _ }
 ',' { Token TokComma _ _ }
 '*' { Token TokStar _ _ }

 '.1' { Token TokPi1 _ _ }
 '.2' { Token TokPi2 _ _ }

 '.1' { Token TokPi1 _ _ }
 '.2' { Token TokPi2 _ _ }
 'PRIMITIVE' { Token TokPrim _ _ }

 ':let' { Token TokReplLet _ _ }
 ':t' { Token (TokReplT _) _ _ }

 %%

@ -52,18 +61,18 @@ Exp
 | Exp '{' Exp '}' { span $1 $4 $ App Im $1 $3 }

 | '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
 | '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex $2 $4 $6 }
 | '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im $2 $4 $6 }
 | '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 }
 | '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im (thd $2) $4 $6 }
 | ExpProj '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }

 | '(' VarList ':' Exp ')' '*' Exp { span $1 $7 $ makeSigmas $2 $4 $7 }
 | '(' VarList ':' Exp ')' '*' Exp { span $1 $7 $ makeSigmas (thd $2) $4 $7 }
 | ExpProj '*' Exp { span $1 $3 $ Sigma (T.singleton '_') $1 $3 }

 | ExpProj { $1 }

 ProdTail :: { Expr }
 : '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex $2 $4 $6 }
 | '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im $2 $4 $6 }
 : '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 }
 | '{' VarList ':' Exp '}' ProdTail { span $1 $6 $ makePis Im (thd $2) $4 $6 }
 | '->' Exp { span $2 $2 $ $2 }

 LambdaList :: { [(Plicity, Text)] }
@ -77,9 +86,9 @@ LhsList :: { [(Plicity, Text)] }
 : { [] }
 | LambdaList { $1 }

 VarList :: { [Text] }
 : var { [getVar $1] }
 | var VarList { getVar $1:$2 }
 VarList :: { (Posn, Posn, [Text]) }
 : var { (startPosn $1, endPosn $1, [getVar $1]) }
 | var VarList { case $2 of (_, end, xs) -> (startPosn $1, end, getVar $1:xs) }

 ExpProj :: { Expr }
 : ExpProj '.1' { span $1 $2 $ Proj1 $1 }
@ -95,13 +104,25 @@ Tuple :: { Expr }
 | Exp ',' Tuple { span $1 $3 $ Pair $1 $3 }

 Statement :: { Statement }
 : var ':' Exp { Decl (getVar $1) $3 }
 | var LhsList '=' Exp { Defn (getVar $1) (makeLams $2 $4) }
 : VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 }
 | var LhsList '=' Exp { spanSt $1 $4 $ Defn (getVar $1) (makeLams $2 $4) }
 | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }

 ReplStatement :: { Statement }
 : Exp { spanSt $1 $1 $ ReplNf $1 }
 | ':t' Exp { spanSt $1 $2 $ ReplTy $2 }
 | ':let' VarList ':' Exp { spanSt $1 $4 $ Decl (thd $2) $4 }
 | ':let' var LhsList '=' Exp { spanSt $1 $5 $ Defn (getVar $2) (makeLams $3 $5) }
 | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }

 Program :: { [Statement] }
 : Statement { [$1] }
 | Statement ';' Program { $1:$3 }

 Pragma :: { Statement }
 : 'PRIMITIVE' var var { Builtin (getVar $2) (getVar $3) }
 | 'PRIMITIVE' var { Builtin (getVar $2) (getVar $2) }

 {
 lexer cont = alexMonadScan >>= cont

@ -126,7 +147,16 @@ instance HasPosn Expr where
 endPosn (Span _ _ e) = e
 endPosn _ = error "no end posn in parsed expression?"

 instance HasPosn (Posn, Posn, a) where
 startPosn (s, _, _) = s
 endPosn (_, e, _) = e

 thd :: (a, b, c) -> c
 thd (x, y, z) = z


 span s e ex = Span ex (startPosn s) (endPosn e)
 spanSt s e ex = SpanSt ex (startPosn s) (endPosn e)

 getVar (Token (TokVar s) _ _) = s
 getVar _ = error "getVar non-var"
--- a/src/Presyntax/Presyntax.hs
+++ b/src/Presyntax/Presyntax.hs
@ -1,5 +1,6 @@
 module Presyntax.Presyntax where


 import Data.Text (Text)

 data Plicity
@ -22,8 +23,14 @@ data Expr
 deriving (Eq, Show, Ord)

 data Statement
 = Decl Text Expr
 | Defn Text Expr
 = Decl [Text] Expr
 | Defn Text Expr
 | Builtin Text Text

 | ReplNf Expr -- REPL eval
 | ReplTy Expr -- REPL :t

 | SpanSt Statement Posn Posn
 deriving (Eq, Show, Ord)

 data Posn
--- a/src/Presyntax/Tokens.hs
+++ b/src/Presyntax/Tokens.hs
@ -15,6 +15,15 @@ data TokenClass
 | TokCParen
 | TokCBrace

 -- {-# #-}
 | TokOPragma
 | TokCPragma

 | TokPrim

 | TokReplLet
 | TokReplT Text

 | TokStar
 | TokColon
 | TokEqual
@ -34,6 +43,9 @@ tokSize TokOParen = 1
 tokSize TokOBrace = 1
 tokSize TokCBrace = 1
 tokSize TokCParen = 1
 tokSize TokCPragma = 3
 tokSize TokOPragma = 3
 tokSize TokPrim = length "PRIMITIVE"
 tokSize TokStar = 1
 tokSize TokColon = 1
 tokSize TokEqual = 1
@ -42,6 +54,8 @@ tokSize TokSemi = 1
 tokSize TokArrow = 2
 tokSize TokPi1 = 2
 tokSize TokPi2 = 2
 tokSize TokReplLet = 4
 tokSize (TokReplT s) = T.length s

 data Token
 = Token { tokenClass :: TokenClass
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@ -7,6 +7,19 @@ import Data.Text (Text)
 import Presyntax.Presyntax (Plicity(..))
 import qualified Data.Text as T
 import Data.IORef (IORef)
 import Data.Set (Set)
 import qualified Data.Set as Set

 data WiredIn
 = WiType
 | WiPretype
 | WiInterval
 | WiI0
 | WiI1
 | WiIAnd
 | WiIOr
 | WiINot
 deriving (Eq, Show, Ord)

 data Term
 = Ref Name
@ -15,11 +28,18 @@ data Term
 | Pi Plicity Text Term Term
 | Meta MV
 | Type
 | Typeω

 | Sigma Text Term Term
 | Pair Term Term
 | Proj1 Term
 | Proj2 Term

 | I
 | I0 | I1
 | IAnd Term Term
 | IOr Term Term
 | INot Term
 deriving (Eq, Show, Ord)

 data MV =
@ -37,11 +57,6 @@ instance Show MV where
 data Name
 = Bound Text
 | Defined Text
 | Builtin Text WiredIn
 deriving (Eq, Show, Ord)

 data WiredIn
 = WiType
 deriving (Eq, Show, Ord)

 type NFType = Value
@ -52,26 +67,58 @@ data Value
 | VPi Plicity Value Closure
 | VSigma Value Closure
 | VPair Value Value
 | VType

 | VType | VTypeω

 | VI
 | VI0 | VI1
 | VIAnd Value Value
 | VIOr Value Value
 | VINot Value
 deriving (Eq, Show, Ord)

 pattern VVar :: Name -> Value
 pattern VVar x = VNe (HVar x) []

 quote :: Value -> Term
 quote (VNe h sp) = foldl goSpine (goHead h) (reverse sp) where
 quoteWith :: Set Text -> Value -> Term
 quoteWith names (VNe h sp) = foldl goSpine (goHead h) (reverse sp) where
 goHead (HVar v) = Ref v
 goHead (HMeta m) = Meta m

 goSpine t (PApp p v) = App p t (quote v)
 goSpine t (PApp p v) = App p t (quoteWith names v)
 goSpine t PProj1 = Proj1 t
 goSpine t PProj2 = Proj2 t

 quote (VLam p (Closure n k)) = Lam p n (quote (k (VVar (Bound n))))
 quote (VPi p d (Closure n k)) = Pi p n (quote d) (quote (k (VVar (Bound n))))
 quote (VSigma d (Closure n k)) = Sigma n (quote d) (quote (k (VVar (Bound n))))
 quote (VPair a b) = Pair (quote a) (quote b)
 quote VType = Type
 quoteWith names (VLam p (Closure n k)) =
 let n' = refresh names n
 in Lam p n' (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))

 quoteWith names (VPi p d (Closure n k)) =
 let n' = refresh names n
 in Pi p n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))

 quoteWith names (VSigma d (Closure n k)) =
 let n' = refresh names n
 in Sigma n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))

 quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b)
 quoteWith _ VType = Type
 quoteWith _ VTypeω = Typeω
 quoteWith _ VI = I
 quoteWith _ VI0 = I0
 quoteWith _ VI1 = I1
 quoteWith names (VIAnd x y) = IAnd (quoteWith names x) (quoteWith names y)
 quoteWith names (VIOr x y) = IOr (quoteWith names x) (quoteWith names y)
 quoteWith names (VINot x) = INot (quoteWith names x)

 refresh :: Set Text -> Text -> Text
 refresh s n
 | T.singleton '_' == n = n
 | n `Set.notMember` s = n
 | otherwise = refresh s (n <> T.singleton '\'')

 quote :: Value -> Term
 quote = quoteWith mempty

 data Closure
 = Closure
--- a/src/Syntax/Pretty.hs
+++ b/src/Syntax/Pretty.hs
@ -0,0 +1,82 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE ViewPatterns #-}
 module Syntax.Pretty where

 import Control.Arrow (Arrow(first))

 import qualified Data.Text.Lazy as L
 import qualified Data.Text as T
 import Data.Text (Text)

 import Presyntax.Presyntax (Plicity(..))

 import Prettyprinter.Render.Terminal
 import Prettyprinter

 import Syntax

 instance Pretty Name where
 pretty (Bound x) = pretty x
 pretty (Defined x) = pretty x

 prettyTm :: Term -> Doc AnsiStyle
 prettyTm (Ref v) = pretty v

 prettyTm (App Im f x) = parenFun f <+> braces (prettyTm x)
 prettyTm (App Ex f x) = parenFun f <+> parenArg x

 prettyTm (Pair x y) = parens $ prettyTm x <> operator comma <+> prettyTm y
 prettyTm (Proj1 x) = prettyTm x <> operator (pretty ".1")
 prettyTm (Proj2 x) = prettyTm x <> operator (pretty ".2")

 prettyTm l@(Lam _ _ _) = pretty '\\' <> hsep (map prettyArgList al) <+> pretty "->" <+> prettyTm bod where
 unwindLam (Lam p x y) = first ((p, x):) (unwindLam y)
 unwindLam t = ([], t)

 (al, bod) = unwindLam l

 prettyArgList (Ex, v) = pretty v
 prettyArgList (Im, v) = braces (pretty v)

 prettyTm (Meta x) = keyword $ pretty '?' <> pretty (mvName x)
 prettyTm Type{} = keyword $ pretty "Type"
 prettyTm Typeω{} = keyword $ pretty "Typeω"
 prettyTm I{} = keyword $ pretty "I"
 prettyTm I0{} = keyword $ pretty "i0"
 prettyTm I1{} = keyword $ pretty "i1"

 prettyTm (Pi Ex (T.unpack -> "_") d r) = prettyDom d <+> pretty "->" <+> prettyTm r
 prettyTm (Pi Im v d r) = braces (pretty v <+> colon <+> prettyTm d) <+> pretty "->" <+> prettyTm r
 prettyTm (Pi Ex v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "->" <+> prettyTm r

 prettyTm (Sigma (T.unpack -> "_") d r) = prettyDom d <+> pretty "*" <+> prettyTm r
 prettyTm (Sigma v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "*" <+> prettyTm r

 prettyTm (IAnd x y) = prettyTm x <+> operator (pretty "&&") <+> prettyTm y
 prettyTm (IOr x y) = prettyTm x <+> operator (pretty "||") <+> prettyTm y
 prettyTm (INot x) = operator (pretty '~') <> prettyTm x

 keyword :: Doc AnsiStyle -> Doc AnsiStyle
 keyword = annotate (color Magenta)

 operator :: Doc AnsiStyle -> Doc AnsiStyle
 operator = annotate (color Yellow)

 parenArg :: Term -> Doc AnsiStyle
 parenArg x@App{} = parens (prettyTm x)
 parenArg x = prettyDom x

 prettyDom :: Term -> Doc AnsiStyle
 prettyDom x@Pi{} = parens (prettyTm x)
 prettyDom x@Sigma{} = parens (prettyTm x)
 prettyDom x = parenFun x

 parenFun :: Term -> Doc AnsiStyle
 parenFun x@Lam{} = parens $ prettyTm x
 parenFun x = prettyTm x

 render :: Doc AnsiStyle -> Text
 render = L.toStrict . renderLazy . layoutPretty defaultLayoutOptions

 showValue :: Value -> String
 showValue = L.unpack . renderLazy . layoutPretty defaultLayoutOptions . prettyTm . quote
--- a/test.tt
+++ b/test.tt
@ -0,0 +1,17 @@
 {-# PRIMITIVE pretype Pretype #-}
 I : Pretype
 {-# PRIMITIVE interval I #-}

 i0 : I
 i1 : I
 {-# PRIMITIVE i0 #-}
 {-# PRIMITIVE i1 #-}

 iand : I -> I -> I
 {-# PRIMITIVE iand #-}

 ior : I -> I -> I
 {-# PRIMITIVE ior #-}

 inot : I -> I
 {-# PRIMITIVE inot #-}