Implement partial elements and systems

3 years ago · 30b2984e1d
--- a/cubical.cabal
+++ b/cubical.cabal
@ -43,6 +43,7 @@ executable cubical
 , Elab.Eval
 , Elab.Monad
 , Elab.WiredIn
 , Elab.Eval.Formula

 build-tool-depends: alex:alex >= 3.2.4 && < 4.0
 , happy:happy >= 1.19.12 && < 2.0
--- a/src/Elab.hs
+++ b/src/Elab.hs
@ -1,4 +1,4 @@
 {-# LANGUAGE TupleSections, OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Elab where
@ -7,8 +7,11 @@ import Control.Monad.Reader
 import Control.Exception

 import qualified Data.Map.Strict as Map
 import Data.Traversable
 import Data.Typeable
 import Data.Foldable

 import Elab.Eval.Formula (possible)
 import Elab.WiredIn
 import Elab.Monad
 import Elab.Eval
@ -17,8 +20,9 @@ import qualified Presyntax.Presyntax as P

 import Prettyprinter

 import Syntax.Pretty
 import Syntax
 import Syntax.Pretty
 import qualified Data.Text as T

 infer :: P.Expr -> ElabM (Term, NFType)
 infer (P.Span ex a b) = withSpan a b $ infer ex
@ -40,6 +44,27 @@ infer (P.App p f x) = do
 x <- check x VI
 x_nf <- eval x
 pure (IElim (quote (fun li)) (quote le) (quote ri) (wp f) x, li x_nf)
 It'sPartial phi a w -> do
 x <- check x (VIsOne phi)
 pure (App P.Ex (w f) x, a)
 It'sPartialP phi a w -> do
 x <- check x (VIsOne phi)
 x_nf <- eval x
 pure (App P.Ex (w f) x, a @@ x_nf)

 infer (P.Bracket ex) = do
 nm <- getNameFor (T.pack "IsOne")
 ty <- getNfType nm
 porp <- isPiType P.Ex ty
 case porp of
 It'sProd d r w -> do
 t <- check ex d
 t_nf <- eval t
 pure (App P.Ex (w (Ref nm)) t, r t_nf)
 _ -> do
 d <- newMeta VType
 r <- newMeta VType
 throwElab $ NotEqual ty (VPi P.Ex d (Closure (T.pack "x") (const r)))

 infer (P.Proj1 x) = do
 (tm, ty) <- infer x
@ -71,19 +96,32 @@ check tm (VPi P.Im dom (Closure var rng)) =
 check (P.Lam p v b) ty = do
 porp <- isPiType p =<< forceIO ty
 case porp of
 It'sProd d r wp -> do
 It'sProd d r wp ->
 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)))
 Lam P.Ex v <$> check b (force (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))

 It'sPartial phi a wp ->
 assume (Bound v) (VIsOne phi) $
 wp . Lam p v <$> check b a

 It'sPartialP phi a wp ->
 assume (Bound v) (VIsOne phi) $
 wp . Lam p v <$> check b (a @@ VVar (Bound v))

 check (P.Pair a b) ty = do
 (d, r, wp) <- isSigmaType =<< forceIO ty
 a <- check a d
@ -107,11 +145,52 @@ check (P.Sigma s d r) ty = do
 r <- check r ty
 pure (Sigma s d r)

 check (P.LamSystem bs) ty = do
 (extent, dom) <- isPartialType ty
 eqns <- for (zip [(0 :: Int)..] bs) $ \(n, (formula, rhs)) -> do
 formula <- checkFormula formula
 rhs <- check rhs dom
 pure (n, (formula, rhs))

 unify extent (foldl ior VI0 (map (fst . snd) eqns))

 for_ eqns $ \(n, (formula, rhs)) ->
 for_ eqns $ \(n', (formula', rhs')) -> do
 let truth = possible mempty (iand formula formula')
 when ((n /= n') && fst truth) $ do
 vl <- eval rhs
 vl' <- eval rhs'
 unify vl vl'
 `withNote` vsep [ pretty "These two cases must agree because they are both possible:"
 , indent 2 $ pretty '*' <+> prettyTm (quote formula) <+> operator (pretty "=>") <+> prettyTm rhs
 , indent 2 $ pretty '*' <+> prettyTm (quote formula') <+> operator (pretty "=>") <+> prettyTm rhs'
 ]
 `withNote` (pretty "Consider this face, where both are true:" <+> showFace (snd truth))

 name <- newName
 pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, y)) eqns))))

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

 checkFormula :: P.Formula -> ElabM Value
 checkFormula P.FTop = pure VI1
 checkFormula P.FBot = pure VI0
 checkFormula (P.FAnd x y) = iand <$> checkFormula x <*> checkFormula y
 checkFormula (P.FOr x y) = ior <$> checkFormula x <*> checkFormula y
 checkFormula (P.FIs0 x) = do
 nm <- getNameFor x
 ty <- getNfType nm
 unify ty VI
 pure (inot (VVar nm))
 checkFormula (P.FIs1 x) = do
 nm <- getNameFor x
 ty <- getNfType nm
 unify ty VI
 pure (VVar nm)

 isSort :: NFType -> ElabM ()
 isSort VType = pure ()
 isSort VTypeω = pure ()
@ -128,16 +207,29 @@ data ProdOrPath
 , pathRight :: Value
 , pathWrap :: Term -> Term
 }
 | It'sPartial { partialExtent :: NFEndp
 , partialDomain :: Value
 , partialWrap :: Term -> Term
 }
 | It'sPartialP { partialExtent :: NFEndp
 , partialDomain :: Value
 , partialWrap :: 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 (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
@ -156,8 +248,14 @@ isSigmaType t = do
 wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
 pure (dom, const rng, wp)

 identityTy :: NFType
 identityTy = VPi P.Im VType (Closure "A" $ \t -> VPi P.Ex t (Closure "_" (const t)))
 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)

 checkStatement :: P.Statement -> ElabM a -> ElabM a
 checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k
@ -194,7 +292,7 @@ checkStatement (P.Builtin winame var) k = do
 nm <- getNameFor var
 ty <- getNfType nm
 unify ty (wiType wi)
 `withNote` hsep [ "Previous definition of", pretty nm, "here" ]
 `withNote` hsep [ pretty "Previous definition of", pretty nm, pretty "here" ]
 `seeAlso` nm

 env <- ask
--- a/src/Elab/Eval.hs
+++ b/src/Elab/Eval.hs
@ -18,17 +18,19 @@ import Data.Foldable
 import Data.IORef
 import Data.Maybe

 import Elab.Eval.Formula
 import Elab.Monad

 import Presyntax.Presyntax (Plicity(..))

 import Prettyprinter

 import Syntax.Pretty
 import Syntax

 import System.IO.Unsafe

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

 eval :: Term -> ElabM Value
 eval t = asks (flip eval' t)
@ -86,6 +88,23 @@ zonkIO (VIAnd x y) = iand <$> zonkIO x <*> zonkIO y
 zonkIO (VIOr x y) = ior <$> zonkIO x <*> zonkIO y
 zonkIO (VINot x) = inot <$> zonkIO x

 zonkIO (VIsOne x) = VIsOne <$> zonkIO x
 zonkIO (VIsOne1 x) = VIsOne1 <$> zonkIO x
 zonkIO (VIsOne2 x) = VIsOne2 <$> zonkIO x
 zonkIO VItIsOne = pure VItIsOne

 zonkIO (VPartial x y) = VPartial <$> zonkIO x <*> zonkIO y
 zonkIO (VPartialP x y) = VPartialP <$> zonkIO x <*> zonkIO y
 zonkIO (VSystem fs) =
 do
 t <- for (Map.toList fs) $ \(a, b) -> (,) <$> zonkIO a <*> zonkIO b
 pure (mkVSystem (Map.fromList t))
 where
 mkVSystem map =
 case Map.lookup VI1 map of
 Just x -> x
 Nothing -> VSystem map

 zonk :: Value -> Value
 zonk = unsafePerformIO . zonkIO

@ -129,6 +148,15 @@ 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)

 eval' e (IsOne i) = VIsOne (eval' e i)
 eval' e (IsOne1 i) = VIsOne1 (eval' e i)
 eval' e (IsOne2 i) = VIsOne2 (eval' e i)
 eval' _ ItIsOne = VItIsOne

 eval' e (Partial x y) = VPartial (eval' e x) (eval' e y)
 eval' e (PartialP x y) = VPartialP (eval' e x) (eval' e y)
 eval' e (System fs) = VSystem (Map.fromList $ map (\(x, y) -> (eval' e x, eval' e y)) $ Map.toList $ fs)

 vApp :: Plicity -> Value -> Value -> Value
 vApp p (VLam p' k) arg
 | p == p' = clCont k arg
@ -161,13 +189,19 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
 go (VNe x a) (VNe x' a')
 | x == x', length a == length a' =
 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 rhs (VNe _hd (_ Seq.:|> PIElim _l x y i)) =
 case force i of
 VI0 -> unify' rhs x
 VI1 -> unify' rhs y
 _ -> fail

 go (VLam p (Closure _ k)) vl = do
 t <- VVar . Bound <$> newName
 unify' (k t) (vApp p vl t)
@ -193,18 +227,12 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
 go VTypeω VTypeω = pure ()

 go VI VI = pure ()
 go VI0 VI0 = 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)
@ -213,7 +241,23 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where
 n <- VVar . Bound <$> newName
 unify (ielim l (l @@ VI0) (l @@ VI1) p' n) (p @@ n)

 go _ _ = fail
 go (VIsOne x) (VIsOne y) = unify' x y

 -- IsOne is proof-irrelevant:
 go VItIsOne _ = pure ()
 go _ VItIsOne = pure ()
 go VIsOne1{} _ = pure ()
 go _ VIsOne1{} = pure ()
 go VIsOne2{} _ = pure ()
 go _ VIsOne2{} = pure ()

 go (VPartial phi r) (VPartial phi' r') = unify' phi phi' *> unify r r'
 go (VPartialP phi r) (VPartialP phi' r') = unify' phi phi' *> unify r r'

 go x y =
 case (toDnf x, toDnf y) of
 (Just xs, Just ys) -> unify'Formula xs ys
 _ -> fail

 fail = liftIO . throwIO $ NotEqual topa topb

@ -227,8 +271,12 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where

 unify'Spine _ _ = fail

 unify'Formula x y
 | compareDNFs x y = pure ()
 | otherwise = fail

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

 isConvertibleTo :: Value -> Value -> ElabM (Term -> Term)
 VPi Im d (Closure _v k) `isConvertibleTo` ty = do
@ -326,7 +374,17 @@ checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y]
 checkScope s (VINot x) = checkScope s x

 checkScope s (VPath line a b) = traverse_ (checkScope s) [line, a, b]
 checkScope s (VLine _ line) = checkScope s line
 checkScope s (VLine _ line) = checkScope s line

 checkScope s (VIsOne x) = checkScope s x
 checkScope s (VIsOne1 x) = checkScope s x
 checkScope s (VIsOne2 x) = checkScope s x
 checkScope _ VItIsOne = pure ()

 checkScope s (VPartial x y) = traverse_ (checkScope s) [x, y]
 checkScope s (VPartialP x y) = traverse_ (checkScope s) [x, y]
 checkScope s (VSystem fs) =
 for_ (Map.toList fs) $ \(x, y) -> traverse_ (checkScope s) [x, y]

 checkSpine :: Set Name -> Seq Projection -> ElabM [T.Text]
 checkSpine scope (PApp Ex (VVar n@(Bound t)) Seq.:<| xs)
--- a/src/Elab/Eval/Formula.hs
+++ b/src/Elab/Eval/Formula.hs
@ -0,0 +1,62 @@
 module Elab.Eval.Formula where

 import qualified Data.Map.Strict as Map
 import qualified Data.Sequence as Seq
 import Data.Map.Strict (Map)

 import Syntax

 import {-# SOURCE #-} Elab.WiredIn (inot, ior, iand)
 import Debug.Trace (traceShow)

 toDnf :: Value -> Maybe Value
 toDnf (VNe _ _) = Nothing
 toDnf x = toDnf x where
 toDnf (VIAnd x y) = idist <$> toDnf (inot x) <*> toDnf (inot y)
 toDnf (VIOr x y) = ior <$> toDnf x <*> toDnf y
 toDnf (VINot x) = inot <$> toDnf x
 toDnf VI0 = pure VI0
 toDnf VI1 = pure VI1
 toDnf v@(VNe _ Seq.Empty) = pure v
 toDnf _ = Nothing

 compareDNFs :: Value -> Value -> Bool
 compareDNFs (VIOr x y) (VIOr x' y') =
 let (a, a') = swap x y
 (b, b') = swap x' y'
 in compareDNFs a b && compareDNFs a' b'
 compareDNFs (VIAnd x y) (VIAnd x' y') =
 let (a, a') = swap x x'
 (b, b') = swap y y'
 in compareDNFs a a' && compareDNFs b b'
 compareDNFs x y = x == y

 swap :: Ord b => b -> b -> (b, b)
 swap x y =
 if x <= y then (x, y) else (y, x)

 possible :: Map Head Bool -> Value -> (Bool, Map Head Bool)
 possible sc (VINot (VNe n Seq.Empty)) =
 case Map.lookup n sc of
 Just True -> (False, sc)
 _ -> (True, Map.insert n False sc)
 possible sc (VNe n Seq.Empty) =
 case Map.lookup n sc of
 Just False -> (False, sc)
 _ -> (True, Map.insert n True sc)
 possible sc (VIAnd x y) =
 let (a, sc') = possible sc x
 (b, sc'') = possible sc' y
 in (a && b, sc'')
 possible sc (VIOr x y) =
 case possible sc x of
 (True, sc') -> (True, sc')
 (False, _) -> possible sc y
 possible sc VI0 = (False, sc)
 possible sc VI1 = (True, sc)
 possible sc _ = (False, sc)

 idist :: Value -> Value -> Value
 idist (VIOr x y) z = (x `idist` z) `ior` (y `idist` z)
 idist z (VIOr x y) = (z `idist` x) `ior` (z `idist` y)
 idist z x = iand z x
--- a/src/Elab/WiredIn.hs
+++ b/src/Elab/WiredIn.hs
@ -23,10 +23,18 @@ wiType WiInterval = VTypeω
 wiType WiI0 = VI
 wiType WiI1 = VI

 wiType WiIAnd = VI ~> VI ~> VI
 wiType WiIOr = VI ~> VI ~> VI
 wiType WiINot = VI ~> VI
 wiType WiPathP = dprod (VI ~> VTypeω) \a -> a @@ VI0 ~> a @@ VI1 ~> VType
 wiType WiIAnd = VI ~> VI ~> VI
 wiType WiIOr = VI ~> VI ~> VI
 wiType WiINot = VI ~> VI
 wiType WiPathP = dprod (VI ~> VTypeω) \a -> a @@ VI0 ~> a @@ VI1 ~> VType

 wiType WiIsOne = VI ~> VType
 wiType WiItIsOne = VIsOne VI1
 wiType WiIsOne1 = forAll VI \i -> forAll VI \j -> VIsOne i ~> VIsOne (ior i j)
 wiType WiIsOne2 = forAll VI \i -> forAll VI \j -> VIsOne j ~> VIsOne (ior i j)

 wiType WiPartial = VI ~> VType ~> VTypeω
 wiType WiPartialP = dprod VI \x -> VPartial x VType ~> VTypeω

 wiValue :: WiredIn -> Value
 wiValue WiType = VType
@ -41,6 +49,14 @@ wiValue WiIOr = fun \x -> fun \y -> ior x y
 wiValue WiINot = fun inot
 wiValue WiPathP = fun \a -> fun \x -> fun \y -> VPath a x y

 wiValue WiIsOne = fun VIsOne
 wiValue WiItIsOne = VItIsOne
 wiValue WiIsOne1 = forallI \_ -> forallI \_ -> fun VIsOne1
 wiValue WiIsOne2 = forallI \_ -> forallI \_ -> fun VIsOne2

 wiValue WiPartial = fun \phi -> fun \r -> VPartial phi r
 wiValue WiPartialP = fun \phi -> fun \r -> VPartialP phi r

 (~>) :: Value -> Value -> Value
 a ~> b = VPi P.Ex a (Closure "_" (const b))
 infixr 7 ~>
@ -68,6 +84,14 @@ wiredInNames = Map.fromList
 , ("ior", WiIOr)
 , ("inot", WiINot)
 , ("PathP", WiPathP)
 
 , ("IsOne", WiIsOne)
 , ("itIs1", WiItIsOne)
 , ("isOneL", WiIsOne1)
 , ("isOneR", WiIsOne2)

 , ("Partial", WiPartial)
 , ("PartialP", WiPartialP)
 ]

 newtype NoSuchPrimitive = NoSuchPrimitive { getUnknownPrim :: Text }
@ -80,6 +104,10 @@ iand, ior :: Value -> Value -> Value
 iand = \case
 VI1 -> id
 VI0 -> const VI0
 VIAnd x y -> \case
 VI0 -> VI0
 VI1 -> VI1
 z -> iand x (iand y z)
 x -> \case
 VI0 -> VI0
 VI1 -> x
@ -88,6 +116,10 @@ iand = \case
 ior = \case
 VI0 -> id
 VI1 -> const VI1
 VIOr x y -> \case
 VI1 -> VI1
 VI0 -> VIOr x y
 z -> ior x (ior y z)
 x -> \case
 VI1 -> VI1
 VI0 -> x
--- a/src/Presyntax/Lexer.x
+++ b/src/Presyntax/Lexer.x
@ -15,6 +15,7 @@ $white_nol = $white # \n

 tokens :-
 $white_nol+ ;
 "--" .* \n ;
 
 <0,prtext> $alpha [$alpha $digit \_ \']* { yield TokVar }

@ -32,13 +33,26 @@ tokens :-

 <0> \( { always TokOParen }
 <0> \{ { always TokOBrace }
 <0> \[ { always TokOSquare }

 <0> \) { always TokCParen }
 <0> \} { always TokCBrace }
 <0> \] { always TokCSquare }

 <0> \; { always TokSemi }

 <0> \n { just $ pushStartCode newline }

 <0> "&&" { always TokAnd }
 <0> "||" { always TokOr }

 <0> "{-" { just $ pushStartCode comment }

 <comment> {
 "-}" { \i l -> popStartCode *> skip i l }
 . ;
 }

 <0> "{-#" { \i l -> pushStartCode prkw *> always TokOPragma i l }
 <prkw> "PRIMITIVE" { \i l -> popStartCode *> pushStartCode prtext *> always TokPrim i l }
 <prtext> "#-}" { \i l -> popStartCode *> always TokCPragma i l }
@ -91,14 +105,16 @@ popStartCode = do
 alexSetStartCode x

 offsideRule :: AlexInput -> Int64 -> Alex Token
 offsideRule (AlexPn _ line col, _, _, _) _ = do
 ~(col':_) <- layoutColumns <$> getUserState
 case col `compare` col' of
 EQ -> do
 popStartCode
 pure (Token TokSemi line col)
 GT -> do
 popStartCode
 alexMonadScan
 LT -> alexError "wrong ass indentation"
 offsideRule (AlexPn _ line col, _, s, _) _
 | Lbs.null s = pure (Token TokEof line col)
 | otherwise = do
 ~(col':_) <- layoutColumns <$> getUserState
 case col `compare` col' of
 EQ -> do
 popStartCode
 pure (Token TokSemi line col)
 GT -> do
 popStartCode
 alexMonadScan
 LT -> alexError "wrong ass indentation"
 }
--- a/src/Presyntax/Parser.y
+++ b/src/Presyntax/Parser.y
@ -1,5 +1,5 @@
 {
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
 module Presyntax.Parser where

 import qualified Data.Text as T
@ -28,12 +28,17 @@ import Prelude hiding (span)

 %token
 var { Token (TokVar _) _ _ }
 'eof' { Token TokEof _ _ }

 '(' { Token TokOParen _ _ }
 ')' { Token TokCParen _ _ }

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

 '[' { Token TokOSquare _ _ }
 ']' { Token TokCSquare _ _ }

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

@ -46,6 +51,9 @@ import Prelude hiding (span)
 ',' { Token TokComma _ _ }
 '*' { Token TokStar _ _ }

 '&&' { Token TokAnd _ _ }
 '||' { Token TokOr _ _ }

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

@ -59,6 +67,7 @@ import Prelude hiding (span)
 Exp :: { Expr }
 Exp
 : '\\' LambdaList '->' Exp { span $1 $4 $ makeLams $2 $4 }
 | '\\' '{' System '}' { span $1 $4 $ LamSystem $3 }
 | '(' 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 }
@ -85,6 +94,7 @@ Tuple :: { Expr }
 Atom :: { Expr }
 : var { span $1 $1 $ Var (getVar $1) }
 | '(' Tuple ')' { span $1 $3 $ $2 }
 | '[' Exp ']' { span $1 $3 $ Bracket $2 }

 ProdTail :: { Expr }
 : '(' VarList ':' Exp ')' ProdTail { span $1 $6 $ makePis Ex (thd $2) $4 $6 }
@ -119,13 +129,42 @@ ReplStatement :: { Statement }
 | '{-#' Pragma '#-}' { spanSt $1 $3 $ $2 }

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

 Semis :: { () }
 : ';' { () }
 | ';' Semis { () }

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

 System :: { [(Formula, Expr)] }
 : {- empty system -} { [] }
 | NeSystem { $1 }

 NeSystem :: { [(Formula, Expr) ]}
 : Formula '->' Exp { [($1, $3)] }
 | Formula '->' Exp ',' NeSystem { ($1, $3):$5 }

 Formula :: { Formula }
 : Disjn { $1 }
 | Disjn '&&' Disjn { $1 `FAnd` $3 }

 Disjn :: { Formula }
 : FAtom { $1 }
 | FAtom '||' FAtom { $1 `FOr` $3 }

 FAtom :: { Formula }
 : '(' var '=' var ')' {%
 case $4 of
 Token (TokVar x) _ _
 | x == T.pack "i0" -> pure (FIs0 (getVar $2))
 | x == T.pack "i1" -> pure (FIs1 (getVar $2))
 x -> parseError (x, ["i0", "i1"])
 }

 {
 lexer cont = alexMonadScan >>= cont

--- a/src/Presyntax/Presyntax.hs
+++ b/src/Presyntax/Presyntax.hs
@ -19,9 +19,24 @@ data Expr
 | Proj1 Expr
 | Proj2 Expr

 -- application of IsOne primitive is written like [ φ ]
 | Bracket Expr

 -- System
 | LamSystem [(Formula, Expr)]

 | Span Expr Posn Posn
 deriving (Eq, Show, Ord)

 data Formula
 = FIs1 Text
 | FIs0 Text
 | FAnd Formula Formula
 | FOr Formula Formula
 | FTop
 | FBot
 deriving (Eq, Show, Ord)

 data Statement
 = Decl [Text] Expr
 | Defn Text Expr
--- a/src/Presyntax/Tokens.hs
+++ b/src/Presyntax/Tokens.hs
@ -12,8 +12,11 @@ data TokenClass

 | TokOParen
 | TokOBrace
 | TokOSquare

 | TokCParen
 | TokCBrace
 | TokCSquare

 -- {-# #-}
 | TokOPragma
@ -32,6 +35,9 @@ data TokenClass
 | TokPi1
 | TokPi2

 | TokAnd
 | TokOr

 | TokSemi
 deriving (Eq, Show, Ord)

@ -41,8 +47,10 @@ tokSize TokEof = 0
 tokSize TokLambda = 1
 tokSize TokOParen = 1
 tokSize TokOBrace = 1
 tokSize TokOSquare = 1
 tokSize TokCBrace = 1
 tokSize TokCParen = 1
 tokSize TokCSquare = 1
 tokSize TokCPragma = 3
 tokSize TokOPragma = 3
 tokSize TokPrim = length "PRIMITIVE"
@ -55,6 +63,8 @@ tokSize TokArrow = 2
 tokSize TokPi1 = 2
 tokSize TokPi2 = 2
 tokSize TokReplLet = 4
 tokSize TokAnd = 2
 tokSize TokOr = 2
 tokSize (TokReplT s) = T.length s

 data Token
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@ -11,6 +11,8 @@ 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
 = WiType
@ -22,6 +24,14 @@ data WiredIn
 | WiIOr
 | WiINot
 | WiPathP

 | WiIsOne -- Proposition associated with an element of the interval
 | WiItIsOne -- 1 = 1
 | WiIsOne1 -- i j -> [i] -> [ior i j]
 | WiIsOne2 -- i j -> [j] -> [ior i j]

 | WiPartial -- (φ : I) -> Type -> Typeω
 | WiPartialP -- (φ : I) -> Partial r Type -> Typeω
 deriving (Eq, Show, Ord)

 data Term
@ -51,6 +61,16 @@ data Term
 | PathIntro Term Term
 -- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1)
 -- ~~~~~~~~~ not printed at all

 | IsOne Term
 | IsOne1 Term
 | IsOne2 Term
 | ItIsOne

 | Partial Term Term
 | PartialP Term Term

 | System (Map Term Term)
 deriving (Eq, Show, Ord)

 data MV =
@ -90,6 +110,15 @@ data Value

 | VPath Value Value Value
 | VLine Value Value

 | VIsOne Value
 | VItIsOne
 | VIsOne1 Value
 | VIsOne2 Value

 | VPartial NFEndp Value
 | VPartialP NFEndp Value
 | VSystem (Map Value Value)
 deriving (Eq, Show, Ord)

 pattern VVar :: Name -> Value
@ -120,6 +149,7 @@ quoteWith names (VSigma d (Closure n k)) =
 quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b)
 quoteWith _ VType = Type
 quoteWith _ VTypeω = Typeω

 quoteWith _ VI = I
 quoteWith _ VI0 = I0
 quoteWith _ VI1 = I1
@ -130,6 +160,15 @@ 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)

 quoteWith names (VIsOne v) = IsOne (quoteWith names v)
 quoteWith names (VIsOne1 v) = IsOne1 (quoteWith names v)
 quoteWith names (VIsOne2 v) = IsOne2 (quoteWith names v)
 quoteWith _ VItIsOne = ItIsOne

 quoteWith names (VPartial x y) = Partial (quoteWith names x) (quoteWith names y)
 quoteWith names (VPartialP x y) = Partial (quoteWith names x) (quoteWith names y)
 quoteWith names (VSystem fs) = System (Map.fromList (map (\(x, y) -> (quoteWith names x, quoteWith names y)) (Map.toList fs)))

 refresh :: Set Text -> Text -> Text
 refresh s n
 | T.singleton '_' == n = n
--- a/src/Syntax/Pretty.hs
+++ b/src/Syntax/Pretty.hs
@ -14,6 +14,8 @@ import Prettyprinter.Render.Terminal
 import Prettyprinter

 import Syntax
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map

 instance Pretty Name where
 pretty (Bound x) = pretty x
@ -31,6 +33,7 @@ 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)

 (al, bod) = unwindLam l
@ -52,14 +55,25 @@ prettyTm (Pi Ex v d r) = parens (pretty v <+> colon <+> prettyTm
 prettyTm (Sigma (T.unpack -> "_") d r) = prettyDom d <+> pretty "*" <+> prettyTm r
 prettyTm (Sigma v d r) = parens (pretty v <+> colon <+> prettyTm d) <+> pretty "*" <+> prettyTm r

 prettyTm (IAnd x y) = prettyTm x <+> operator (pretty "&&") <+> prettyTm y
 prettyTm (IOr x y) = prettyTm x <+> operator (pretty "||") <+> prettyTm y
 prettyTm (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 (IsOne phi) = brackets (prettyTm 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 (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 (System xs) = braces (mempty <+> hsep (punctuate comma (map go (Map.toList xs))) <+> mempty) where
 go (f, t) = prettyTm f <+> operator (pretty "=>") <+> prettyTm t

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

@ -69,6 +83,10 @@ operator = annotate (color Yellow)
 parenArg :: Term -> Doc AnsiStyle
 parenArg x@App{} = parens (prettyTm x)
 parenArg x@IElim{} = parens (prettyTm x)
 parenArg x@IsOne1{} = parens $ prettyTm x
 parenArg x@IsOne2{} = parens $ prettyTm x
 parenArg x@Partial{} = parens $ prettyTm x
 parenArg x@PartialP{} = parens $ prettyTm x
 parenArg x = prettyDom x

 prettyDom :: Term -> Doc AnsiStyle
@ -86,3 +104,7 @@ render = L.toStrict . renderLazy . layoutPretty defaultLayoutOptions

 showValue :: Value -> String
 showValue = L.unpack . renderLazy . layoutPretty defaultLayoutOptions . prettyTm . quote

 showFace :: Map Head Bool -> Doc AnsiStyle
 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")
--- a/test.tt
+++ b/test.tt
@ -30,6 +30,9 @@ 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)

 id : {A : Type} -> A -> A
 id x = x

 the : (A : Pretype) -> A -> A
 the A x = x

@ -43,4 +46,45 @@ 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)))
 singContr {A} {a} = ((a, \i -> a), \y i -> (y.2 i, \j -> y.2 (iand i j)))

 cong : {A : Type} {B : A -> Type} (f : (x : A) -> B x) {x : A} {y : A} (p : Path x y) -> PathP (\i -> B (p i)) (f x) (f y)
 cong f p i = f (p i)

 congComp : {A : Type} {B : Type} {C : Type}
 {f : A -> B} {g : B -> C} {x : A} {y : A}
 (p : Path x y)
 -> Path (cong g (cong f p)) (cong (\x -> g (f x)) p)
 congComp p = refl

 congId : {A : Type} {x : A} {y : A}
 (p : Path x y)
 -> Path (cong (id {A}) p) p
 congId p = refl

 IsOne : I -> Type
 {-# PRIMITIVE IsOne #-}

 itIs1 : IsOne i1
 {-# PRIMITIVE itIs1 #-}

 isOneL : {i : I} {j : I} -> IsOne i -> IsOne (ior i j)
 {-# PRIMITIVE isOneL #-}

 isOneR : {i : I} {j : I} -> IsOne j -> IsOne (ior i j)
 {-# PRIMITIVE isOneR #-}

 Partial : I -> Type -> Pretype
 {-# PRIMITIVE Partial #-}

 PartialP : (phi : I) -> Partial phi Type -> Pretype
 {-# PRIMITIVE PartialP #-}

 Bool : Type
 tt, ff : Bool

 foo : (i : I) -> (j : I) -> Partial (ior (inot i) (ior i (iand i j))) Bool
 foo i j = \ { (i = i0) -> tt, (i = i1) -> ff, (i = i1) && (j = i1) -> ff }

 apPartial : {B : Type} {A : Type} -> (phi : I) -> (A -> B) -> Partial phi A -> Partial phi B
 apPartial phi f p is1 = f (p is1)