amelia
/
cubical
1
0
Fork 0
Code Issues 0 Pull Requests 0 Projects 0 Releases 0 Wiki Activity
Browse Source

Implement dependent paths (PathP's)

feature/hits
Amélia Liao 3 years ago
parent
a1a8a96fa9
commit
79cb94757c
10 changed files with 296 additions and 104 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +56
    -15
      src/Elab.hs
  2. +102
    -46
      src/Elab/Eval.hs
  3. +9
    -2
      src/Elab/Monad.hs
  4. +21
    -4
      src/Elab/WiredIn.hs
  5. +2
    -1
      src/Elab/WiredIn.hs-boot
  6. +16
    -4
      src/Main.hs
  7. +27
    -24
      src/Presyntax/Parser.y
  8. +25
    -5
      src/Syntax.hs
  9. +6
    -0
      src/Syntax/Pretty.hs
  10. +32
    -3
      test.tt

+ 56
- 15
src/Elab.hs View File

@ -15,9 +15,11 @@ import Elab.Eval
import qualified Presyntax.Presyntax as P import qualified Presyntax.Presyntax as P
import Syntax
import Prettyprinter import Prettyprinter
import Syntax.Pretty
import Syntax
infer :: P.Expr -> ElabM (Term, NFType) infer :: P.Expr -> ElabM (Term, NFType)
infer (P.Span ex a b) = withSpan a b $ infer ex infer (P.Span ex a b) = withSpan a b $ infer ex
@ -28,10 +30,16 @@ infer (P.Var t) = do
infer (P.App p f x) = do infer (P.App p f x) = do
(f, f_ty) <- infer f (f, f_ty) <- infer f
(d, r, w) <- isPiType p f_ty
x <- check x d
x_nf <- eval x
pure (App p (w f) x, r x_nf)
porp <- isPiType p f_ty
case porp of
It'sProd d r w -> do
x <- check x d
x_nf <- eval x
pure (App p (w f) x, r x_nf)
It'sPath li le ri wp -> do
x <- check x VI
x_nf <- eval x
pure (IElim (quote (fun li)) (quote le) (quote ri) (wp f) x, li x_nf)
infer (P.Proj1 x) = do infer (P.Proj1 x) = do
(tm, ty) <- infer x (tm, ty) <- infer x
@ -61,12 +69,23 @@ check tm (VPi P.Im dom (Closure var rng)) =
Lam P.Im var <$> check tm (rng (VVar (Bound var))) Lam P.Im var <$> check tm (rng (VVar (Bound var)))
check (P.Lam p v b) ty = do check (P.Lam p v b) ty = do
(d, r, wp) <- isPiType p ty
assume (Bound v) d $
wp . Lam P.Im v <$> check b (r (VVar (Bound v)))
porp <- isPiType p =<< forceIO ty
case porp of
It'sProd d r wp -> do
assume (Bound v) d $
wp . Lam p v <$> check b (r (VVar (Bound v)))
It'sPath li le ri wp -> do
tm <- assume (Bound v) VI $
Lam P.Ex v <$> check b (li (VVar (Bound v)))
tm_nf <- eval tm
unify (tm_nf @@ VI0) le
`catchElab` (throwElab . WhenCheckingEndpoint le ri VI0)
unify (tm_nf @@ VI1) ri
`catchElab` (throwElab . WhenCheckingEndpoint le ri VI1)
pure (wp (PathIntro (quote (fun li)) tm))
check (P.Pair a b) ty = do check (P.Pair a b) ty = do
(d, r, wp) <- isSigmaType ty
(d, r, wp) <- isSigmaType =<< forceIO ty
a <- check a d a <- check a d
a_nf <- eval a a_nf <- eval a
b <- check b (r a_nf) b <- check b (r a_nf)
@ -99,15 +118,33 @@ isSort VTypeω = pure ()
isSort vt@(VNe HMeta{} _) = unify vt VType isSort vt@(VNe HMeta{} _) = unify vt VType
isSort vt = liftIO . throwIO $ NotEqual 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)
data ProdOrPath
= It'sProd { prodDmn :: NFType
, prodRng :: NFType -> NFType
, prodWrap :: Term -> Term
}
| It'sPath { pathLine :: NFType -> NFType
, pathLeft :: Value
, pathRight :: Value
, pathWrap :: Term -> Term
}
isPiType :: P.Plicity -> NFType -> ElabM ProdOrPath
isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (It'sProd d k id)
isPiType P.Ex (VPath li le ri) = pure (It'sPath (li @@) le ri id)
isPiType P.Ex (VPi P.Im d (Closure _ k)) = do
meta <- newMeta d
porp <- isPiType P.Ex (k meta)
pure $ case porp of
It'sProd d r w -> It'sProd d r (\f -> w (App P.Im f (quote meta)))
It'sPath l x y w -> It'sPath l x y (\f -> w (App P.Im f (quote meta)))
isPiType p t = do isPiType p t = do
dom <- newMeta VType dom <- newMeta VType
name <- newName name <- newName
assume (Bound name) dom $ do assume (Bound name) dom $ do
rng <- newMeta VType rng <- newMeta VType
wp <- isConvertibleTo t (VPi p dom (Closure name (const rng))) wp <- isConvertibleTo t (VPi p dom (Closure name (const rng)))
pure (dom, const rng, wp)
pure (It'sProd dom (const rng) wp)
isSigmaType :: NFType -> ElabM (Value, NFType -> NFType, Term -> Term) isSigmaType :: NFType -> ElabM (Value, NFType -> NFType, Term -> Term)
isSigmaType (VSigma d (Closure _ k)) = pure (d, k, id) isSigmaType (VSigma d (Closure _ k)) = pure (d, k, id)
@ -138,8 +175,9 @@ checkStatement (P.Defn name rhs) k = do
tm_nf <- eval tm tm_nf <- eval tm
define (Defined name) ty tm_nf k define (Defined name) ty tm_nf k
Just (ty_nf, nm) -> do Just (ty_nf, nm) -> do
unless (nm == VVar (Defined name)) . liftIO . throwIO $
Redefinition (Defined name)
case nm of
VVar (Defined n') | n' == name -> pure ()
_ -> liftIO . throwIO $ Redefinition (Defined name)
rhs <- check rhs ty_nf rhs <- check rhs ty_nf
rhs_nf <- eval rhs rhs_nf <- eval rhs
@ -183,4 +221,7 @@ checkProgram [] k = k
checkProgram (st:sts) k = checkStatement st $ checkProgram sts k checkProgram (st:sts) k = checkStatement st $ checkProgram sts k
newtype Redefinition = Redefinition { getRedefName :: Name } newtype Redefinition = Redefinition { getRedefName :: Name }
deriving (Show, Typeable, Exception)
deriving (Show, Typeable, Exception)
data WhenCheckingEndpoint = WhenCheckingEndpoint { leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException }
deriving (Show, Typeable, Exception)

+ 102
- 46
src/Elab/Eval.hs View File

@ -7,8 +7,10 @@ import Control.Monad.Reader
import Control.Exception import Control.Exception
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T import qualified Data.Text as T
import Data.Sequence (Seq)
import Data.Traversable import Data.Traversable
import Data.Set (Set) import Data.Set (Set)
import Data.Typeable import Data.Typeable
@ -16,31 +18,34 @@ import Data.Foldable
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import {-# SOURCE #-} Elab.WiredIn
import Elab.Monad import Elab.Monad
import Presyntax.Presyntax (Plicity(..)) import Presyntax.Presyntax (Plicity(..))
import Syntax.Pretty
import Syntax import Syntax
import System.IO.Unsafe import System.IO.Unsafe
import Syntax.Pretty
import {-# SOURCE #-} Elab.WiredIn
import Prettyprinter
eval :: Term -> ElabM Value eval :: Term -> ElabM Value
eval t = asks (flip evalWithEnv t)
eval t = asks (flip eval' t)
forceIO :: MonadIO m => Value -> m Value forceIO :: MonadIO m => Value -> m Value
forceIO vl@(VNe (HMeta (MV _ cell)) args) = do forceIO vl@(VNe (HMeta (MV _ cell)) args) = do
solved <- liftIO $ readIORef cell solved <- liftIO $ readIORef cell
case solved of case solved of
Just vl -> forceIO $ foldl applProj vl (reverse args)
Just vl -> forceIO $ foldl applProj vl args
Nothing -> pure vl Nothing -> pure vl
forceIO x = pure x forceIO x = pure x
applProj :: Value -> Projection -> Value applProj :: Value -> Projection -> Value
applProj fun (PApp p arg) = vApp p fun arg
applProj fun PProj1 = vProj1 fun
applProj fun PProj2 = vProj2 fun
applProj fun (PApp p arg) = vApp p fun arg
applProj fun (PIElim l x y i) = ielim l x y fun i
applProj fun PProj1 = vProj1 fun
applProj fun PProj2 = vProj2 fun
force :: Value -> Value force :: Value -> Value
force = unsafePerformIO . forceIO force = unsafePerformIO . forceIO
@ -53,11 +58,12 @@ zonkIO (VNe hd sp) = do
HMeta (MV _ cell) -> do HMeta (MV _ cell) -> do
solved <- liftIO $ readIORef cell solved <- liftIO $ readIORef cell
case solved of case solved of
Just vl -> zonkIO $ foldl applProj vl (reverse sp')
Just vl -> zonkIO $ foldl applProj vl sp'
Nothing -> pure $ VNe hd sp' Nothing -> pure $ VNe hd sp'
hd -> pure $ VNe hd sp' hd -> pure $ VNe hd sp'
where where
zonkSp (PApp p x) = PApp p <$> zonkIO x zonkSp (PApp p x) = PApp p <$> zonkIO x
zonkSp (PIElim l x y i) = PIElim <$> zonkIO l <*> zonkIO x <*> zonkIO y <*> zonkIO i
zonkSp PProj1 = pure PProj1 zonkSp PProj1 = pure PProj1
zonkSp PProj2 = pure PProj2 zonkSp PProj2 = pure PProj2
zonkIO (VLam p (Closure s k)) = pure $ VLam p (Closure s (zonk . k)) zonkIO (VLam p (Closure s k)) = pure $ VLam p (Closure s (zonk . k))
@ -65,6 +71,9 @@ zonkIO (VPi p d (Closure s k)) = VPi p <$> zonkIO d <*> pure (Closure s (zonk .
zonkIO (VSigma d (Closure s k)) = VSigma <$> 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 zonkIO (VPair a b) = VPair <$> zonkIO a <*> zonkIO b
zonkIO (VPath line x y) = VPath <$> zonkIO line <*> zonkIO x <*> zonkIO y
zonkIO (VLine line f) = VLine <$> zonkIO line <*> zonkIO f
-- Sorts -- Sorts
zonkIO VType = pure VType zonkIO VType = pure VType
zonkIO VTypeω = pure VTypeω zonkIO VTypeω = pure VTypeω
@ -80,55 +89,65 @@ zonkIO (VINot x) = inot <$> zonkIO x
zonk :: Value -> Value zonk :: Value -> Value
zonk = unsafePerformIO . zonkIO zonk = unsafePerformIO . zonkIO
evalWithEnv :: ElabEnv -> Term -> Value
evalWithEnv env (Ref x) =
eval' :: ElabEnv -> Term -> Value
eval' env (Ref x) =
case Map.lookup x (getEnv env) of case Map.lookup x (getEnv env) of
Just (_, vl) -> vl Just (_, vl) -> vl
_ -> error "variable not in scope when evaluating" _ -> error "variable not in scope when evaluating"
evalWithEnv env (App p f x) = vApp p (evalWithEnv env f) (evalWithEnv env x)
eval' env (App p f x) = vApp p (eval' env f) (eval' env x)
evalWithEnv env (Lam p s t) =
eval' env (Lam p s t) =
VLam p $ Closure s $ \a -> VLam p $ Closure s $ \a ->
evalWithEnv env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
eval' env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
eval' env (Pi p s d t) =
VPi p (eval' env d) $ Closure s $ \a ->
eval' env { getEnv = (Map.insert (Bound s) (error "type of abs", a) (getEnv env))} t
evalWithEnv env (Pi p s d t) =
VPi p (evalWithEnv env d) $ Closure s $ \a ->
evalWithEnv env { getEnv = (Map.insert (Bound s) (error "type of abs", a) (getEnv env))} t
eval' _ (Meta m) = VNe (HMeta m) mempty
evalWithEnv _ (Meta m) = VNe (HMeta m) []
eval' env (Sigma s d t) =
VSigma (eval' env d) $ Closure s $ \a ->
eval' env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
evalWithEnv env (Sigma s d t) =
VSigma (evalWithEnv env d) $ Closure s $ \a ->
evalWithEnv env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
eval' e (Pair a b) = VPair (eval' e a) (eval' e b)
evalWithEnv e (Pair a b) = VPair (evalWithEnv e a) (evalWithEnv e b)
eval' e (Proj1 a) = vProj1 (eval' e a)
eval' e (Proj2 a) = vProj2 (eval' e a)
evalWithEnv e (Proj1 a) = vProj1 (evalWithEnv e a)
evalWithEnv e (Proj2 a) = vProj2 (evalWithEnv e a)
eval' _ Type = VType
eval' _ Typeω = VTypeω
eval' _ I = VI
eval' _ I0 = VI0
eval' _ I1 = VI1
evalWithEnv _ Type = VType
evalWithEnv _ Typeω = VTypeω
evalWithEnv _ I = VI
evalWithEnv _ I0 = VI0
evalWithEnv _ I1 = VI1
eval' e (IAnd x y) = iand (eval' e x) (eval' e y)
eval' e (IOr x y) = ior (eval' e x) (eval' e y)
eval' e (INot x) = inot (eval' e x)
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)
eval' e (PathP l a b) = VPath (eval' e l) (eval' e a) (eval' e b)
eval' e (IElim l x y f i) = ielim (eval' e l) (eval' e x) (eval' e y) (eval' e f) (eval' e i)
eval' e (PathIntro p f) = VLine (eval' e p) (eval' e f)
vApp :: Plicity -> Value -> Value -> Value vApp :: Plicity -> Value -> Value -> Value
vApp p (VLam p' k) arg = assert (p == p') $ clCont k arg
vApp p (VNe h sp) arg = VNe h (PApp p arg:sp)
vApp p (VLam p' k) arg
| p == p' = clCont k arg
| otherwise = error $ "wrong plicity " ++ show p ++ " vs " ++ show p' ++ " in app " ++ show (App p (quote (VLam p' k)) (quote arg))
vApp p (VNe h sp) arg = VNe h (sp Seq.:|> PApp p arg)
vApp _ x _ = error $ "can't apply " ++ show x vApp _ x _ = error $ "can't apply " ++ show x
(@@) :: Value -> Value -> Value
(@@) = vApp Ex
infixl 9 @@
vProj1 :: Value -> Value vProj1 :: Value -> Value
vProj1 (VPair a _) = a vProj1 (VPair a _) = a
vProj1 (VNe h sp) = VNe h (PProj1:sp)
vProj1 (VNe h sp) = VNe h (sp Seq.:|> PProj1)
vProj1 x = error $ "can't proj1 " ++ show x vProj1 x = error $ "can't proj1 " ++ show x
vProj2 :: Value -> Value vProj2 :: Value -> Value
vProj2 (VPair _ b) = b vProj2 (VPair _ b) = b
vProj2 (VNe h sp) = VNe h (PProj2:sp)
vProj2 (VNe h sp) = VNe h (sp Seq.:|> PProj2)
vProj2 x = error $ "can't proj2 " ++ show x vProj2 x = error $ "can't proj2 " ++ show x
data NotEqual = NotEqual Value Value data NotEqual = NotEqual Value Value
@ -141,8 +160,13 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go (VNe x a) (VNe x' a') go (VNe x a) (VNe x' a')
| x == x', length a == length a' = | x == x', length a == length a' =
traverse_ (uncurry unify'Spine) (zip a a')
| otherwise = fail
traverse_ (uncurry unify'Spine) (Seq.zip a a')
go (VNe _hd (_ Seq.:|> PIElim _l x y i)) rhs =
case force i of
VI0 -> unify' x rhs
VI1 -> unify' y rhs
_ -> fail
go (VLam p (Closure _ k)) vl = do go (VLam p (Closure _ k)) vl = do
t <- VVar . Bound <$> newName t <- VVar . Bound <$> newName
@ -171,6 +195,23 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go VI VI = pure () go VI VI = pure ()
go VI0 VI0 = pure () go VI0 VI0 = pure ()
go VI1 VI1 = pure () go VI1 VI1 = pure ()
go (VINot x) (VINot y) = unify' x y
go (VIAnd x y) (VIAnd x' y') = unify' x x' *> unify' y y'
go (VIOr x y) (VIOr x' y') = unify' x x' *> unify' y y'
go (VPath l x y) (VPath l' x' y') = do
unify' l l'
unify' x x'
unify' y y'
go (VLine l p) p' = do
n <- VVar . Bound <$> newName
unify (p @@ n) (ielim l (l @@ VI0) (l @@ VI1) p' n)
go p' (VLine l p) = do
n <- VVar . Bound <$> newName
unify (ielim l (l @@ VI0) (l @@ VI1) p' n) (p @@ n)
go _ _ = fail go _ _ = fail
@ -182,6 +223,8 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
unify'Spine PProj1 PProj1 = pure () unify'Spine PProj1 PProj1 = pure ()
unify'Spine PProj2 PProj2 = pure () unify'Spine PProj2 PProj2 = pure ()
unify'Spine (PIElim _ _ _ i) (PIElim _ _ _ j) = unify' i j
unify'Spine _ _ = fail unify'Spine _ _ = fail
unify :: Value -> Value -> ElabM () unify :: Value -> Value -> ElabM ()
@ -191,8 +234,17 @@ isConvertibleTo :: Value -> Value -> ElabM (Term -> Term)
VPi Im d (Closure _v k) `isConvertibleTo` ty = do VPi Im d (Closure _v k) `isConvertibleTo` ty = do
meta <- newMeta d meta <- newMeta d
cont <- k meta `isConvertibleTo` ty cont <- k meta `isConvertibleTo` ty
pure (\f -> cont (App Ex f (quote meta)))
pure (\f -> cont (App Im f (quote meta)))
VType `isConvertibleTo` VTypeω = pure id VType `isConvertibleTo` VTypeω = pure id
VPi p d (Closure _ k) `isConvertibleTo` VPi p' d' (Closure _ k') | p == p' = do
wp <- d' `isConvertibleTo` d
n <- newName
wp_n <- eval (Lam Ex n (wp (Ref (Bound n))))
wp' <- k (VVar (Bound n)) `isConvertibleTo` k' (wp_n @@ VVar (Bound n))
pure (\f -> Lam p n (wp' (App p f (wp (Ref (Bound n))))))
isConvertibleTo a b = do isConvertibleTo a b = do
unify' a b unify' a b
pure id pure id
@ -210,7 +262,7 @@ newMeta _dom = do
Bound{} -> Just (PApp Ex (VVar n)) Bound{} -> Just (PApp Ex (VVar n))
_ -> Nothing _ -> Nothing
pure (VNe (HMeta m) (catMaybes t))
pure (VNe (HMeta m) (Seq.fromList (catMaybes t)))
newName :: MonadIO m => m T.Text newName :: MonadIO m => m T.Text
newName = liftIO $ do newName = liftIO $ do
@ -221,14 +273,14 @@ _nameCounter :: IORef Int
_nameCounter = unsafePerformIO $ newIORef 0 _nameCounter = unsafePerformIO $ newIORef 0
{-# NOINLINE _nameCounter #-} {-# NOINLINE _nameCounter #-}
solveMeta :: MV -> [Projection] -> Value -> ElabM ()
solveMeta :: MV -> Seq Projection -> Value -> ElabM ()
solveMeta m@(MV _ cell) sp rhs = do solveMeta m@(MV _ cell) sp rhs = do
env <- ask env <- ask
liftIO $ putStrLn (showValue (VNe (HMeta m) sp) ++ " ≡? " ++ showValue rhs)
names <- checkSpine Set.empty sp names <- checkSpine Set.empty sp
checkScope (Set.fromList (Bound <$> names)) rhs checkScope (Set.fromList (Bound <$> names)) rhs
`withNote` hsep [prettyTm (quote (VNe (HMeta m) sp)), pretty '≡', prettyTm (quote rhs)]
let tm = quote rhs let tm = quote rhs
lam = evalWithEnv env $ foldr (Lam Ex) tm names
lam = eval' env $ foldr (Lam Ex) tm names
liftIO . atomicModifyIORef' cell $ \case liftIO . atomicModifyIORef' cell $ \case
Just _ -> error "filled cell in solvedMeta" Just _ -> error "filled cell in solvedMeta"
Nothing -> (Just lam, ()) Nothing -> (Just lam, ())
@ -245,6 +297,7 @@ checkScope scope (VNe h sp) =
traverse_ checkProj sp traverse_ checkProj sp
where where
checkProj (PApp _ t) = checkScope scope t checkProj (PApp _ t) = checkScope scope t
checkProj (PIElim l x y i) = traverse_ (checkScope scope) [l, x, y, i]
checkProj PProj1 = pure () checkProj PProj1 = pure ()
checkProj PProj2 = pure () checkProj PProj2 = pure ()
@ -272,12 +325,15 @@ checkScope s (VIAnd x y) = traverse_ (checkScope s) [x, y]
checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y] checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y]
checkScope s (VINot x) = checkScope s x checkScope s (VINot x) = checkScope s x
checkSpine :: Set Name -> [Projection] -> ElabM [T.Text]
checkSpine scope (PApp Ex (VVar n@(Bound t)):xs)
checkScope s (VPath line a b) = traverse_ (checkScope s) [line, a, b]
checkScope s (VLine _ line) = checkScope s line
checkSpine :: Set Name -> Seq Projection -> ElabM [T.Text]
checkSpine scope (PApp Ex (VVar n@(Bound t)) Seq.:<| xs)
| n `Set.member` scope = liftIO . throwIO $ NonLinearSpine n | n `Set.member` scope = liftIO . throwIO $ NonLinearSpine n
| otherwise = (t:) <$> checkSpine scope xs | otherwise = (t:) <$> checkSpine scope xs
checkSpine _ (p:_) = liftIO . throwIO $ SpineProj p
checkSpine _ [] = pure []
checkSpine _ (p Seq.:<| _) = liftIO . throwIO $ SpineProj p
checkSpine _ Seq.Empty = pure []
newtype NonLinearSpine = NonLinearSpine { getDupeName :: Name } newtype NonLinearSpine = NonLinearSpine { getDupeName :: Name }
deriving (Show, Typeable, Exception) deriving (Show, Typeable, Exception)


+ 9
- 2
src/Elab/Monad.hs View File

@ -49,7 +49,6 @@ assumes nm ty = local go where
, whereBound = maybe (whereBound x) (\l -> Map.union (Map.fromList (zip nm (repeat l))) (whereBound x)) (currentSpan x) , whereBound = maybe (whereBound x) (\l -> Map.union (Map.fromList (zip nm (repeat l))) (whereBound x)) (currentSpan x)
} }
getNameText :: Name -> Text getNameText :: Name -> Text
getNameText (Bound x) = x getNameText (Bound x) = x
getNameText (Defined x) = x getNameText (Defined x) = x
@ -129,4 +128,12 @@ seeAlso k nm = do
catchElab :: Exception e => ElabM a -> (e -> ElabM a) -> ElabM a catchElab :: Exception e => ElabM a -> (e -> ElabM a) -> ElabM a
catchElab k h = do catchElab k h = do
env <- ask env <- ask
liftIO $ runElab k env `catch` \e -> runElab (h e) env
liftIO $ runElab k env `catch` \e -> runElab (h e) env
tryElab :: Exception e => ElabM a -> ElabM (Either e a)
tryElab k = do
env <- ask
liftIO $ (Right <$> runElab k env) `catch` \e -> pure (Left e)
throwElab :: Exception e => e -> ElabM a
throwElab = liftIO . throwIO

+ 21
- 4
src/Elab/WiredIn.hs View File

@ -13,6 +13,7 @@ import Control.Exception
import Data.Typeable import Data.Typeable
import qualified Presyntax.Presyntax as P import qualified Presyntax.Presyntax as P
import Elab.Eval import Elab.Eval
import qualified Data.Sequence as Seq
wiType :: WiredIn -> NFType wiType :: WiredIn -> NFType
wiType WiType = VType wiType WiType = VType
@ -25,6 +26,7 @@ wiType WiI1 = VI
wiType WiIAnd = VI ~> VI ~> VI wiType WiIAnd = VI ~> VI ~> VI
wiType WiIOr = VI ~> VI ~> VI wiType WiIOr = VI ~> VI ~> VI
wiType WiINot = VI ~> VI wiType WiINot = VI ~> VI
wiType WiPathP = dprod (VI ~> VTypeω) \a -> a @@ VI0 ~> a @@ VI1 ~> VType
wiValue :: WiredIn -> Value wiValue :: WiredIn -> Value
wiValue WiType = VType wiValue WiType = VType
@ -37,6 +39,7 @@ wiValue WiI1 = VI1
wiValue WiIAnd = fun \x -> fun \y -> iand x y wiValue WiIAnd = fun \x -> fun \y -> iand x y
wiValue WiIOr = fun \x -> fun \y -> ior x y wiValue WiIOr = fun \x -> fun \y -> ior x y
wiValue WiINot = fun inot wiValue WiINot = fun inot
wiValue WiPathP = fun \a -> fun \x -> fun \y -> VPath a x y
(~>) :: Value -> Value -> Value (~>) :: Value -> Value -> Value
a ~> b = VPi P.Ex a (Closure "_" (const b)) a ~> b = VPi P.Ex a (Closure "_" (const b))
@ -45,19 +48,26 @@ infixr 7 ~>
fun :: (Value -> Value) -> Value fun :: (Value -> Value) -> Value
fun k = VLam P.Ex $ Closure "x" (k . force) fun k = VLam P.Ex $ Closure "x" (k . force)
forallI :: (Value -> Value) -> Value
forallI k = VLam P.Im $ Closure "x" (k . force)
dprod :: Value -> (Value -> Value) -> Value dprod :: Value -> (Value -> Value) -> Value
dprod a b = VPi P.Ex a (Closure "x" b) dprod a b = VPi P.Ex a (Closure "x" b)
forAll :: Value -> (Value -> Value) -> Value
forAll a b = VPi P.Im a (Closure "x" b)
wiredInNames :: Map Text WiredIn wiredInNames :: Map Text WiredIn
wiredInNames = Map.fromList wiredInNames = Map.fromList
[ ("pretype", WiPretype)
, ("type", WiType)
, ("interval", WiInterval)
[ ("Pretype", WiPretype)
, ("Type", WiType)
, ("Interval", WiInterval)
, ("i0", WiI0) , ("i0", WiI0)
, ("i1", WiI1) , ("i1", WiI1)
, ("iand", WiIAnd) , ("iand", WiIAnd)
, ("ior", WiIOr) , ("ior", WiIOr)
, ("inot", WiINot) , ("inot", WiINot)
, ("PathP", WiPathP)
] ]
newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text } newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
@ -90,4 +100,11 @@ inot = \case
VIOr x y -> VIAnd (inot x) (inot y) VIOr x y -> VIAnd (inot x) (inot y)
VIAnd x y -> VIOr (inot x) (inot y) VIAnd x y -> VIOr (inot x) (inot y)
VINot x -> x VINot x -> x
x -> VINot x
x -> VINot x
ielim :: Value -> Value -> Value -> Value -> NFEndp -> Value
ielim _line _left _right fn i =
case force fn of
VLine _ fun -> fun @@ i
VNe n sp -> VNe n (sp Seq.:|> PIElim _line _left _right i)
_ -> error $ "can't ielim " ++ show fn

+ 2
- 1
src/Elab/WiredIn.hs-boot View File

@ -6,4 +6,5 @@ wiType :: WiredIn -> NFType
wiValue :: WiredIn -> NFType wiValue :: WiredIn -> NFType
iand, ior :: Value -> Value -> Value iand, ior :: Value -> Value -> Value
inot :: Value -> Value
inot :: Value -> Value
ielim :: Value -> Value -> Value -> Value -> NFEndp -> Value

+ 16
- 4
src/Main.hs View File

@ -46,7 +46,7 @@ main = do
enterReplIn :: ElabEnv -> IO () enterReplIn :: ElabEnv -> IO ()
enterReplIn env = runInputT defaultSettings (loop env') where enterReplIn env = runInputT defaultSettings (loop env') where
env' = env { commHook = T.putStrLn . render . prettyTm . quote }
env' = env { commHook = T.putStrLn . render . prettyTm . quote . zonk }
loop :: ElabEnv -> InputT IO () loop :: ElabEnv -> InputT IO ()
loop env = do loop env = do
@ -113,6 +113,21 @@ displayExceptions lines =
, Handler \(SeeAlso a b e) -> do , Handler \(SeeAlso a b e) -> do
displayExceptions' lines e displayExceptions' lines e
T.putStrLn $ squiggleUnder a b lines T.putStrLn $ squiggleUnder a b lines
, Handler \(AttachedNote n e) -> do
displayExceptions' lines e
T.putStrLn $ "\x1b[1;32mnote\x1b[0m: " <> render n
, Handler \(WhenCheckingEndpoint le ri ep e) -> do
displayExceptions' lines e
let
endp = case ep of
VI0 -> T.pack "left"
VI1 -> T.pack "right"
_ -> T.pack $ show (prettyTm (quote ep))
T.putStrLn . T.unlines $
[ "\x1b[1;32mnote\x1b[0m: This path was expected to fill the diagram"
, "\t " <> render (prettyTm (quote le)) <> " " <> T.replicate 7 (T.singleton '\x2500') <> " " <> render (prettyTm (quote ri))
, "\x1b[1;32mnote\x1b[0m: the " <> endp <> " endpoint is incorrect"
]
, Handler \(NotEqual ta tb) -> do , Handler \(NotEqual ta tb) -> do
putStrLn . unlines $ putStrLn . unlines $
[ "\x1b[1;31merror\x1b[0m: Mismatch between actual and expected types:" [ "\x1b[1;31merror\x1b[0m: Mismatch between actual and expected types:"
@ -123,9 +138,6 @@ displayExceptions lines =
putStrLn $ "Unknown primitive: " ++ T.unpack x putStrLn $ "Unknown primitive: " ++ T.unpack x
, Handler \(NotInScope x) -> do , Handler \(NotInScope x) -> do
putStrLn $ "Variable not in scope: " ++ show x 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 () displayExceptions' :: Exception e => Text -> e -> IO ()


+ 27
- 24
src/Presyntax/Parser.y View File

@ -1,4 +1,5 @@
{ {
{-# LANGUAGE FlexibleInstances #-}
module Presyntax.Parser where module Presyntax.Parser where
import qualified Data.Text as T import qualified Data.Text as T
@ -57,18 +58,33 @@ import Prelude hiding (span)
Exp :: { Expr } Exp :: { Expr }
Exp Exp
: Exp ExpProj { span $1 $2 $ App Ex $1 $2 }
| Exp '{' Exp '}' { span $1 $4 $ App Im $1 $3 }
: '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
| '(' var ':' Exp ')' ProdTail { span $1 $6 $ Pi Ex (getVar $2) $4 $6 }
| '{' var ':' Exp '}' ProdTail { span $1 $6 $ Pi Im (getVar $2) $4 $6 }
| ExpApp '->' Exp { span $1 $3 $ Pi Ex (T.singleton '_') $1 $3 }
| '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
| '(' 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 }
| '(' var ':' Exp ')' '*' Exp { span $1 $7 $ Sigma (getVar $2) $4 $7 }
| ExpApp '*' Exp { span $1 $3 $ Sigma (T.singleton '_') $1 $3 }
| ExpApp { $1 }
ExpApp :: { Expr }
: ExpApp ExpProj { span $1 $2 $ App Ex $1 $2 }
| ExpApp '{' Exp '}' { span $1 $4 $ App Im $1 $3 }
| ExpProj { $1 }
ExpProj :: { Expr }
: ExpProj '.1' { span $1 $2 $ Proj1 $1 }
| ExpProj '.2' { span $1 $2 $ Proj2 $1 }
| Atom { $1 }
| '(' VarList ':' Exp ')' '*' Exp { span $1 $7 $ makeSigmas (thd $2) $4 $7 }
| ExpProj '*' Exp { span $1 $3 $ Sigma (T.singleton '_') $1 $3 }
Tuple :: { Expr }
: Exp { $1 }
| Exp ',' Tuple { span $1 $3 $ Pair $1 $3 }
| ExpProj { $1 }
Atom :: { Expr }
: var { span $1 $1 $ Var (getVar $1) }
| '(' Tuple ')' { span $1 $3 $ $2 }
ProdTail :: { Expr } ProdTail :: { Expr }
: '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 } : '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 }
@ -87,21 +103,8 @@ LhsList :: { [(Plicity, Text)] }
| LambdaList { $1 } | LambdaList { $1 }
VarList :: { (Posn, Posn, [Text]) } 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 }
| ExpProj '.2' { span $1 $2 $ Proj2 $1 }
| Atom { $1 }
Atom :: { Expr }
: var { span $1 $1 $ Var (getVar $1) }
| '(' Tuple ')' { span $1 $3 $ $2 }
Tuple :: { Expr }
: Exp { $1 }
| Exp ',' Tuple { span $1 $3 $ Pair $1 $3 }
: var { (startPosn $1, endPosn $1, [getVar $1]) }
| var ',' VarList { case $3 of (_, end, xs) -> (startPosn $1, end, getVar $1:xs) }
Statement :: { Statement } Statement :: { Statement }
: VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 } : VarList ':' Exp { spanSt $1 $3 $ Decl (thd $1) $3 }


+ 25
- 5
src/Syntax.hs View File

@ -9,6 +9,8 @@ import qualified Data.Text as T
import Data.IORef (IORef) import Data.IORef (IORef)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
data WiredIn data WiredIn
= WiType = WiType
@ -19,6 +21,7 @@ data WiredIn
| WiIAnd | WiIAnd
| WiIOr | WiIOr
| WiINot | WiINot
| WiPathP
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Term data Term
@ -40,6 +43,14 @@ data Term
| IAnd Term Term | IAnd Term Term
| IOr Term Term | IOr Term Term
| INot Term | INot Term
| PathP Term Term Term
-- ^ PathP : (A : I -> Type) -> A i0 -> A i1 -> Type
| IElim Term Term Term Term Term
-- ^ IElim : {A : I -> Type} {x : A i0} {y : A i1} (p : PathP A x y) (i : I) -> A i
| PathIntro Term Term
-- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1)
-- ~~~~~~~~~ not printed at all
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data MV = data MV =
@ -60,9 +71,10 @@ data Name
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
type NFType = Value type NFType = Value
type NFEndp = Value
data Value data Value
= VNe Head [Projection]
= VNe Head (Seq Projection)
| VLam Plicity Closure | VLam Plicity Closure
| VPi Plicity Value Closure | VPi Plicity Value Closure
| VSigma Value Closure | VSigma Value Closure
@ -75,17 +87,21 @@ data Value
| VIAnd Value Value | VIAnd Value Value
| VIOr Value Value | VIOr Value Value
| VINot Value | VINot Value
| VPath Value Value Value
| VLine Value Value
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
pattern VVar :: Name -> Value pattern VVar :: Name -> Value
pattern VVar x = VNe (HVar x) []
pattern VVar x = VNe (HVar x) Seq.Empty
quoteWith :: Set Text -> Value -> Term quoteWith :: Set Text -> Value -> Term
quoteWith names (VNe h sp) = foldl goSpine (goHead h) (reverse sp) where
quoteWith names (VNe h sp) = foldl goSpine (goHead h) sp where
goHead (HVar v) = Ref v goHead (HVar v) = Ref v
goHead (HMeta m) = Meta m goHead (HMeta m) = Meta m
goSpine t (PApp p v) = App p t (quoteWith names v)
goSpine t (PApp p v) = App p t (quoteWith names v)
goSpine t (PIElim l x y i) = IElim (quote l) (quote x) (quote y) t (quote i)
goSpine t PProj1 = Proj1 t goSpine t PProj1 = Proj1 t
goSpine t PProj2 = Proj2 t goSpine t PProj2 = Proj2 t
@ -111,6 +127,9 @@ 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 (VIOr x y) = IOr (quoteWith names x) (quoteWith names y)
quoteWith names (VINot x) = INot (quoteWith names x) quoteWith names (VINot x) = INot (quoteWith names x)
quoteWith names (VPath line x y) = PathP (quoteWith names line) (quoteWith names x) (quoteWith names y)
quoteWith names (VLine p f) = PathIntro (quoteWith names p) (quoteWith names f)
refresh :: Set Text -> Text -> Text refresh :: Set Text -> Text -> Text
refresh s n refresh s n
| T.singleton '_' == n = n | T.singleton '_' == n = n
@ -143,7 +162,8 @@ data Head
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Projection data Projection
= PApp Plicity Value
= PApp Plicity Value
| PIElim Value Value Value NFEndp
| PProj1 | PProj1
| PProj2 | PProj2
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)

+ 6
- 0
src/Syntax/Pretty.hs View File

@ -56,6 +56,10 @@ prettyTm (IAnd x y) = prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr 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 prettyTm (INot x) = operator (pretty '~') <> prettyTm x
prettyTm (PathP l x y) = keyword (pretty "PathP") <+> parenArg l <+> parenArg x <+> parenArg y
prettyTm (IElim _ _ _ f i) = prettyTm (App Ex f i)
prettyTm (PathIntro _ f) = prettyTm f
keyword :: Doc AnsiStyle -> Doc AnsiStyle keyword :: Doc AnsiStyle -> Doc AnsiStyle
keyword = annotate (color Magenta) keyword = annotate (color Magenta)
@ -64,6 +68,7 @@ operator = annotate (color Yellow)
parenArg :: Term -> Doc AnsiStyle parenArg :: Term -> Doc AnsiStyle
parenArg x@App{} = parens (prettyTm x) parenArg x@App{} = parens (prettyTm x)
parenArg x@IElim{} = parens (prettyTm x)
parenArg x = prettyDom x parenArg x = prettyDom x
prettyDom :: Term -> Doc AnsiStyle prettyDom :: Term -> Doc AnsiStyle
@ -73,6 +78,7 @@ prettyDom x = parenFun x
parenFun :: Term -> Doc AnsiStyle parenFun :: Term -> Doc AnsiStyle
parenFun x@Lam{} = parens $ prettyTm x parenFun x@Lam{} = parens $ prettyTm x
parenFun x@PathIntro{} = parens $ prettyTm x
parenFun x = prettyTm x parenFun x = prettyTm x
render :: Doc AnsiStyle -> Text render :: Doc AnsiStyle -> Text


+ 32
- 3
test.tt View File

@ -1,6 +1,8 @@
{-# PRIMITIVE pretype Pretype #-}
{-# PRIMITIVE Type #-}
{-# PRIMITIVE Pretype #-}
I : Pretype I : Pretype
{-# PRIMITIVE interval I #-}
{-# PRIMITIVE Interval I #-}
i0 : I i0 : I
i1 : I i1 : I
@ -14,4 +16,31 @@ ior : I -> I -> I
{-# PRIMITIVE ior #-} {-# PRIMITIVE ior #-}
inot : I -> I inot : I -> I
{-# PRIMITIVE inot #-}
{-# PRIMITIVE inot #-}
PathP : (A : I -> Pretype) -> A i0 -> A i1 -> Type
{-# PRIMITIVE PathP #-}
Path : {A : Pretype} -> A -> A -> Type
Path {A} = PathP (\i -> A)
refl : {A : Pretype} {x : A} -> Path x x
refl {A} {x} i = x
sym : {A : I -> Pretype} {x : A i0} {y : A i1} -> PathP A x y -> PathP (\i -> A (inot i)) y x
sym p i = p (inot i)
the : (A : Pretype) -> A -> A
the A x = x
iElim : {A : I -> Pretype} {x : A i0} {y : A i1} -> PathP A x y -> (i : I) -> A i
iElim p i = p i
Singl : (A : Type) -> A -> Type
Singl A x = (y : A) * Path x y
isContr : Type -> Type
isContr A = (x : A) * ((y : A) -> Path x y)
singContr : {A : Type} {a : A} -> isContr (Singl A a)
singContr {A} {a} = ((a, \i -> a), \y i -> (y.2 i, \j -> y.2 (iand i j)))

Write Preview
Loading…
Cancel
Save