Implement partial elements and systems

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

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

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)

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

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

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"
 }

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
 

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

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

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

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")

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)