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

Implement Glueing

master
Amélia Liao 3 years ago
parent
eb83b77bf3
commit
1e6e17c3d8
14 changed files with 549 additions and 271 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +2
    -0
      Setup.hs
  2. +1
    -0
      cubical.cabal
  3. +42
    -7
      intro.tt
  4. +80
    -75
      src/Elab.hs
  5. +72
    -45
      src/Elab/Eval.hs
  6. +1
    -1
      src/Elab/Eval/Formula.hs
  7. +43
    -18
      src/Elab/Monad.hs
  8. +168
    -26
      src/Elab/WiredIn.hs
  9. +5
    -1
      src/Elab/WiredIn.hs-boot
  10. +12
    -9
      src/Main.hs
  11. +4
    -3
      src/Presyntax/Presyntax.hs
  12. +2
    -2
      src/Presyntax/Tokens.hs
  13. +54
    -29
      src/Syntax.hs
  14. +63
    -55
      src/Syntax/Pretty.hs

+ 2
- 0
Setup.hs View File

@ -1,2 +1,4 @@
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain

+ 1
- 0
cubical.cabal View File

@ -20,6 +20,7 @@ executable cubical
build-depends: base ^>= 4.14 build-depends: base ^>= 4.14
, mtl ^>= 2.2 , mtl ^>= 2.2
, syb ^>= 0.7
, text ^>= 1.2 , text ^>= 1.2
, array ^>= 0.5 , array ^>= 0.5
, containers ^>= 0.6 , containers ^>= 0.6


+ 42
- 7
intro.tt View File

@ -59,18 +59,18 @@ inot : I -> I
-- The type PathP generalises this to dependent products (i : I) -> A i. -- The type PathP generalises this to dependent products (i : I) -> A i.
PathP : (A : I -> Pretype) -> A i0 -> A i1 -> Type
PathP : (A : I -> Type) -> A i0 -> A i1 -> Type
{-# PRIMITIVE PathP #-} {-# PRIMITIVE PathP #-}
-- By taking the first argument to be constant we get the equality type -- By taking the first argument to be constant we get the equality type
-- Path. -- Path.
Path : {A : Pretype} -> A -> A -> Type
Path : {A : Type} -> A -> A -> Type
Path {A} = PathP (\i -> A) Path {A} = PathP (\i -> A)
-- reflexivity is given by constant paths -- reflexivity is given by constant paths
refl : {A : Pretype} {x : A} -> Path x x
refl : {A : Type} {x : A} -> Path x x
refl {A} {x} i = x refl {A} {x} i = x
-- Symmetry (for dpeendent paths) is given by inverting the argument to the path, such that -- Symmetry (for dpeendent paths) is given by inverting the argument to the path, such that
@ -78,18 +78,18 @@ refl {A} {x} i = x
-- sym p i1 = p (inot i1) = p i0 -- sym p i1 = p (inot i1) = p i0
-- This has the correct endpoints. -- This has the correct endpoints.
sym : {A : I -> Pretype} {x : A i0} {y : A i1} -> PathP A x y -> PathP (\i -> A (inot i)) y x
sym : {A : I -> Type} {x : A i0} {y : A i1} -> PathP A x y -> PathP (\i -> A (inot i)) y x
sym p i = p (inot i) sym p i = p (inot i)
id : {A : Type} -> A -> A id : {A : Type} -> A -> A
id x = x id x = x
the : (A : Pretype) -> A -> A
the : (A : Type) -> A -> A
the A x = x the A x = x
-- The eliminator for the interval says that if you have x : A i0 and y : A i1, -- The eliminator for the interval says that if you have x : A i0 and y : A i1,
-- and x ≡ y, then you can get a proof A i for every element of the interval. -- and x ≡ y, then you can get a proof A i for every element of the interval.
iElim : {A : I -> Pretype} {x : A i0} {y : A i1} -> PathP A x y -> (i : I) -> A i
iElim : {A : I -> Type} {x : A i0} {y : A i1} -> PathP A x y -> (i : I) -> A i
iElim p i = p i iElim p i = p i
-- This corresponds to the elimination principle for the HIT -- This corresponds to the elimination principle for the HIT
@ -268,6 +268,7 @@ transp A x = comp A (\i [ ]) (inS x)
fill : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) -> Sub (A i0) phi (u i0) -> (i : I) -> A i fill : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) -> Sub (A i0) phi (u i0) -> (i : I) -> A i
fill A {phi} u a0 i = fill A {phi} u a0 i =
comp (\j -> A (iand i j)) comp (\j -> A (iand i j))
{ior phi (inot i)}
(\j [ (phi = i1) as p -> u (iand i j) p, (i = i0) -> outS a0 ]) (\j [ (phi = i1) as p -> u (iand i j) p, (i = i0) -> outS a0 ])
(inS (outS a0)) (inS (outS a0))
@ -293,4 +294,38 @@ transpFun : {A : Type} {B : Type} {C : Type} {D : Type} (p : Path A B) (q : Path
transpFun p q f = refl transpFun p q f = refl
-- When considering the more general case of a composition respecing sides, -- When considering the more general case of a composition respecing sides,
-- the outer transport becomes a composition.
-- the outer transport becomes a composition.
-- Glueing and Univalence
-------------------------
fiber : {A : Type} {B : Type} -> (A -> B) -> B -> Type
fiber f y = (x : A) * Path (f x) y
isEquiv : {A : Type} {B : Type} -> (A -> B) -> Type
isEquiv {A} {B} f = (y : B) -> isContr (fiber f y)
Equiv : (A : Type) (B : Type) -> Type
Equiv A B = (f : A -> B) * isEquiv f
primGlue : (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type
{-# PRIMITIVE Glue primGlue #-}
prim'Glue : {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> (e o).1 (t o)) -> primGlue A T e
{-# PRIMITIVE glue prim'Glue #-}
primUnglue : {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> primGlue A {phi} T e -> A
{-# PRIMITIVE unglue primUnglue #-}
Glue : (A : Type) {phi : I} -> Partial phi ((X : Type) * Equiv X A) -> Type
Glue A {phi} u = primGlue A {phi} (\o -> (u o).1) (\o -> (u o).2)
idEquiv : {A : Type} -> isEquiv (id {A})
idEquiv y = ((y, \i -> y), \u i -> (u.2 (inot i), \j -> u.2 (ior (inot i) j)))
univalence : {A : Type} {B : Type} -> Equiv A B -> Path A B
univalence {A} {B} equiv i = Glue B (\[ (i = i0) -> (A, equiv), (i = i1) -> (B, the B, idEquiv {B}) ])
A, B : Type
f : Equiv A B
x : A
line : I -> Type
line i = univalence {A} {B} f i

+ 80
- 75
src/Elab.hs View File

@ -1,3 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -7,6 +8,7 @@ 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.Set as Set
import Data.Traversable import Data.Traversable
import Data.Typeable import Data.Typeable
import Data.Foldable import Data.Foldable
@ -20,9 +22,8 @@ import qualified Presyntax.Presyntax as P
import Prettyprinter import Prettyprinter
import Syntax
import Syntax.Pretty import Syntax.Pretty
import qualified Data.Text as T
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
@ -72,23 +73,23 @@ check :: P.Expr -> NFType -> ElabM Term
check (P.Span ex a b) ty = withSpan a b $ check ex ty 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' = check (P.Lam p var body) (VPi p' dom (Closure _ rng)) | p == p' =
assume (Bound var) dom $
Lam p var <$> check body (rng (VVar (Bound var)))
assume (Bound var 0) dom $ \name ->
Lam p name <$> check body (rng (VVar name))
check tm (VPi P.Im dom (Closure var rng)) = check tm (VPi P.Im dom (Closure var rng)) =
assume (Bound var) dom $
Lam P.Im var <$> check tm (rng (VVar (Bound var)))
assume var dom $ \name ->
Lam P.Im name <$> check tm (rng (VVar name))
check (P.Lam p v b) ty = do check (P.Lam p v b) ty = do
porp <- isPiType p =<< forceIO ty porp <- isPiType p =<< forceIO ty
case porp of case porp of
It'sProd d r wp -> It'sProd d r wp ->
assume (Bound v) d $
wp . Lam p v <$> check b (r (VVar (Bound v)))
assume (Bound v 0) d $ \name ->
wp . Lam p name <$> check b (r (VVar name))
It'sPath li le ri wp -> do It'sPath li le ri wp -> do
tm <- assume (Bound v) VI $
Lam P.Ex v <$> check b (force (li (VVar (Bound v))))
tm <- assume (Bound v 0) VI $ \var ->
Lam P.Ex var <$> check b (force (li (VVar var)))
tm_nf <- eval tm tm_nf <- eval tm
@ -101,12 +102,12 @@ check (P.Lam p v b) ty = do
pure (wp (PathIntro (quote (fun li)) (quote le) (quote ri) tm)) pure (wp (PathIntro (quote (fun li)) (quote le) (quote ri) tm))
It'sPartial phi a wp -> It'sPartial phi a wp ->
assume (Bound v) (VIsOne phi) $
wp . Lam p v <$> check b a
assume (Bound v 0) (VIsOne phi) $ \var ->
wp . Lam p var <$> check b a
It'sPartialP phi a wp -> It'sPartialP phi a wp ->
assume (Bound v) (VIsOne phi) $
wp . Lam p v <$> check b (a @@ VVar (Bound v))
assume (Bound v 0) (VIsOne phi) $ \var ->
wp . Lam p var <$> check b (a @@ VVar var)
check (P.Pair a b) ty = do check (P.Pair a b) ty = do
(d, r, wp) <- isSigmaType =<< forceIO ty (d, r, wp) <- isSigmaType =<< forceIO ty
@ -119,17 +120,17 @@ check (P.Pi p s d r) ty = do
isSort ty isSort ty
d <- check d ty d <- check d ty
d_nf <- eval d d_nf <- eval d
assume (Bound s) d_nf $ do
assume (Bound s 0) d_nf \var -> do
r <- check r ty r <- check r ty
pure (Pi p s d r)
pure (Pi p var d r)
check (P.Sigma s d r) ty = do check (P.Sigma s d r) ty = do
isSort ty isSort ty
d <- check d ty d <- check d ty
d_nf <- eval d d_nf <- eval d
assume (Bound s) d_nf $ do
assume (Bound s 0) d_nf \var -> do
r <- check r ty r <- check r ty
pure (Sigma s d r)
pure (Sigma var d r)
check (P.LamSystem bs) ty = do check (P.LamSystem bs) ty = do
(extent, dom) <- isPartialType ty (extent, dom) <- isPartialType ty
@ -138,34 +139,34 @@ check (P.LamSystem bs) ty = do
phi <- checkFormula (P.condF formula) phi <- checkFormula (P.condF formula)
rhses <- rhses <-
case P.condV formula of case P.condV formula of
Just t -> assume (Bound t) (VIsOne phi) $ do
Just t -> assume (Bound t 0) (VIsOne phi) $ \var -> do
env <- ask env <- ask
for (truthAssignments phi (getEnv env)) $ \e -> do for (truthAssignments phi (getEnv env)) $ \e -> do
let env' = env{ getEnv = e } let env' = env{ getEnv = e }
check rhs (eval' env' dom_q)
(Just var,) <$> check rhs (eval' env' dom_q)
Nothing -> do Nothing -> do
env <- ask env <- ask
for (truthAssignments phi (getEnv env)) $ \e -> do for (truthAssignments phi (getEnv env)) $ \e -> do
let env' = env{ getEnv = e } let env' = env{ getEnv = e }
check rhs (eval' env' dom_q)
pure (n, (phi, (P.condV formula, head rhses)))
(Nothing,) <$> check rhs (eval' env' dom_q)
pure (n, (phi, head rhses))
unify extent (foldl ior VI0 (map (fst . snd) eqns)) unify extent (foldl ior VI0 (map (fst . snd) eqns))
for_ eqns $ \(n, (formula, (binding, rhs))) -> do for_ eqns $ \(n, (formula, (binding, rhs))) -> do
let let
k = case binding of k = case binding of
Just v -> assume (Bound v) (VIsOne formula)
Just v -> assume v (VIsOne formula) . const
Nothing -> id Nothing -> id
k $ for_ eqns $ \(n', (formula', (binding, rhs'))) -> do k $ for_ eqns $ \(n', (formula', (binding, rhs'))) -> do
let let
k = case binding of k = case binding of
Just v -> assume (Bound v) (VIsOne formula)
Just v -> assume v (VIsOne formula) . const
Nothing -> id Nothing -> id
truth = possible mempty (iand formula formula') truth = possible mempty (iand formula formula')
add [] = id add [] = id
add ((~(HVar x), True):xs) = define x VI VI1 . add xs
add ((~(HVar x), False):xs) = define x VI VI0 . add xs
add ((~(HVar x), True):xs) = redefine x VI VI1 . add xs
add ((~(HVar x), False):xs) = redefine x VI VI0 . add xs
k $ when ((n /= n') && fst truth) . add (Map.toList (snd truth)) $ do k $ when ((n /= n') && fst truth) . add (Map.toList (snd truth)) $ do
vl <- eval rhs vl <- eval rhs
vl' <- eval rhs' vl' <- eval rhs'
@ -180,7 +181,7 @@ check (P.LamSystem bs) ty = do
let let
mkB name (Just v, b) = App P.Ex (Lam P.Ex v b) (Ref name) mkB name (Just v, b) = App P.Ex (Lam P.Ex v b) (Ref name)
mkB _ (Nothing, b) = b mkB _ (Nothing, b) = b
pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB (Bound name) y)) eqns))))
pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB name y)) eqns))))
check exp ty = do check exp ty = do
(tm, has) <- switch $ infer exp (tm, has) <- switch $ infer exp
@ -204,10 +205,11 @@ checkFormula (P.FIs1 x) = do
pure (VVar nm) pure (VVar nm)
isSort :: NFType -> ElabM () isSort :: NFType -> ElabM ()
isSort VType = pure ()
isSort VTypeω = pure ()
isSort vt@(VNe HMeta{} _) = unify vt VType
isSort vt = throwElab $ NotEqual vt VType
isSort t = isSort (force t) where
isSort VType = pure ()
isSort VTypeω = pure ()
isSort vt@(VNe HMeta{} _) = unify vt VType
isSort vt = throwElab $ NotEqual vt VType
data ProdOrPath data ProdOrPath
= It'sProd { prodDmn :: NFType = It'sProd { prodDmn :: NFType
@ -229,45 +231,48 @@ data ProdOrPath
} }
isPiType :: P.Plicity -> NFType -> ElabM ProdOrPath 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 (VPartial phi a) = pure (It'sPartial phi a id)
isPiType P.Ex (VPartialP phi a) = pure (It'sPartialP phi a 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)))
It'sPartial phi a w -> It'sPartial phi a (\f -> w (App P.Im f (quote meta)))
It'sPartialP phi a w -> It'sPartialP phi a (\f -> w (App P.Im f (quote meta)))
isPiType p t = do
dom <- newMeta VType
name <- newName
assume (Bound name) dom $ do
rng <- newMeta VType
wp <- isConvertibleTo t (VPi p dom (Closure name (const rng)))
pure (It'sProd dom (const rng) wp)
isPiType p x = isPiType p (force x) where
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 (VPartial phi a) = pure (It'sPartial phi a id)
isPiType P.Ex (VPartialP phi a) = pure (It'sPartialP phi a 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)))
It'sPartial phi a w -> It'sPartial phi a (\f -> w (App P.Im f (quote meta)))
It'sPartialP phi a w -> It'sPartialP phi a (\f -> w (App P.Im f (quote meta)))
isPiType p t = do
dom <- newMeta VType
name <- newName
assume name dom $ \name -> do
rng <- newMeta VType
wp <- isConvertibleTo t (VPi p dom (Closure name (const rng)))
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 t = do
dom <- newMeta VType
name <- newName
assume (Bound name) dom $ do
rng <- newMeta VType
wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
pure (dom, const rng, wp)
isSigmaType t = isSigmaType (force t) where
isSigmaType (VSigma d (Closure _ k)) = pure (d, k, id)
isSigmaType t = do
dom <- newMeta VType
name <- newName
assume name dom $ \name -> do
rng <- newMeta VType
wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
pure (dom, const rng, wp)
isPartialType :: NFType -> ElabM (NFEndp, Value) isPartialType :: NFType -> ElabM (NFEndp, Value)
isPartialType (VPartial phi a) = pure (phi, a)
isPartialType (VPartialP phi a) = pure (phi, a)
isPartialType t = do
phi <- newMeta VI
dom <- newMeta (VPartial phi VType)
unify t (VPartial phi dom)
pure (phi, dom)
isPartialType t = isPartialType (force t) where
isPartialType (VPartial phi a) = pure (phi, a)
isPartialType (VPartialP phi a) = pure (phi, a)
isPartialType t = do
phi <- newMeta VI
dom <- newMeta (VPartial phi VType)
unify t (VPartial phi dom)
pure (phi, dom)
checkStatement :: P.Statement -> ElabM a -> ElabM a checkStatement :: P.Statement -> ElabM a -> ElabM a
checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k
@ -275,23 +280,23 @@ checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k
checkStatement (P.Decl name ty) k = do checkStatement (P.Decl name ty) k = do
ty <- check ty VTypeω ty <- check ty VTypeω
ty_nf <- eval ty ty_nf <- eval ty
assumes (Defined <$> name) ty_nf k
assumes (flip Defined 0 <$> name) ty_nf (const k)
checkStatement (P.Defn name rhs) k = do checkStatement (P.Defn name rhs) k = do
ty <- asks (Map.lookup (Defined name) . getEnv)
ty <- asks (Map.lookup name . nameMap)
case ty of case ty of
Nothing -> do Nothing -> do
(tm, ty) <- infer rhs (tm, ty) <- infer rhs
tm_nf <- eval tm tm_nf <- eval tm
define (Defined name) ty tm_nf k
Just (ty_nf, nm) -> do
case nm of
VVar (Defined n') | n' == name -> pure ()
_ -> throwElab $ Redefinition (Defined name)
define (Defined name 0) ty tm_nf (const k)
Just nm -> do
ty_nf <- getNfType nm
t <- asks (Set.member nm . definedNames)
when t $ throwElab (Redefinition (Defined name 0))
rhs <- check rhs ty_nf rhs <- check rhs ty_nf
rhs_nf <- eval rhs rhs_nf <- eval rhs
define (Defined name) ty_nf rhs_nf k
define (Defined name 0) ty_nf rhs_nf (const k)
checkStatement (P.Builtin winame var) k = do checkStatement (P.Builtin winame var) k = do
wi <- wi <-
@ -311,7 +316,7 @@ checkStatement (P.Builtin winame var) k = do
liftIO $ liftIO $
runElab check env `catch` \(_ :: NotInScope) -> pure () runElab check env `catch` \(_ :: NotInScope) -> pure ()
define (Defined var) (wiType wi) (wiValue wi) k
define (Defined var 0) (wiType wi) (wiValue wi) (const k)
checkStatement (P.ReplNf e) k = do checkStatement (P.ReplNf e) k = do
(e, _) <- infer e (e, _) <- infer e


+ 72
- 45
src/Elab/Eval.hs View File

@ -22,6 +22,8 @@ import Data.Maybe
import Elab.Eval.Formula import Elab.Eval.Formula
import Elab.Monad import Elab.Monad
import GHC.Stack
import Presyntax.Presyntax (Plicity(..)) import Presyntax.Presyntax (Plicity(..))
import Prettyprinter import Prettyprinter
@ -32,17 +34,20 @@ import Syntax
import System.IO.Unsafe import System.IO.Unsafe
import {-# SOURCE #-} Elab.WiredIn import {-# SOURCE #-} Elab.WiredIn
import GHC.Stack
eval :: Term -> ElabM Value eval :: Term -> ElabM Value
eval t = asks (flip eval' t) eval t = asks (flip eval' t)
forceIO :: MonadIO m => Value -> m Value forceIO :: MonadIO m => Value -> m Value
forceIO mv@(VNe (HMeta (MV id cell)) args) = do
forceIO mv@(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 args Just vl -> forceIO $ foldl applProj vl args
Nothing -> pure mv Nothing -> pure mv
forceIO vl@(VSystem fs) =
case Map.lookup VI1 fs of
Just x -> forceIO x
Nothing -> pure vl
forceIO (VComp line phi u a0) = comp line <$> forceIO phi <*> pure u <*> pure a0 forceIO (VComp line phi u a0) = comp line <$> forceIO phi <*> pure u <*> pure a0
forceIO x = pure x forceIO x = pure x
@ -73,6 +78,7 @@ zonkIO (VNe hd sp) = do
zonkSp (POuc a phi u) = POuc <$> zonkIO a <*> zonkIO phi <*> zonkIO u zonkSp (POuc a phi u) = POuc <$> zonkIO a <*> zonkIO phi <*> zonkIO u
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))
zonkIO (VPi p d (Closure s k)) = VPi p <$> zonkIO d <*> pure (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 (VSigma d (Closure s k)) = VSigma <$> zonkIO d <*> pure (Closure s (zonk . k))
@ -107,6 +113,10 @@ zonkIO (VSub a b c) = VSub <$> zonkIO a <*> zonkIO b <*> zonkIO c
zonkIO (VInc a b c) = VInc <$> zonkIO a <*> zonkIO b <*> zonkIO c zonkIO (VInc a b c) = VInc <$> zonkIO a <*> zonkIO b <*> zonkIO c
zonkIO (VComp a b c d) = comp <$> zonkIO a <*> zonkIO b <*> zonkIO c <*> zonkIO d zonkIO (VComp a b c d) = comp <$> zonkIO a <*> zonkIO b <*> zonkIO c <*> zonkIO d
zonkIO (VGlueTy a phi ty e) = glueType <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e
zonkIO (VGlue a phi ty e t x) = glueElem <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e <*> zonkIO t <*> zonkIO x
zonkIO (VUnglue a phi ty e x) = unglue <$> zonkIO a <*> zonkIO phi <*> zonkIO ty <*> zonkIO e <*> zonkIO x
mkVSystem :: Map.Map Value Value -> Value mkVSystem :: Map.Map Value Value -> Value
mkVSystem map = mkVSystem map =
case Map.lookup VI1 map of case Map.lookup VI1 map of
@ -120,22 +130,22 @@ eval' :: ElabEnv -> Term -> Value
eval' env (Ref x) = eval' env (Ref x) =
case Map.lookup x (getEnv env) of case Map.lookup x (getEnv env) of
Just (_, vl) -> vl Just (_, vl) -> vl
_ -> VVar x
_ -> VNe (HVar x) mempty
eval' env (App p f x) = vApp p (eval' env f) (eval' env x) eval' env (App p f x) = vApp p (eval' env f) (eval' env x)
eval' env (Lam p s t) = eval' env (Lam p s t) =
VLam p $ Closure s $ \a -> VLam p $ Closure s $ \a ->
eval' env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
eval' env { getEnv = Map.insert s (error "type of abs", a) (getEnv env) } t
eval' env (Pi p s d t) = eval' env (Pi p s d t) =
VPi p (eval' env d) $ Closure s $ \a -> VPi p (eval' env d) $ Closure s $ \a ->
eval' env { getEnv = (Map.insert (Bound s) (error "type of abs", a) (getEnv env))} t
eval' env { getEnv = (Map.insert s (error "type of abs", a) (getEnv env))} t
eval' _ (Meta m) = VNe (HMeta m) mempty eval' _ (Meta m) = VNe (HMeta m) mempty
eval' env (Sigma s d t) = eval' env (Sigma s d t) =
VSigma (eval' env d) $ Closure s $ \a -> VSigma (eval' env d) $ Closure s $ \a ->
eval' env { getEnv = Map.insert (Bound s) (error "type of abs", a) (getEnv env) } t
eval' env { getEnv = Map.insert s (error "type of abs", a) (getEnv env) } t
eval' e (Pair a b) = VPair (eval' e a) (eval' e b) eval' e (Pair a b) = VPair (eval' e a) (eval' e b)
@ -171,29 +181,33 @@ eval' e (Ouc a phi u x) = outS (eval' e a) (eval' e phi) (eval' e u) (eval' e x)
eval' e (Comp a phi u a0) = comp (eval' e a) (eval' e phi) (eval' e u) (eval' e a0) eval' e (Comp a phi u a0) = comp (eval' e a) (eval' e phi) (eval' e u) (eval' e a0)
eval' e (GlueTy a phi tys f) = glueType (eval' e a) (eval' e phi) (eval' e tys) (eval' e f)
eval' e (Glue a phi tys eqvs t x) = glueElem (eval' e a) (eval' e phi) (eval' e tys) (eval' e eqvs) (eval' e t) (eval' e x)
eval' e (Unglue a phi tys f x) = unglue (eval' e a) (eval' e phi) (eval' e tys) (eval' e f) (eval' e x)
vApp :: HasCallStack => Plicity -> Value -> Value -> Value vApp :: HasCallStack => Plicity -> Value -> Value -> Value
vApp p (VLam p' k) arg vApp p (VLam p' k) arg
| p == p' = clCont 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)) | 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 p (VNe h sp) arg = VNe h (sp Seq.:|> PApp p arg)
vApp p (VSystem fs) arg = VSystem (fmap (flip (vApp p) arg) fs) vApp p (VSystem fs) arg = VSystem (fmap (flip (vApp p) arg) fs)
vApp _ x _ = error $ "can't apply " ++ show x
vApp _ x _ = error $ "can't apply " ++ show (prettyTm (quote x))
(@@) :: HasCallStack => Value -> Value -> Value (@@) :: HasCallStack => Value -> Value -> Value
(@@) = vApp Ex (@@) = vApp Ex
infixl 9 @@ infixl 9 @@
vProj1 :: Value -> Value
vProj1 :: HasCallStack => Value -> Value
vProj1 (VPair a _) = a vProj1 (VPair a _) = a
vProj1 (VNe h sp) = VNe h (sp Seq.:|> PProj1) vProj1 (VNe h sp) = VNe h (sp Seq.:|> PProj1)
vProj1 (VSystem fs) = VSystem (fmap vProj1 fs) vProj1 (VSystem fs) = VSystem (fmap vProj1 fs)
vProj1 x = error $ "can't proj1 " ++ show x
vProj1 x = error $ "can't proj1 " ++ show (prettyTm (quote x))
vProj2 :: Value -> Value
vProj2 :: HasCallStack => Value -> Value
vProj2 (VPair _ b) = b vProj2 (VPair _ b) = b
vProj2 (VNe h sp) = VNe h (sp Seq.:|> PProj2) vProj2 (VNe h sp) = VNe h (sp Seq.:|> PProj2)
vProj2 (VSystem fs) = VSystem (fmap vProj2 fs) vProj2 (VSystem fs) = VSystem (fmap vProj2 fs)
vProj2 x = error $ "can't proj2 " ++ show x
vProj2 x = error $ "can't proj2 " ++ show (prettyTm (quote x))
data NotEqual = NotEqual Value Value data NotEqual = NotEqual Value Value
deriving (Show, Typeable, Exception) deriving (Show, Typeable, Exception)
@ -206,7 +220,6 @@ 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) (Seq.zip a a') traverse_ (uncurry unify'Spine) (Seq.zip a a')
| x == HVar (Bound (T.pack "y")), x' == HVar (Bound (T.pack "A")) = error "what"
go lhs@(VNe _hd (_ Seq.:|> PIElim _l x y i)) rhs = go lhs@(VNe _hd (_ Seq.:|> PIElim _l x y i)) rhs =
case force i of case force i of
@ -225,23 +238,23 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
_ -> fail _ -> fail
go (VLam p (Closure _ k)) vl = do go (VLam p (Closure _ k)) vl = do
t <- VVar . Bound <$> newName
t <- VVar <$> newName
unify' (k t) (vApp p vl t) unify' (k t) (vApp p vl t)
go vl (VLam p (Closure _ k)) = do go vl (VLam p (Closure _ k)) = do
t <- VVar . Bound <$> newName
t <- VVar <$> 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 (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 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 go (VPi p d (Closure _ k)) (VPi p' d' (Closure _ k')) | p == p' = do
t <- VVar . Bound <$> newName
t <- VVar <$> newName
unify' d d' unify' d d'
unify' (k t) (k' t) unify' (k t) (k' t)
go (VSigma d (Closure _ k)) (VSigma d' (Closure _ k')) = do go (VSigma d (Closure _ k)) (VSigma d' (Closure _ k')) = do
t <- VVar . Bound <$> newName
t <- VVar <$> newName
unify' d d' unify' d d'
unify' (k t) (k' t) unify' (k t) (k' t)
@ -256,11 +269,11 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
unify' y y' unify' y y'
go (VLine l x y p) p' = do go (VLine l x y p) p' = do
n <- VVar . Bound <$> newName
n <- VVar <$> newName
unify (p @@ n) (ielim l x y p' n) unify (p @@ n) (ielim l x y p' n)
go p' (VLine l x y p) = do go p' (VLine l x y p) = do
n <- VVar . Bound <$> newName
n <- VVar <$> newName
unify (ielim l x y p' n) (p @@ n) unify (ielim l x y p' n) (p @@ n)
go (VIsOne x) (VIsOne y) = unify' x y go (VIsOne x) (VIsOne y) = unify' x y
@ -282,6 +295,15 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
go (VComp a phi u a0) (VComp a' phi' u' a0') = go (VComp a phi u a0) (VComp a' phi' u' a0') =
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')] traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
go (VGlueTy _ VI1 u _0) rhs = unify' (u @@ VItIsOne) rhs
go lhs (VGlueTy _ VI1 u _0) = unify' lhs (u @@ VItIsOne)
go (VGlueTy a phi u a0) (VGlueTy a' phi' u' a0') =
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')]
go (VGlue a phi u a0 t x) (VGlue a' phi' u' a0' t' x') =
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0'), (t, t'), (x, x')]
go (VSystem sys) rhs = goSystem unify' sys rhs go (VSystem sys) rhs = goSystem unify' sys rhs
go rhs (VSystem sys) = goSystem (flip unify') sys rhs go rhs (VSystem sys) = goSystem (flip unify') sys rhs
@ -321,29 +343,30 @@ unify :: HasCallStack => Value -> Value -> ElabM ()
unify a b = unify' a b `catchElab` \(_ :: NotEqual) -> liftIO $ throwIO (NotEqual a b) unify a b = unify' a b `catchElab` \(_ :: NotEqual) -> liftIO $ throwIO (NotEqual a b)
isConvertibleTo :: Value -> Value -> ElabM (Term -> Term) 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 Im f (quote meta)))
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))))
isConvertibleTo a b = isConvertibleTo (force a) (force b) where
VPi Im d (Closure _v k) `isConvertibleTo` ty = do
meta <- newMeta d
cont <- k meta `isConvertibleTo` ty
pure (\f -> cont (App Im f (quote meta)))
VType `isConvertibleTo` VTypeω = pure id
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))))))
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 n)))
isConvertibleTo a b = do
unify' a b
pure id
wp' <- k (VVar n) `isConvertibleTo` k' (wp_n @@ VVar n)
pure (\f -> Lam p n (wp' (App p f (wp (Ref n)))))
isConvertibleTo a b = do
unify' a b
pure id
newMeta :: Value -> ElabM Value newMeta :: Value -> ElabM Value
newMeta _dom = do newMeta _dom = do
n <- newName n <- newName
c <- liftIO $ newIORef Nothing c <- liftIO $ newIORef Nothing
let m = MV n c
let m = MV (getNameText n) c
env <- asks getEnv env <- asks getEnv
@ -354,10 +377,10 @@ newMeta _dom = do
pure (VNe (HMeta m) (Seq.fromList (catMaybes t))) pure (VNe (HMeta m) (Seq.fromList (catMaybes t)))
newName :: MonadIO m => m T.Text
newName :: MonadIO m => m Name
newName = liftIO $ do newName = liftIO $ do
x <- atomicModifyIORef _nameCounter $ \x -> (x + 1, x + 1) x <- atomicModifyIORef _nameCounter $ \x -> (x + 1, x + 1)
pure (T.pack (show x))
pure (Bound (T.pack (show x)) x)
_nameCounter :: IORef Int _nameCounter :: IORef Int
_nameCounter = unsafePerformIO $ newIORef 0 _nameCounter = unsafePerformIO $ newIORef 0
@ -367,7 +390,7 @@ solveMeta :: MV -> Seq Projection -> Value -> ElabM ()
solveMeta m@(MV _ cell) sp rhs = do solveMeta m@(MV _ cell) sp rhs = do
env <- ask env <- ask
names <- checkSpine Set.empty sp names <- checkSpine Set.empty sp
checkScope (Set.fromList (Bound <$> names)) rhs
checkScope (Set.fromList names) rhs
`withNote` hsep [prettyTm (quote (VNe (HMeta m) sp)), pretty '≡', prettyTm (quote rhs)] `withNote` hsep [prettyTm (quote (VNe (HMeta m) sp)), pretty '≡', prettyTm (quote rhs)]
let tm = quote rhs let tm = quote rhs
lam = eval' env $ foldr (Lam Ex) tm names lam = eval' env $ foldr (Lam Ex) tm names
@ -393,15 +416,15 @@ checkScope scope (VNe h sp) =
checkProj PProj2 = pure () checkProj PProj2 = pure ()
checkScope scope (VLam _ (Closure n k)) = checkScope scope (VLam _ (Closure n k)) =
checkScope (Set.insert (Bound n) scope) (k (VVar (Bound n)))
checkScope (Set.insert n scope) (k (VVar n))
checkScope scope (VPi _ d (Closure n k)) = do checkScope scope (VPi _ d (Closure n k)) = do
checkScope scope d checkScope scope d
checkScope (Set.insert (Bound n) scope) (k (VVar (Bound n)))
checkScope (Set.insert n scope) (k (VVar n))
checkScope scope (VSigma d (Closure n k)) = do checkScope scope (VSigma d (Closure n k)) = do
checkScope scope d checkScope scope d
checkScope (Set.insert (Bound n) scope) (k (VVar (Bound n)))
checkScope (Set.insert n scope) (k (VVar n))
checkScope s (VPair a b) = traverse_ (checkScope s) [a, b] checkScope s (VPair a b) = traverse_ (checkScope s) [a, b]
@ -433,10 +456,14 @@ checkScope s (VSub a b c) = traverse_ (checkScope s) [a, b, c]
checkScope s (VInc a b c) = traverse_ (checkScope s) [a, b, c] checkScope s (VInc a b c) = traverse_ (checkScope s) [a, b, c]
checkScope s (VComp a phi u a0) = traverse_ (checkScope s) [a, phi, u, a0] checkScope s (VComp a phi u a0) = traverse_ (checkScope s) [a, phi, u, a0]
checkSpine :: Set Name -> Seq Projection -> ElabM [T.Text]
checkSpine scope (PApp Ex (VVar n@(Bound t)) Seq.:<| xs)
checkScope s (VGlueTy a phi ty eq) = traverse_ (checkScope s) [a, phi, ty, eq]
checkScope s (VGlue a phi ty eq inv x) = traverse_ (checkScope s) [a, phi, ty, eq, inv, x]
checkScope s (VUnglue a phi ty eq vl) = traverse_ (checkScope s) [a, phi, ty, eq, vl]
checkSpine :: Set Name -> Seq Projection -> ElabM [Name]
checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs)
| n `Set.member` scope = throwElab $ NonLinearSpine n | n `Set.member` scope = throwElab $ NonLinearSpine n
| otherwise = (t:) <$> checkSpine scope xs
| otherwise = (n:) <$> checkSpine scope xs
checkSpine _ (p Seq.:<| _) = throwElab $ SpineProj p checkSpine _ (p Seq.:<| _) = throwElab $ SpineProj p
checkSpine _ Seq.Empty = pure [] checkSpine _ Seq.Empty = pure []
@ -444,4 +471,4 @@ newtype NonLinearSpine = NonLinearSpine { getDupeName :: Name }
deriving (Show, Typeable, Exception) deriving (Show, Typeable, Exception)
newtype SpineProjection = SpineProj { getSpineProjection :: Projection } newtype SpineProjection = SpineProj { getSpineProjection :: Projection }
deriving (Show, Typeable, Exception)
deriving (Show, Typeable, Exception)

+ 1
- 1
src/Elab/Eval/Formula.hs View File

@ -56,7 +56,7 @@ possible sc VI1 = (True, sc)
possible sc _ = (False, sc) possible sc _ = (False, sc)
truthAssignments :: NFEndp -> Map Name (NFType, NFEndp) -> [Map Name (NFType, NFEndp)] truthAssignments :: NFEndp -> Map Name (NFType, NFEndp) -> [Map Name (NFType, NFEndp)]
truthAssignments VI0 m = []
truthAssignments VI0 _ = []
truthAssignments VI1 m = pure m truthAssignments VI1 m = pure m
truthAssignments (VIOr x y) m = truthAssignments x m ++ truthAssignments y m truthAssignments (VIOr x y) m = truthAssignments x m ++ truthAssignments y m
truthAssignments (VIAnd x y) m = truthAssignments x =<< truthAssignments y m truthAssignments (VIAnd x y) m = truthAssignments x =<< truthAssignments y m


+ 43
- 18
src/Elab/Monad.hs View File

@ -12,11 +12,11 @@ import qualified Data.Map.Strict as Map
import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Text (Text) import Data.Text (Text)
import Data.Set (Set)
import Data.Typeable import Data.Typeable
import qualified Presyntax.Presyntax as P import qualified Presyntax.Presyntax as P
import Syntax.Pretty (getNameText)
import Syntax import Syntax
data ElabEnv = data ElabEnv =
@ -28,6 +28,7 @@ data ElabEnv =
, currentSpan :: Maybe (P.Posn, P.Posn) , currentSpan :: Maybe (P.Posn, P.Posn)
, whereBound :: Map Name (P.Posn, P.Posn) , whereBound :: Map Name (P.Posn, P.Posn)
, definedNames :: Set Name
} }
newtype ElabM a = ElabM { runElab :: ElabEnv -> IO a } newtype ElabM a = ElabM { runElab :: ElabEnv -> IO a }
@ -35,25 +36,45 @@ newtype ElabM a = ElabM { runElab :: ElabEnv -> IO a }
via ReaderT ElabEnv IO via ReaderT ElabEnv IO
emptyEnv :: ElabEnv emptyEnv :: ElabEnv
emptyEnv = ElabEnv mempty mempty 0 (const (pure ())) Nothing mempty
emptyEnv = ElabEnv mempty mempty 0 (const (pure ())) Nothing mempty 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)
, whereBound = maybe (whereBound x) (flip (Map.insert nm) (whereBound x)) (currentSpan x)
}
assume :: Name -> Value -> (Name -> ElabM a) -> ElabM a
assume nm ty k = defineInternal nm ty VVar k
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)
}
define :: Name -> Value -> Value -> (Name -> ElabM a) -> ElabM a
define nm vty val = defineInternal nm vty (const val)
assumes :: [Name] -> Value -> ([Name] -> ElabM a) -> ElabM a
assumes nms ty k = do
let
go acc [] k = k acc
go acc (x:xs) k = assume x ty $ \n -> go (n:acc) xs k
in go [] nms k
define :: Name -> Value -> Value -> ElabM a -> ElabM a
define nm ty vl = local go where
go x = x { getEnv = Map.insert nm (ty, vl) (getEnv x), nameMap = Map.insert (getNameText nm) nm (nameMap x) }
defineInternal :: Name -> Value -> (Name -> Value) -> (Name -> ElabM a) -> ElabM a
defineInternal nm vty val k =
do
env <- ask
let (env', name') = go env
local (const env') (k name')
where
go x =
let
nm' = case Map.lookup (getNameText nm) (nameMap x) of
Just name -> incName nm name
Nothing -> nm
in ( x { getEnv = Map.insert nm' (vty, val nm') (getEnv x)
, nameMap = Map.insert (getNameText nm) nm' (nameMap x)
, whereBound = maybe (whereBound x) (flip (Map.insert nm') (whereBound x)) (currentSpan x)
}
, nm')
redefine :: Name -> Value -> Value -> ElabM a -> ElabM a
redefine nm vty val = local go where
go x = x { getEnv = Map.insert nm (vty, val) (getEnv x)
, nameMap = Map.insert (getNameText nm) nm (nameMap x)
, whereBound = maybe (whereBound x) (flip (Map.insert nm) (whereBound x)) (currentSpan x)
}
getValue :: Name -> ElabM Value getValue :: Name -> ElabM Value
getValue nm = do getValue nm = do
@ -74,7 +95,7 @@ getNameFor x = do
vl <- asks (Map.lookup x . nameMap) vl <- asks (Map.lookup x . nameMap)
case vl of case vl of
Just v -> pure v Just v -> pure v
Nothing -> liftIO . throwIO $ NotInScope (Bound x)
Nothing -> liftIO . throwIO $ NotInScope (Bound x 0)
switch :: ElabM a -> ElabM a switch :: ElabM a -> ElabM a
switch k = switch k =
@ -135,3 +156,7 @@ tryElab k = do
throwElab :: Exception e => e -> ElabM a throwElab :: Exception e => e -> ElabM a
throwElab = liftIO . throwIO throwElab = liftIO . throwIO
incName :: Name -> Name -> Name
incName (Bound x _) n = Bound x (getNameNum n + 1)
incName (Defined x k) n = Defined x (getNameNum n + 1)

+ 168
- 26
src/Elab/WiredIn.hs View File

@ -6,16 +6,22 @@
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Elab.WiredIn where module Elab.WiredIn where
import Syntax
import Control.Exception
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map.Strict as Map
import Control.Exception
import Data.Typeable import Data.Typeable
import qualified Presyntax.Presyntax as P
import Elab.Eval import Elab.Eval
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Presyntax.Presyntax as P
import Syntax
import System.IO.Unsafe
wiType :: WiredIn -> NFType wiType :: WiredIn -> NFType
wiType WiType = VType wiType WiType = VType
@ -28,7 +34,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
wiType WiPathP = dprod (VI ~> VType) \a -> a @@ VI0 ~> a @@ VI1 ~> VType
wiType WiIsOne = VI ~> VTypeω wiType WiIsOne = VI ~> VTypeω
wiType WiItIsOne = VIsOne VI1 wiType WiItIsOne = VIsOne VI1
@ -39,10 +45,17 @@ wiType WiPartial = VI ~> VType ~> VTypeω
wiType WiPartialP = dprod VI \x -> VPartial x VType ~> VTypeω wiType WiPartialP = dprod VI \x -> VPartial x VType ~> VTypeω
wiType WiSub = dprod VType \a -> dprod VI \phi -> VPartial phi a ~> VTypeω wiType WiSub = dprod VType \a -> dprod VI \phi -> VPartial phi a ~> VTypeω
wiType WiInS = forAll VType \a -> forAll VI \phi -> dprod a \u -> VSub a phi (VLam P.Ex (Closure "x" (const u)))
wiType WiInS = forAll VType \a -> forAll VI \phi -> dprod a \u -> VSub a phi (fun (const u))
wiType WiOutS = forAll VType \a -> forAll VI \phi -> forAll (VPartial phi a) \u -> VSub a phi u ~> a wiType WiOutS = forAll VType \a -> forAll VI \phi -> forAll (VPartial phi a) \u -> VSub a phi u ~> a
wiType WiComp = dprod (VI ~> VType) \a -> forAll VI \phi -> dprod (dprod VI \i -> VPartial phi (a @@ i)) \u -> VSub (a @@ VI0) phi (u @@ VI0) ~> a @@ VI1
wiType WiComp = dprod' "A" (VI ~> VType) \a -> forAll VI \phi -> dprod (dprod VI \i -> VPartial phi (a @@ i)) \u -> VSub (a @@ VI0) phi (u @@ VI0) ~> a @@ VI1
-- (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type
wiType WiGlue = dprod' "A" VType \a -> forAll' "phi" VI \phi -> dprod' "T" (VPartial phi VType) \t -> VPartialP phi (fun \o -> equiv (t @@ o) a) ~> VType
-- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> e o (t o)) -> Glue A phi T e
wiType WiGlueElem = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T" (VPartial phi VType) \ty -> forAll' "e" (VPartialP phi (fun \o -> equiv (ty @@ o) a)) \eqv ->
dprod' "t" (VPartialP phi ty) \t -> VSub a phi (fun \o -> vProj1 (eqv @@ o) @@ (t @@ o)) ~> VGlueTy a phi ty eqv
-- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A
wiType WiUnglue = forAll' "A" VType \a -> forAll' "phi" VI \phi -> forAll' "T" (VPartial phi VType) \ty -> forAll' "e" (VPartialP phi (fun \o -> equiv (ty @@ o) a)) \e -> VGlueTy a phi ty e ~> a
wiValue :: WiredIn -> Value wiValue :: WiredIn -> Value
wiValue WiType = VType wiValue WiType = VType
@ -67,24 +80,41 @@ wiValue WiPartialP = fun \phi -> fun \r -> VPartialP phi r
wiValue WiSub = fun \a -> fun \phi -> fun \u -> VSub a phi u wiValue WiSub = fun \a -> fun \phi -> fun \u -> VSub a phi u
wiValue WiInS = forallI \a -> forallI \phi -> fun \u -> VInc a phi u wiValue WiInS = forallI \a -> forallI \phi -> fun \u -> VInc a phi u
wiValue WiOutS = forallI \a -> forallI \phi -> forallI \u -> fun \x -> outS a phi u x wiValue WiOutS = forallI \a -> forallI \phi -> forallI \u -> fun \x -> outS a phi u x
-- wiValue WiComp = forAll (VI ~> VType) \a -> forAll VI \phi -> dprod (dprod VI \i -> VPartial phi (a @@ i)) \u -> VSub (a @@ VI0) phi (u @@ VI0) ~> a @@ VI1
wiValue WiComp = fun \a -> forallI \phi -> fun \u -> fun \x -> comp a phi u x wiValue WiComp = fun \a -> forallI \phi -> fun \u -> fun \x -> comp a phi u x
wiValue WiGlue = fun \a -> forallI \phi -> fun \t -> fun \e -> glueType a phi t e
wiValue WiGlueElem = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> fun \y -> glueElem a phi ty eqv x y
wiValue WiUnglue = forallI \a -> forallI \phi -> forallI \ty -> forallI \eqv -> fun \x -> unglue a phi ty eqv x
(~>) :: Value -> Value -> Value (~>) :: Value -> Value -> Value
a ~> b = VPi P.Ex a (Closure "_" (const b))
a ~> b = VPi P.Ex a (Closure (Bound "_" 0) (const b))
infixr 7 ~> infixr 7 ~>
fun :: (Value -> Value) -> Value
fun k = VLam P.Ex $ Closure "x" (k . force)
fun, line :: (Value -> Value) -> Value
fun k = VLam P.Ex $ Closure (Bound "x" 0) (k . force)
line k = VLam P.Ex $ Closure (Bound "i" 0) (k . force)
forallI :: (Value -> Value) -> Value forallI :: (Value -> Value) -> Value
forallI k = VLam P.Im $ Closure "x" (k . force)
forallI k = VLam P.Im $ Closure (Bound "x" 0) (k . force)
dprod' :: String -> Value -> (Value -> Value) -> Value
dprod' t a b = VPi P.Ex a (Closure (Bound (T.pack t) 0) b)
dprod :: Value -> (Value -> Value) -> Value dprod :: Value -> (Value -> Value) -> Value
dprod a b = VPi P.Ex a (Closure "x" b)
dprod = dprod' "x"
exists' :: String -> Value -> (Value -> Value) -> Value
exists' s a b = VSigma a (Closure (Bound (T.pack s) 0) b)
exists :: Value -> (Value -> Value) -> Value
exists = exists' "x"
forAll' :: String -> Value -> (Value -> Value) -> Value
forAll' n a b = VPi P.Im a (Closure (Bound (T.pack n) 0) b)
forAll :: Value -> (Value -> Value) -> Value forAll :: Value -> (Value -> Value) -> Value
forAll a b = VPi P.Im a (Closure "x" b)
forAll = forAll' "x"
wiredInNames :: Map Text WiredIn wiredInNames :: Map Text WiredIn
wiredInNames = Map.fromList wiredInNames = Map.fromList
@ -97,7 +127,7 @@ wiredInNames = Map.fromList
, ("ior", WiIOr) , ("ior", WiIOr)
, ("inot", WiINot) , ("inot", WiINot)
, ("PathP", WiPathP) , ("PathP", WiPathP)
, ("IsOne", WiIsOne) , ("IsOne", WiIsOne)
, ("itIs1", WiItIsOne) , ("itIs1", WiItIsOne)
, ("isOneL", WiIsOne1) , ("isOneL", WiIsOne1)
@ -110,6 +140,9 @@ wiredInNames = Map.fromList
, ("outS", WiOutS) , ("outS", WiOutS)
, ("comp", WiComp) , ("comp", WiComp)
, ("Glue", WiGlue)
, ("glue", WiGlueElem)
, ("unglue", WiUnglue)
] ]
newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text } newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
@ -157,20 +190,24 @@ ielim _line _left _right fn i =
case force fn of case force fn of
VLine _ _ _ fun -> fun @@ i VLine _ _ _ fun -> fun @@ i
VNe n sp -> VNe n (sp Seq.:|> PIElim _line _left _right i) VNe n sp -> VNe n (sp Seq.:|> PIElim _line _left _right i)
VSystem (Map.toList -> []) -> VSystem (Map.fromList [])
_ -> error $ "can't ielim " ++ show fn _ -> error $ "can't ielim " ++ show fn
outS :: NFSort -> NFEndp -> Value -> Value -> Value outS :: NFSort -> NFEndp -> Value -> Value -> Value
outS _ (force -> VI1) u _ = u @@ VItIsOne outS _ (force -> VI1) u _ = u @@ VItIsOne
outS _ _phi _ (VInc _ _ x) = x
outS a phi u (VNe x sp) = VNe x (sp Seq.:|> POuc a phi u)
outS _ _ _ v = error $ "can't outS " ++ show v
outS _ _phi _ (VInc _ _ x) = x
outS _ VI0 _ x = x
outS a phi u (VNe x sp) = VNe x (sp Seq.:|> POuc a phi u)
outS _ _ _ v = error $ "can't outS " ++ show v
-- Composition -- Composition
comp :: NFLine -> NFEndp -> Value -> Value -> Value comp :: NFLine -> NFEndp -> Value -> Value -> Value
comp _ VI1 u _ = u @@ VI1 @@ VItIsOne comp _ VI1 u _ = u @@ VI1 @@ VItIsOne
comp a phi u (VInc _ _ a0) =
case a @@ VNe (HVar (Bound (T.pack "x"))) Seq.empty of
VPi{} ->
comp a psi@phi u (outS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
case force $ a @@ VVar (Bound (T.pack "neutral composition") 0) of
VPi{} ->
let let
plic i = let VPi p _ _ = a @@ i in p plic i = let VPi p _ _ = a @@ i in p
dom i = let VPi _ d _ = a @@ i in d dom i = let VPi _ d _ = a @@ i in d
@ -178,7 +215,7 @@ comp a phi u (VInc _ _ a0) =
y' i y = fill (fun (dom . inot)) VI0 (fun \_ -> fun \_ -> VSystem mempty) (VInc (dom VI0) phi y) i y' i y = fill (fun (dom . inot)) VI0 (fun \_ -> fun \_ -> VSystem mempty) (VInc (dom VI0) phi y) i
ybar i y = y' (inot i) y ybar i y = y' (inot i) y
in VLam (plic VI1) . Closure "x" $ \arg ->
in VLam (plic VI1) . Closure (Bound "x" 0) $ \arg ->
comp (fun \i -> rng i (ybar i arg)) comp (fun \i -> rng i (ybar i arg))
phi phi
(system \i isone -> vApp (plic i) (u @@ i @@ isone) (ybar i arg)) (system \i isone -> vApp (plic i) (u @@ i @@ isone) (ybar i arg))
@ -193,6 +230,7 @@ comp a phi u (VInc _ _ a0) =
c2 = comp (fun (($ w VI1) . rng)) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (rng VI0 (dom VI0)) phi (vProj2 a0)) c2 = comp (fun (($ w VI1) . rng)) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (rng VI0 (dom VI0)) phi (vProj2 a0))
in in
VPair c1 c2 VPair c1 c2
VPath{} -> VPath{} ->
let let
a' i = let VPath a _ _ = a @@ i in a a' i = let VPath a _ _ = a @@ i in a
@ -207,8 +245,45 @@ comp a phi u (VInc _ _ a0) =
, (inot j, u' i)])) , (inot j, u' i)]))
(VInc (a' VI0 @@ VI0 @@ j) phi (ielim (a' VI0 @@ VI0) (u' VI0) (v' VI0) a0 j)) (VInc (a' VI0 @@ VI0 @@ j) phi (ielim (a' VI0 @@ VI0) (u' VI0) (v' VI0) a0 j))
VGlueTy{} ->
let
b = u
b0 = a0
fam = a
in
let
base i = let VGlueTy base _ _ _ = fam @@ i in base
phi i = let VGlueTy _ phi _ _ = fam @@ i in phi
types i = let VGlueTy _ _ types _ = fam @@ i in types
equivs i = let VGlueTy _ _ _ equivs = fam @@ i in equivs
a i = fun \u -> unglue (base i) (phi i) (types i @@ u) (equivs i @@ u) (b @@ i @@ u)
a0 = unglue (base VI0) (phi VI0) (types VI0) (equivs VI0) b0
del = faceForall phi
a1' = comp (line base) psi (line a) (VInc undefined undefined a0)
t1' = comp (line types) psi (line (b @@)) (VInc undefined undefined b0)
(omega_st, omega_t, omega_rep) = pres types base equivs psi (b @@) b0
omega = outS omega_t psi omega_rep omega_st
(t1alpha_st, t1a_t, t1a_rep) = opEquiv (base VI1) (types VI1 @@ VItIsOne) (equivs VI1 @@ VItIsOne) (del `ior` psi) (fun ts) (fun ps) a1'
t1alpha = outS t1a_t (del `ior` psi) t1a_rep t1alpha_st
(t1, alpha) = (vProj1 t1alpha, vProj2 t1alpha)
ts isone = mkVSystem . Map.fromList $ [(del, t1'), (psi, (b @@ VI1 @@ isone))]
ps _isone = mkVSystem . Map.fromList $ [(del, omega), (psi, VLine (line (const (base VI1))) a1' a1' (fun (const a1')))]
a1 = comp
(fun (const (base VI1 @@ VItIsOne)))
(phi VI1 `ior` psi)
(system \j _u -> mkVSystem (Map.fromList [ (phi VI1, ielim (base VI1) a1' (vProj1 (equivs VI1 @@ VItIsOne)) alpha j)
, (psi, a VI1)]))
a1'
b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1
in b1
_ -> VComp a phi u a0 _ -> VComp a phi u a0
comp a phi u a0 = VComp a phi u a0
system :: (Value -> Value -> Value) -> Value system :: (Value -> Value -> Value) -> Value
system k = fun \i -> fun \isone -> k i isone system k = fun \i -> fun \isone -> k i isone
@ -219,4 +294,71 @@ fill a phi u a0 j =
(phi `ior` inot j) (phi `ior` inot j)
(fun \i -> fun \isone -> mkVSystem (Map.fromList [ (phi, u @@ (i `iand` j) @@ isone) (fun \i -> fun \isone -> mkVSystem (Map.fromList [ (phi, u @@ (i `iand` j) @@ isone)
, (inot j, a0)])) , (inot j, a0)]))
a0
a0
glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value
glueType a phi tys eqvs = VGlueTy a phi tys eqvs
glueElem :: NFSort -> NFEndp -> NFPartial -> NFPartial -> NFPartial -> Value -> Value
glueElem _a VI1 _tys _eqvs t _vl = t @@ VItIsOne
glueElem a phi tys eqvs t vl = VGlue a phi tys eqvs t vl
unglue :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value -> Value
unglue _a VI1 _tys eqvs x = vProj1 (eqvs @@ VItIsOne) @@ x
unglue _a _phi _tys _eqvs (VGlue _ _ _ _ _ vl) = vl
unglue _ _ _ _ (VSystem (Map.toList -> [])) = VSystem (Map.fromList [])
unglue a phi tys eqvs vl = VUnglue a phi tys eqvs vl
-- Definition of equivalences
faceForall :: (NFEndp -> NFEndp) -> Value
faceForall phi = T.length (getNameText name) `seq` go (phi (VVar name)) where
{-# NOINLINE name #-}
name = unsafePerformIO newName
go x@(VVar n)
| n == name = VI0
| otherwise = x
go x@(VINot (VVar n))
| n == name = VI0
| otherwise = x
go (VIAnd x y) = iand (go x) (go y)
go (VIOr x y) = ior (go x) (go y)
go (VINot x) = inot (go x)
go vl = vl
isContr :: Value -> Value
isContr a = exists' "x" a \x -> dprod' "y" a \y -> VPath (line (const a)) x y
fiber :: NFSort -> NFSort -> Value -> Value -> Value
fiber a b f y = exists' "x" a \x -> VPath (line (const b)) (f @@ x) y
isEquiv :: NFSort -> NFSort -> Value -> Value
isEquiv a b f = dprod' "y" b \y -> isContr (fiber a b f y)
equiv :: NFSort -> NFSort -> Value
equiv a b = exists' "f" (a ~> b) \f -> isEquiv a b f
pres :: (NFEndp -> NFSort) -> (NFEndp -> NFSort) -> (NFEndp -> Value) -> NFEndp -> (NFEndp -> Value) -> Value -> (Value, NFSort, Value)
pres tyT tyA f phi t t0 = (VInc pathT phi (VLine (tyA VI1) c1 c2 (line path)), pathT, fun $ \u -> VLine (fun (const (tyA VI1))) c1 c2 (fun (const (f VI1 @@ (t VI1 @@ u))))) where
pathT = VPath (fun (const (tyA VI1))) c1 c2
c1 = comp (fun tyA) phi (system \i u -> f i @@ (t i @@ u)) (VInc (tyA VI0) phi (f VI0 @@ t0))
c2 = f VI1 @@ comp (fun tyT) phi (system \i u -> t i @@ u) t0
a0 = f VI0 @@ t0
v = fill (fun tyT) phi (system \i u -> t i @@ u) t0
path j = comp (fun tyA) (phi `ior` j) (system \i _ -> f i @@ (v i)) a0
opEquiv :: Value -> Value -> Value -> NFEndp -> Value -> Value -> Value -> (Value, NFSort, Value)
opEquiv aT tT f phi t p a = (VInc ty phi v, ty, fun \u -> VPair (t @@ u) (p @@ u)) where
fn = vProj1 f
ty = exists' "f" tT \x -> VPath (line (const aT)) a (fn @@ x)
v = contr ty (vProj2 f @@ a) phi (\u -> VPair (t @@ u) (p @@ u))
contr :: Value -> Value -> NFEndp -> (Value -> Value) -> Value
contr a aC phi u =
comp (line (const a))
phi
(system \i is1 -> ielim (line (const a)) a (vProj1 (u is1)) (vProj2 (u is1)) i)
(vProj1 aC)

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

@ -10,4 +10,8 @@ inot :: NFEndp -> NFEndp
ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value
outS :: NFSort -> NFEndp -> Value -> Value -> Value outS :: NFSort -> NFEndp -> Value -> Value -> Value
comp :: NFLine -> NFEndp -> Value -> Value -> Value
comp :: NFLine -> NFEndp -> Value -> Value -> Value
glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value
glueElem :: NFSort -> NFEndp -> NFPartial -> NFPartial -> NFPartial -> Value -> Value
unglue :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value -> Value

+ 12
- 9
src/Main.hs View File

@ -3,7 +3,10 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Main where module Main where
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Exception import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as Bsl import qualified Data.ByteString.Lazy as Bsl
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
@ -14,23 +17,23 @@ import Data.Text ( Text )
import Data.Foldable import Data.Foldable
import Elab.Monad hiding (switch) import Elab.Monad hiding (switch)
import Elab.WiredIn
import Elab.Eval import Elab.Eval
import Elab import Elab
import Options.Applicative
import Presyntax.Presyntax (Posn(Posn)) import Presyntax.Presyntax (Posn(Posn))
import Presyntax.Parser import Presyntax.Parser
import Presyntax.Lexer import Presyntax.Lexer
import System.Exit
import Prettyprinter
import Syntax.Pretty import Syntax.Pretty
import Elab.WiredIn
import Options.Applicative
import Control.Monad
import Syntax import Syntax
import Prettyprinter
import Control.Monad.IO.Class
import Control.Monad.Reader
import System.Console.Haskeline import System.Console.Haskeline
import System.Exit
main :: IO () main :: IO ()
main = do main = do
@ -80,7 +83,7 @@ checkFiles files = runElab (go files ask) emptyEnv where
dumpEnv :: Map.Map Name (NFType, Value) -> IO () dumpEnv :: Map.Map Name (NFType, Value) -> IO ()
dumpEnv env = for_ (Map.toList env) $ \(name, (nft, _)) -> dumpEnv env = for_ (Map.toList env) $ \(name, (nft, _)) ->
T.putStrLn $ render (pretty name <+> colon <+> prettyTm (quote (zonk nft)))
T.putStrLn $ render (pretty name <+> align (nest (negate 1) (colon <+> prettyTm (quote (zonk nft)))))
parser :: ParserInfo Opts parser :: ParserInfo Opts
parser = info (subparser (load <> check) <|> pure Repl <**> helper) (header "cubical - a cubical programming language") parser = info (subparser (load <> check) <|> pure Repl <**> helper) (header "cubical - a cubical programming language")
@ -152,4 +155,4 @@ squiggleUnder (Posn l c) (Posn l' c') file
squiggle = T.replicate c " " <> T.pack "\x1b[1;31m" <> T.replicate (c' - c) "~" <> T.pack "\x1b[0m" squiggle = T.replicate c " " <> T.pack "\x1b[1;31m" <> T.replicate (c' - c) "~" <> T.pack "\x1b[0m"
in T.unlines [ padding, line, padding <> squiggle ] in T.unlines [ padding, line, padding <> squiggle ]
| otherwise = T.pack (show (Posn l c, Posn l' c'))
| otherwise = T.pack (show (Posn l c, Posn l' c'))

+ 4
- 3
src/Presyntax/Presyntax.hs View File

@ -1,11 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Presyntax.Presyntax where module Presyntax.Presyntax where
import Data.Text (Text) import Data.Text (Text)
import Data.Data
data Plicity data Plicity
= Im | Ex = Im | Ex
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord, Data)
data Expr data Expr
= Var Text = Var Text
@ -53,4 +54,4 @@ data Posn
= Posn { posnLine :: {-# UNPACK #-} !Int = Posn { posnLine :: {-# UNPACK #-} !Int
, posnColm :: {-# UNPACK #-} !Int , posnColm :: {-# UNPACK #-} !Int
} }
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord)

+ 2
- 2
src/Presyntax/Tokens.hs View File

@ -1,7 +1,7 @@
module Presyntax.Tokens where module Presyntax.Tokens where
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text (Text)
data TokenClass data TokenClass
= TokVar Text = TokVar Text
@ -75,4 +75,4 @@ data Token
, tokStartLine :: !Int , tokStartLine :: !Int
, tokStartCol :: !Int , tokStartCol :: !Int
} }
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord)

+ 54
- 29
src/Syntax.hs View File

@ -1,18 +1,20 @@
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Syntax where module Syntax where
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Map.Strict (Map)
import Data.Sequence (Seq)
import Data.Function (on) import Data.Function (on)
import Data.IORef (IORef)
import Data.Text (Text) import Data.Text (Text)
import Data.Set (Set)
import Data.Data
import Presyntax.Presyntax (Plicity(..)) import Presyntax.Presyntax (Plicity(..))
import qualified Data.Text as T
import Data.IORef (IORef)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
data WiredIn data WiredIn
= WiType = WiType
@ -40,18 +42,22 @@ data WiredIn
| WiComp -- {A : I -> Type} {phi : I} | WiComp -- {A : I -> Type} {phi : I}
-- -> ((i : I) -> Partial phi (A i) -- -> ((i : I) -> Partial phi (A i)
-- -> (A i0)[phi -> u i0] -> (A i1)[phi -> u i1] -- -> (A i0)[phi -> u i0] -> (A i1)[phi -> u i1]
| WiGlue -- (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type
| WiGlueElem -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> e o (t o)) -> Glue A phi T e
| WiUnglue -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data Term data Term
= Ref Name = Ref Name
| App Plicity Term Term | App Plicity Term Term
| Lam Plicity Text Term
| Pi Plicity Text Term Term
| Lam Plicity Name Term
| Pi Plicity Name Term Term
| Meta MV | Meta MV
| Type | Type
| Typeω | Typeω
| Sigma Text Term Term
| Sigma Name Term Term
| Pair Term Term | Pair Term Term
| Proj1 Term | Proj1 Term
| Proj2 Term | Proj2 Term
@ -85,7 +91,11 @@ data Term
| Ouc Term Term Term Term | Ouc Term Term Term Term
| Comp Term Term Term Term | Comp Term Term Term Term
deriving (Eq, Show, Ord)
| GlueTy Term Term Term Term
| Glue Term Term Term Term Term Term
| Unglue Term Term Term Term Term
deriving (Eq, Show, Ord, Data)
data MV = data MV =
MV { mvName :: Text MV { mvName :: Text
@ -99,15 +109,22 @@ instance Ord MV where
instance Show MV where instance Show MV where
show = ('?':) . T.unpack . mvName show = ('?':) . T.unpack . mvName
instance Data MV where
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "MV"
data Name data Name
= Bound Text
| Defined Text
deriving (Eq, Show, Ord)
= Bound {getNameText :: Text, getNameNum :: !Int}
| Defined {getNameText :: Text, getNameNum :: !Int}
deriving (Eq, Show, Ord, Data)
type NFType = Value type NFType = Value
type NFEndp = Value type NFEndp = Value
type NFLine = Value type NFLine = Value
type NFSort = Value type NFSort = Value
type NFPartial = Value
data Value data Value
= VNe Head (Seq Projection) = VNe Head (Seq Projection)
@ -140,12 +157,16 @@ data Value
| VInc NFSort NFEndp Value | VInc NFSort NFEndp Value
| VComp NFSort NFEndp Value Value | VComp NFSort NFEndp Value Value
| VGlueTy NFSort NFEndp NFPartial NFPartial
| VGlue NFSort NFEndp NFPartial NFPartial NFPartial Value
| VUnglue NFSort NFEndp NFPartial NFPartial Value
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
pattern VVar :: Name -> Value pattern VVar :: Name -> Value
pattern VVar x = VNe (HVar x) Seq.Empty pattern VVar x = VNe (HVar x) Seq.Empty
quoteWith :: Set Text -> Value -> Term
quoteWith :: Set Name -> Value -> Term
quoteWith names (VNe h sp) = foldl goSpine (goHead h) 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
@ -158,15 +179,15 @@ quoteWith names (VNe h sp) = foldl goSpine (goHead h) sp where
quoteWith names (VLam p (Closure n k)) = quoteWith names (VLam p (Closure n k)) =
let n' = refresh Nothing names n let n' = refresh Nothing names n
in Lam p n' (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))
in Lam p n' (quoteWith (Set.insert n' names) (k (VVar n')))
quoteWith names (VPi p d (Closure n k)) = quoteWith names (VPi p d (Closure n k)) =
let n' = refresh (Just d) names n let n' = refresh (Just d) names n
in Pi p n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))
in Pi p n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar n')))
quoteWith names (VSigma d (Closure n k)) = quoteWith names (VSigma d (Closure n k)) =
let n' = refresh (Just d) names n let n' = refresh (Just d) names n
in Sigma n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))
in Sigma n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar n')))
quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b) quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b)
quoteWith _ VType = Type quoteWith _ VType = Type
@ -194,32 +215,36 @@ quoteWith names (VSub a b c) = Sub (quoteWith names a) (quoteWith names b) (quot
quoteWith names (VInc a b c) = Inc (quoteWith names a) (quoteWith names b) (quoteWith names c) quoteWith names (VInc a b c) = Inc (quoteWith names a) (quoteWith names b) (quoteWith names c)
quoteWith names (VComp a phi u a0) = Comp (quoteWith names a) (quoteWith names phi) (quoteWith names u) (quoteWith names a0) quoteWith names (VComp a phi u a0) = Comp (quoteWith names a) (quoteWith names phi) (quoteWith names u) (quoteWith names a0)
refresh :: Maybe Value -> Set Text -> Text -> Text
refresh (Just VI) n _ = refresh Nothing n (T.pack "phi")
quoteWith names (VGlueTy a phi t e) = GlueTy (quoteWith names a) (quoteWith names phi) (quoteWith names t) (quoteWith names e)
quoteWith names (VGlue a phi ty e t x) = Glue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names t) (quoteWith names x)
quoteWith names (VUnglue a phi ty e x) = Unglue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names x)
refresh :: Maybe Value -> Set Name -> Name -> Name
refresh (Just VI) n _ = refresh Nothing n (Bound (T.pack "phi") 0)
refresh x s n refresh x s n
| T.singleton '_' == n = n
| T.singleton '_' == getNameText n = n
| n `Set.notMember` s = n | n `Set.notMember` s = n
| otherwise = refresh x s (n <> T.singleton '\'')
| otherwise = refresh x s (Bound (getNameText n <> T.singleton '\'') 0)
quote :: Value -> Term quote :: Value -> Term
quote = quoteWith mempty quote = quoteWith mempty
data Closure data Closure
= Closure = Closure
{ clArgName :: Text
{ clArgName :: Name
, clCont :: Value -> Value , clCont :: Value -> Value
} }
instance Show Closure where instance Show Closure where
show (Closure n c) = "Closure \\" ++ show n ++ " -> " ++ show (c (VVar (Bound n)))
show (Closure n c) = "Closure \\" ++ show n ++ " -> " ++ show (c (VVar n))
instance Eq Closure where instance Eq Closure where
Closure _ k == Closure _ k' = Closure _ k == Closure _ k' =
k (VVar (Bound (T.pack "_"))) == k' (VVar (Bound (T.pack "_")))
k (VVar (Bound (T.pack "_") 0)) == k' (VVar (Bound (T.pack "_") 0))
instance Ord Closure where instance Ord Closure where
Closure _ k <= Closure _ k' = Closure _ k <= Closure _ k' =
k (VVar (Bound (T.pack "_"))) <= k' (VVar (Bound (T.pack "_")))
k (VVar (Bound (T.pack "_") 0)) <= k' (VVar (Bound (T.pack "_") 0))
data Head data Head
= HVar Name = HVar Name
@ -231,5 +256,5 @@ data Projection
| PIElim Value Value Value NFEndp | PIElim Value Value Value NFEndp
| PProj1 | PProj1
| PProj2 | PProj2
| POuc NFSort NFEndp Value
deriving (Eq, Show, Ord)
| POuc NFSort NFEndp Value
deriving (Eq, Show, Ord)

+ 63
- 55
src/Syntax/Pretty.hs View File

@ -4,9 +4,12 @@ module Syntax.Pretty where
import Control.Arrow (Arrow(first)) import Control.Arrow (Arrow(first))
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy as L
import qualified Data.Text as T import qualified Data.Text as T
import Data.Map.Strict (Map)
import Data.Text (Text) import Data.Text (Text)
import Data.Generics
import Presyntax.Presyntax (Plicity(..)) import Presyntax.Presyntax (Plicity(..))
@ -14,72 +17,81 @@ import Prettyprinter.Render.Terminal
import Prettyprinter import Prettyprinter
import Syntax import Syntax
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
instance Pretty Name where instance Pretty Name where
pretty (Bound x) = pretty x
pretty (Defined x) = pretty x
pretty (Bound x _) = pretty x
pretty (Defined x _) = pretty x
prettyTm :: Term -> Doc AnsiStyle prettyTm :: Term -> Doc AnsiStyle
prettyTm (Ref v) =
case T.uncons (getNameText v) of
Just ('.', w) -> keyword (pretty w)
_ -> pretty v
prettyTm = prettyTm . everywhere (mkT beautify) where
prettyTm (Ref v) =
case T.uncons (getNameText v) of
Just ('.', w) -> keyword (pretty w)
_ -> pretty v
prettyTm (App Im f x) = parenFun f <+> braces (prettyTm x)
prettyTm (App Ex f x) = parenFun f <+> parenArg x
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 (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 (PathIntro _ _ _ (Lam p x y)) = first ((p, x):) (unwindLam y)
unwindLam t = ([], t)
prettyTm l@(Lam _ _ _) = pretty '\\' <> hsep (map prettyArgList al) <+> pretty "->" <+> prettyTm bod where
unwindLam (Lam p x y) = first ((p, x):) (unwindLam y)
unwindLam (PathIntro _ _ _ (Lam p x y)) = first ((p, x):) (unwindLam y)
unwindLam t = ([], t)
(al, bod) = unwindLam l
(al, bod) = unwindLam l
prettyArgList (Ex, v) = pretty v
prettyArgList (Im, v) = braces (pretty v)
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 (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 (Pi Ex (T.unpack . getNameText -> "_") d r) = prettyDom d <+> pretty "->" <+> prettyTm r
prettyTm (Pi Im v d r) = group (braces (pretty v <+> colon <+> prettyTm d)) <> softline <> pretty "->" <+> prettyTm r
prettyTm (Pi Ex v d r) = group (parens (pretty v <+> colon <+> prettyTm d)) <> softline <> 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 (Sigma (T.unpack . getNameText -> "_") 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) = parens $ prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr x y) = parens $ prettyTm x <+> operator (pretty "||") <+> prettyTm y
prettyTm (INot x) = operator (pretty '~') <> prettyTm x
prettyTm (IAnd x y) = parens $ prettyTm x <+> operator (pretty "&&") <+> prettyTm y
prettyTm (IOr x y) = parens $ prettyTm x <+> operator (pretty "||") <+> prettyTm y
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
prettyTm (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where
go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t
prettyTm (IsOne phi) = prettyTm (App Ex (Ref (Bound (T.pack ".IsOne"))) phi)
prettyTm ItIsOne = keyword (pretty "1=1")
prettyTm (IsOne1 phi) = prettyTm (App Ex (Ref (Bound (T.pack ".isOne1"))) phi)
prettyTm (IsOne2 phi) = prettyTm (App Ex (Ref (Bound (T.pack ".isOne2"))) phi)
prettyTm x = error (show x)
prettyTm (Partial phi a) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".Partial"))) [phi, a]
prettyTm (PartialP phi a) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".PartialP"))) [phi, a]
prettyTm (Comp a phi u a0) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".comp"))) [a, phi, u, a0]
prettyTm (Sub a phi u) = prettyTm a <> brackets (prettyTm phi <+> operator (pretty "->") <+> prettyTm u)
prettyTm (Inc _ _ u) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".inS"))) [u]
prettyTm (Ouc _ _ _ u) = prettyTm $ foldl (App Ex) (Ref (Bound (T.pack ".outS"))) [u]
beautify (PathP l x y) = toFun "PathP" [l, x, y]
beautify (IElim _ _ _ f i) = App Ex f i
beautify (PathIntro _ _ _ f) = f
prettyTm (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where
go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t
beautify (IsOne phi) = toFun "IsOne" [phi]
beautify ItIsOne = Ref (Bound (T.pack ".1=1") 0)
beautify (IsOne1 phi) = toFun "isOne1" [phi]
beautify (IsOne2 phi) = toFun "isOne2" [phi]
beautify (Partial phi a) = toFun "Partial" [phi, a]
beautify (PartialP phi a) = toFun "PartialP" [phi, a]
beautify (Comp a phi u a0) = toFun "comp" [a, phi, u, a0]
beautify (Sub a phi u) = toFun "Sub" [a, phi, u]
beautify (Inc _ _ u) = toFun "inS" [u]
beautify (Ouc _ phi u0 u) = toFun "outS" [phi, u0, u]
beautify (GlueTy a I1 _ _) = a
beautify (GlueTy a b c d) = toFun "Glue" [a,b,c,d]
beautify (Glue a b c d e f) = toFun "glue" [a,b,c,d,e,f]
beautify (Unglue a b c d e) = toFun "unglue" [a,b,c,d,e]
beautify x = x
toFun s a = foldl (App Ex) (Ref (Bound (T.pack ('.':s)) 0)) a
keyword :: Doc AnsiStyle -> Doc AnsiStyle keyword :: Doc AnsiStyle -> Doc AnsiStyle
keyword = annotate (color Magenta) keyword = annotate (color Magenta)
@ -115,15 +127,11 @@ parenFun x@PathIntro{} = parens $ prettyTm x
parenFun x = prettyTm x parenFun x = prettyTm x
render :: Doc AnsiStyle -> Text render :: Doc AnsiStyle -> Text
render = L.toStrict . renderLazy . layoutPretty defaultLayoutOptions
render = L.toStrict . renderLazy . layoutSmart defaultLayoutOptions
showValue :: Value -> String showValue :: Value -> String
showValue = L.unpack . renderLazy . layoutPretty defaultLayoutOptions . prettyTm . quote
showValue = L.unpack . renderLazy . layoutSmart defaultLayoutOptions . prettyTm . quote
showFace :: Map Head Bool -> Doc AnsiStyle showFace :: Map Head Bool -> Doc AnsiStyle
showFace = hsep . map go . Map.toList where showFace = hsep . map go . Map.toList where
go (h, b) = parens $ prettyTm (quote (VNe h mempty)) <+> operator (pretty "=") <+> pretty (if b then "i1" else "i0") go (h, b) = parens $ prettyTm (quote (VNe h mempty)) <+> operator (pretty "=") <+> pretty (if b then "i1" else "i0")
getNameText :: Name -> Text
getNameText (Bound x) = x
getNameText (Defined x) = x

Write Preview
Loading…
Cancel
Save