initial commit

.gitignore

@@ -0,0 +1 @@
+.stack-work

LICENSE

@@ -0,0 +1,30 @@
+Copyright Abigail Magalhães (c) 2021
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Abigail Magalhães nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1 @@
+# indexed

Setup.hs

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

hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  stack:

indexed.cabal

@@ -0,0 +1,34 @@
+name:                indexed
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/plt-hokusai/indexed#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Abigail Magalhães
+maintainer:          [email protected]
+copyright:           2021 Abigail Magalhães
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+executable indexed
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , mtl
+                     , text
+                     , haskeline
+                     , exceptions
+                     , containers
+                     , megaparsec
+
+  other-modules:       Syntax
+                     , Eval
+                     , Elab
+                     , Systems
+                     , Presyntax
+                     , Presyntax.Parser
+                     , Presyntax.Lexer

src/Elab.hs

@@ -0,0 +1,288 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveAnyClass #-}
+module Elab where
+
+import Control.Exception
+
+import qualified Data.Map.Strict as Map
+import Data.Typeable
+
+import qualified Presyntax as P
+import Syntax
+import Eval
+import Control.Monad
+import Systems
+import Data.Traversable
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Data.Foldable
+
+data TypeError
+  = NotInScope String
+  | UnifyError UnifyError
+  | WrongFaces Value [([Value], Value, Elab.TypeError)]
+  | InSpan     (Int, Int) (Int, Int) Elab.TypeError
+  | IncompleteSystem P.Formula P.Formula
+  | IncompatibleFaces (P.Formula, Term) (P.Formula, Term) Elab.TypeError
+  | InvalidSystem (Set Face) (Set Face)
+  deriving (Show, Typeable, Exception)
+
+check :: Env -> P.Exp -> Value -> IO Term
+check env (P.Span s e exp) wants =
+  check env exp wants
+    `catch` \case
+      InSpan s e err -> throwIO $ InSpan s e err
+      err -> throwIO $ InSpan s e err
+
+check env exp (VSub a fm@(toFormula -> Just phi) el) = do
+  tm <- check env exp a
+  for (addFormula phi env) \env -> 
+    let tm' = eval env tm
+     in unifyTC env tm' el
+  pure (InclSub (quote a) (quote fm) (quote el) tm)
+
+check env (P.Lam s b) expected = do
+  expc <- isPiOrPathType expected
+  case expc of
+    Left (_, d, r) -> do -- function
+      bd <- check env { names = Map.insert s (makeValueGluingSub d s) (names env) } b (r (VVar s))
+      pure (Lam s (quote d) bd)
+    Right (a, x, y) -> do
+      bd <- check env { names = Map.insert s (VI, VVar s) (names env) } b (a @@ VVar s)
+
+      let t = Lam s I bd
+          t' = eval env t
+
+      checkBoundary env [s] t'
+        [ ([VI0], x)
+        , ([VI1], y)
+        ]
+
+      pure (PathI (quote a) (quote x) (quote y) s bd)
+
+check env (P.Let v t d b) expected = do
+  ty <- check env t VType
+  let ty' = eval env ty
+  d <- check env d ty'
+  let d' = eval env d
+  b <- check env { names = Map.insert v (ty', d') (names env) }  b expected
+  pure (Let v (quote ty') d b)
+
+check env (P.Pair a b) expected = do
+  (_, fst, snd) <- isSigmaType expected
+  a <- check env a fst
+  let a' = eval env a
+  b <- check env b (snd a')
+  pure (Pair a b)
+
+check env (P.Partial fs) ty = do
+  let formula = orFormula (map fst fs)
+  (extent, ty) <- isPartialType formula ty
+  let ourFaces    = Systems.faces formula
+      extentFaces = Systems.faces extent
+
+  unless (formula == extent) $
+    throwIO $ IncompleteSystem formula extent
+
+  let range = formulaToTm $ toDNF formula
+
+  rangeTm <- check env range VI
+  let rangeTy = eval env rangeTm
+
+  ts <- for fs $ \(fn, tn) -> do
+    tms <- for (addFormula fn env) \env -> check env tn ty
+    pure (fn, head tms)
+
+  fmap (System . FMap . Map.fromList) $ for ts \(fn, tn) -> do
+    for ts \(fm, tm) -> do
+      when (possible (fn `P.And` fm)) do
+        for_ (addFormula (fn `P.And` fm) env) $ \env ->
+          unifyTC (env) (eval env tn) (eval env tm)
+            `catch` \e -> throwIO (IncompatibleFaces (fn, tn) (fm, tm) e)
+    pure (fn, tn)
+
+check env exp expected = do
+  (term, actual) <- infer env exp
+  unifyTC env actual expected
+  pure term
+
+makeValueGluingSub :: Value -> String -> (Value, Value)
+makeValueGluingSub ty@(VSub a phi a0) s = (ty, VOfSub a phi a0 (VVar s))
+makeValueGluingSub ty s = (ty, VVar s)
+
+addFormula :: P.Formula -> Env -> [Env]
+addFormula (P.And x y) = addFormula x >=> addFormula y
+addFormula (P.Or x y) = (++) <$> addFormula x <*> addFormula y
+addFormula P.Top = pure
+addFormula P.Bot = const []
+addFormula (P.Is0 x) = \env -> pure env{ names = Map.insert x (VI, VI0) (names env) }
+addFormula (P.Is1 x) = \env -> pure env{ names = Map.insert x (VI, VI1) (names env) }
+
+unifyTC :: Env -> Value -> Value -> IO ()
+unifyTC env a b = unify env a b `catch` \e -> const (throwIO (UnifyError (Mismatch a b))) (e :: UnifyError)
+
+checkBoundary :: Env -> [String] -> Value -> [([Value], Value)] -> IO ()
+checkBoundary env ns f = finish <=< go where
+  go :: [([Value], Value)] -> IO [([Value], Value, Elab.TypeError)]
+  go [] = pure []
+  go ((ixs, vl):faces) = do
+    let env' = foldr (\(x, t) env -> env { names = Map.insert x t (names env) }) env (zip ns (zip (repeat VI) ixs))
+    t <- try $ unifyTC env' (foldl (@@) f ixs) vl
+    case t of
+      Right _ -> go faces
+      Left e -> ((ixs, vl, e):) <$> go faces
+  
+  finish [] = pure ()
+  finish xs = throwIO $ WrongFaces f xs
+
+infer :: Env -> P.Exp -> IO (Term, Value)
+infer env (P.Span s e exp) =
+  infer env exp
+    `catch` \case
+      InSpan s e err -> throwIO $ InSpan s e err
+      err -> throwIO $ InSpan s e err
+
+infer env (P.Var s) =
+  case Map.lookup s (names env) of
+    Just (t, _) -> pure (Var s, t)
+    Nothing     -> throwIO (NotInScope s)
+
+infer env (P.App f x) = do
+  (fun, ty) <- infer env f
+  funt <- isPiOrPathType ty
+  case funt of
+    Left (_, dom, rng) -> do
+      arg <- check env x dom
+      let arg' = eval env arg
+      pure (App fun arg, rng arg')
+    Right (a, ai0, ai1) -> do
+      arg <- check env x VI
+      let arg' = eval env arg
+      pure (PathP (quote a) (quote ai0) (quote ai1) fun arg, a @@ arg')
+
+infer env (P.Pi s d r) = do
+  dom <- check env d VType
+  let d' = eval env dom
+  rng <- check env { names = Map.insert s (d', VVar s) (names env) } r VType
+  pure (Pi s dom rng, VType)
+
+infer env (P.Sigma s d r) = do
+  dom <- check env d VType
+  let d' = eval env dom
+  rng <- check env { names = Map.insert s (d', VVar s) (names env) } r VType
+  pure (Sigma s dom rng, VType)
+
+infer env P.Type = pure (Type, VType)
+infer env P.I    = pure (I,    VType)
+infer env P.I0   = pure (I0,   VI)
+infer env P.I1   = pure (I1,   VI)
+
+infer env (P.Cut e t) = do
+  t <- check env t VType
+  let t' = eval env t
+  (, t') <$> check env e t'
+
+infer env (P.IAnd x y) = do
+  x <- check env x VI
+  y <- check env y VI
+  pure (IAnd x y, VI)
+
+infer env (P.IOr x y) = do
+  x <- check env x VI
+  y <- check env y VI
+  pure (IOr x y, VI)
+
+infer env P.Path = do
+  pure
+    ( Lam "A" (quote index_t) $
+        Lam "x" (App (Var "A") I0) $
+          Lam "y" (App (Var "A") I1) $
+            Path (Var "A") (Var "x") (Var "y")
+    , VPi "A" index_t \a ->
+        VPi "x" (a @@ VI0) \_ ->
+          VPi "y" (a @@ VI1) (const VType))
+
+infer env P.PartialT = do
+  pure
+    ( Lam "r" I $
+        Lam "A" Type $
+          Partial (Var "r") (Var "A")
+    , VPi "I" VI \i ->
+        VPi "A" VType (const VType))
+
+infer env P.Comp = do
+  let u_t a r = VPi "i" VI \i -> VPartial r (a @@ i)
+
+  pure
+    ( Lam "A" (quote index_t) $
+        Lam "phi" I $
+          Lam "u" (quote (u_t (VVar "A") (VVar "r"))) $
+            Lam "a0" (Sub (App (Var "A") I0) (Var "phi") (App (Var "u") I0)) $
+              Comp (Var "A") (Var "phi") (Var "u") (Var "a0")
+    , VPi "A" index_t \a ->
+        VPi "phi" VI \phi ->
+          VPi "u" (u_t a phi) \u ->
+            VPi "_" (VSub (a @@ VI0) phi (u @@ VI0)) \_ ->
+              a @@ VI1
+    )
+
+infer env P.SubT = do
+  pure
+    ( Lam "A" Type $
+        Lam "phi" I $
+          Lam "u" (Partial (Var "phi") (Var "A")) $
+            Sub (Var "A") (Var "phi") (Var "u")
+    , VPi "A" VType \a ->
+        VPi "phi" VI \phi ->
+          VPi "_" (VPartial phi a) (const VType)
+    )
+
+infer env (P.INot x) = (, VI) . INot <$> check env x VI
+infer env P.Lam{}    = error "can't infer type for lambda"
+
+infer env (P.Let v t d b) = do
+  ty <- check env t VType
+  let ty' = eval env ty
+  d <- check env d ty'
+  let d' = eval env d
+  (b, t) <- infer env{ names = Map.insert v (ty', d') (names env) } b
+  pure (Let v ty d b, t)
+
+infer env (P.Proj1 x) = do
+  (t, ty) <- infer env x
+  (_, d, _) <- isSigmaType ty
+  pure (Proj1 t, d)
+  
+infer env (P.Proj2 x) = do
+  (t, ty) <- infer env x
+  let t' = eval env t
+  (_, _, r) <- isSigmaType ty
+  pure (Proj2 t, r (proj1 t'))
+
+formulaToTm :: P.Formula -> P.Exp
+formulaToTm (P.Is0 i) = P.INot (P.Var i)
+formulaToTm (P.Is1 i) = P.Var i
+formulaToTm (P.And x y) = P.IAnd (formulaToTm x) (formulaToTm y)
+formulaToTm (P.Or x y) = P.IOr (formulaToTm x) (formulaToTm y)
+formulaToTm P.Top = P.I1
+formulaToTm P.Bot = P.I0
+
+checkFormula :: Env -> P.Formula -> IO ()
+checkFormula env P.Top = pure ()
+checkFormula env P.Bot = pure ()
+checkFormula env (P.And x y) = checkFormula env x *> checkFormula env y
+checkFormula env (P.Or x y)  = checkFormula env x *> checkFormula env y
+checkFormula env (P.Is0 x) =
+  case Map.lookup x (names env) of
+    Just (ty, _) -> unifyTC env ty VI
+    Nothing -> throwIO (NotInScope x)
+checkFormula env (P.Is1 x) =
+  case Map.lookup x (names env) of
+    Just (ty, _) -> unifyTC env ty VI
+    Nothing -> throwIO (NotInScope x)
+
+index_t :: Value
+index_t = VPi "_" VI (const VType)

src/Eval.hs

@@ -0,0 +1,456 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+module Eval where
+
+import Syntax
+import qualified Data.Map.Strict as Map
+import Data.Foldable
+import Control.Exception
+import Data.Typeable
+import System.IO.Unsafe (unsafePerformIO)
+import Data.IORef
+import Systems
+import Presyntax (Formula)
+import qualified Presyntax as P
+import Data.Maybe
+import Debug.Trace
+import GHC.Stack
+
+iand :: Value -> Value -> Value
+iand = \case
+  VI1 -> id
+  VI0 -> const VI0
+  x -> \case
+    VI0 -> VI0
+    VI1 -> x
+    y -> VIAnd x y
+
+ior :: Value -> Value -> Value
+ior = \case
+  VI0 -> id
+  VI1 -> const VI1
+  x -> \case
+    VI1 -> VI1
+    VI0 -> x
+    y -> VIOr x y
+
+inot :: Value -> Value
+inot VI1 = VI0
+inot VI0 = VI1
+inot (VIOr x y) = iand (inot x) (inot y)
+inot (VIAnd x y) = ior (inot x) (inot y)
+inot (VINot x) = x
+inot x = VINot x
+
+(@@) :: Value -> Value -> Value
+VNe hd xs @@ vl = VNe hd (PApp vl:xs)
+VLam _ _ k        @@ vl = k vl
+VEqGlued a b      @@ vl = VEqGlued (a @@ vl) (b @@ vl)
+VOfSub a phi u0 x @@ vl = x @@ vl
+f @@ _  = error $ "can't apply argument to " ++ show f
+
+proj1 :: Value -> Value
+proj1 (VPair x _) = x
+proj1 (VEqGlued x y) = VEqGlued (proj1 x) (proj1 y)
+proj1 (VNe s xs) = VNe s (PProj1:xs)
+proj1 (VOfSub (VSigma _ d _) phi u0 x) = VOfSub d phi (proj1 u0) (proj1 x)
+proj1 x = error $ "can't proj1 " ++ show x
+
+proj2 :: Value -> Value
+proj2 (VPair _ y) = y
+proj2 (VEqGlued x y) = VEqGlued (proj1 x) (proj1 y)
+proj2 (VNe s xs) = VNe s (PProj2:xs)
+proj2 (VOfSub (VSigma _ d r) phi u0 x) =
+  VOfSub (r (proj1 x)) phi (proj2 u0) (proj2 x)
+proj2 x = error $ "can't proj2 " ++ show x
+
+pathp :: Env -> Value -> Value -> Value -> Value -> Value -> Value
+pathp env p x y f@(VLine _a _x _y e) i =
+  case reduceCube env i of
+    Just P.Bot -> VEqGlued (e i) x
+    Just P.Top -> VEqGlued (e i) y
+    _          -> e i
+pathp env p x y (VEqGlued e e') i = VEqGlued (pathp env p x y e i) (pathp env p x y e' i)
+pathp env p x y (VNe hd sp) i =
+  case reduceCube env i of
+    Just P.Bot -> VEqGlued (VNe hd (PPathP p x y i:sp)) x
+    Just P.Top -> VEqGlued (VNe hd (PPathP p x y i:sp)) y
+    _ -> VNe hd (PPathP p x y i:sp)
+pathp env p x y (VOfSub _ _ _ v) i = pathp env p x y v i
+
+comp :: Env -> Value -> Formula -> Value -> Value -> Value
+comp env a@(VLam ivar VI fam) phi u a0 = go (fam undefined) phi u a0 where
+  i = VVar ivar
+  stuck :: Value
+  stuck = maybeAddEq $ VComp a (toValue phi) u a0
+
+  maybeAddEq :: Value -> Value
+  maybeAddEq =
+    if phi == P.Top
+      then flip VEqGlued (u @@ VI1)
+      else id
+
+  go :: HasCallStack => Value -> Formula -> Value -> Value -> Value
+  go VPi{} phi u a0 =
+    let
+      dom x = let VPi _ d _ = fam x in d
+      rng x = let VPi _ d _ = fam x in d
+
+      ai1 = dom VI0
+      y' i y   = fill env i (dom . inot . fam) P.Bot (VSystem emptySystem) y
+      ybar i y = y' (inot i) y
+     in VLam "x" ai1 \arg ->
+       comp env
+        (VLam ivar VI (\i -> rng (ybar i arg)))
+        phi
+        (VLam "i" VI \i -> mapVSystem (u @@ i) (@@ ybar i arg)) 
+        (a0 @@ ybar VI0 arg)
+
+  go VSigma{} phi u a0 =
+    let
+      dom x = let VSigma _ d _ = fam x in d
+      rng x = let VSigma _ d _ = fam x in d
+
+      a i = fill env i (dom . fam) phi (VLam "j" VI \v -> mapVSystem (u @@ v) proj1) (proj1 a0)
+      c1 = comp env (VLam ivar VI (getd . fam))        phi (VLam "i" VI \v -> mapVSystem (u @@ v) proj1) (proj1 a0)
+      c2 = comp env (VLam ivar VI (apr (a VI1) . fam)) phi (VLam "i" VI \v -> mapVSystem (u @@ v) proj2) (proj2 a0)
+
+      getd (VSigma _ d _) = d
+      apr x (VSigma _ _ r) = r x
+     in VPair c1 c2
+
+  go VPath{} phi p p0 =
+    let
+      ~(VPath ai1 u1 v1) = fam VI1
+      ~(VPath ai0 u0 v0) = fam VI0
+      getA (VPath a _ _) = a
+      u' x = let ~(VPath _ u _) = fam x in u
+      v' x = let ~(VPath _ _ v) = fam x in v
+     in
+       VLine (ai1 @@ VI1) u1 v1 \j ->
+         let
+           jc = reduceCube' env j
+          in comp env (VLam ivar VI (getA . fam))
+              (orFormula [phi, jc, notFormula jc])
+              (VLam "j" VI \v ->
+                let
+                  VSystem (FMap sys) = p @@ v
+                  sys' = fmap (flip (pathp env ai0 u0 v0) j) sys
+               in mkVSystem $ Map.fromList [(phi, mapVSystem (p @@ v) (flip (pathp env ai0 u0 v0) j))
+                                           , (notFormula jc, u' v), (jc, v' v)])
+              (pathp env (ai0 @@ VI0) u0 v0 p0 j)
+
+  go a P.Top u a0 = u @@ VI1
+  go a phi u a0 = maybeAddEq stuck
+
+comp env va phi u a0 =
+  if phi == P.Top
+    then VEqGlued (VComp va phi' u a0) (u @@ VI1)
+    else VComp va phi' u a0
+  where
+    phi' = toValue phi
+
+mkVSystem :: Map.Map Formula Value -> Value
+mkVSystem mp
+  | Just e <- Map.lookup P.Top mp = e
+  | otherwise = VSystem $ FMap $ Map.filterWithKey f mp
+  where
+    f P.Bot _ = False
+    f _ _ = True
+
+reduceCube' :: Env -> Value -> Formula
+reduceCube' env = fromJust . reduceCube env
+
+mapVSystem :: Value -> (Value -> Value) -> Value
+mapVSystem (VSystem ss) f = VSystem (mapSystem ss f)
+mapVSystem x f = f x
+
+evalSystem :: Env -> Map.Map Formula Term -> Value
+evalSystem env face = mk . Map.mapMaybeWithKey go $ face where
+  go :: Formula -> Term -> Maybe Value
+  go face tm
+    | VI0 <- toValue' env face = Nothing
+    | otherwise = Just (eval env tm)
+
+  differsFromEnv :: String -> Bool -> Bool
+  differsFromEnv x True =
+    case Map.lookup x (names env) of
+      Just (VI, VI0) -> True
+      _ -> False
+  differsFromEnv x False =
+    case Map.lookup x (names env) of
+      Just (VI, VI1) -> True
+      _ -> False
+
+  mk x = case Map.toList x of
+    [(_, x)] -> x
+    _ -> mkVSystem x
+
+eval :: Env -> Term -> Value
+eval env = \case
+  Var v ->
+    case Map.lookup v (names env) of
+      Just (_, vl) -> vl
+      Nothing      -> error $ "variable not in scope: " ++ show v
+
+  App f x -> eval env f @@ eval env x
+
+  Lam s d b ->
+    let d' = eval env d
+     in VLam s d' \a -> eval env{ names = Map.insert s (d', a) (names env) } b
+
+  Let s t b d ->
+    let b' = eval env b
+        t' = eval env t
+     in eval env{ names = Map.insert s (t', b') (names env) } d
+
+  Pi s d r  ->
+    let d' = eval env d
+     in VPi s d' \a -> eval env{ names = Map.insert s (d', a) (names env) } r
+
+  Sigma s d r  ->
+    let d' = eval env d
+     in VSigma s d' \a -> eval env{ names = Map.insert s (d', a) (names env) } r
+
+  Pair a b -> VPair (eval env a) (eval env b)
+  Proj1 x  -> proj1 (eval env x)
+  Proj2 y  -> proj2 (eval env y)
+
+  Type     -> VType
+
+  I   -> VI
+  I0  -> VI0
+  I1  -> VI1
+
+  Path p x y      -> VPath (eval env p) (eval env x) (eval env y)
+  Partial r a     -> VPartial (eval env r) (eval env a)
+
+  PathI p x y s e -> VLine (eval env p) (eval env x) (eval env y) (\ a -> eval env{ names = Map.insert s (VI, a) (names env) } e)
+  PathP p x y f i -> pathp env (eval env p) (eval env x) (eval env y) (eval env f) (eval env i)
+
+  Sub p x y          -> VSub (eval env p) (eval env x) (eval env y)
+  InclSub a phi u a0 -> VOfSub (eval env a) (eval env phi) (eval env u) (eval env a0)
+
+  IAnd x y        -> iand (eval env x) (eval env y)
+  IOr x y         -> ior (eval env x) (eval env y)
+  INot x          -> inot (eval env x)
+
+  Comp a phi u a0 ->
+    case reduceCube env (eval env phi) of
+      Just formula -> comp env (eval env a) formula (eval env u) (eval env a0)
+      Nothing      -> VComp (eval env a) (eval env phi) (eval env u) (eval env a0)
+
+  System fs       -> evalSystem env (getSystem fs)
+
+
+data UnifyError
+  = Mismatch       Value Value
+  | NotPiType      Value
+  | NotPartialType Formula Value
+  | NotSigmaType   Value
+  deriving (Show, Typeable, Exception)
+
+unify :: Env -> Value -> Value -> IO ()
+unify env (VEqGlued a b) c =
+  unify env a c `catch` \e -> const (unify env b c) (e :: UnifyError)
+unify env c (VEqGlued a b) =
+  unify env c a `catch` \e -> const (unify env c b) (e :: UnifyError)
+
+unify env (VLine a x y f) e = unify env (f (VVar "i")) (pathp env a x y e (VVar "i"))
+unify env e (VLine a x y f) = unify env (f (VVar "i")) (pathp env a x y e (VVar "i"))
+
+unify env (VPartial r b) (VPartial r' b') = do
+  unify env b b'
+  case sameCube env r r' of
+    Just True -> pure ()
+    _ -> unify env r r'
+
+unify env (VPartial r b) x = do
+  case sameCube env r VI1 of
+    Just True -> pure ()
+    _ -> unify env r VI1
+  unify env b x
+
+unify env x (VPartial r b) = do
+  case sameCube env r VI1 of
+    Just True -> pure ()
+    _ -> unify env r VI1
+  unify env x b
+
+unify env (VSub a phi _u0) vl = unify env a vl
+
+unify env u1 (VOfSub _a phi u0 a) = do
+  case sameCube env phi VI1 of
+    Just True -> unify env u1 u0
+    _ -> unify env u1 a
+
+unify env (VOfSub _a phi u0 a) u1 = do
+  case sameCube env phi VI1 of
+    Just True -> unify env u1 u0
+    _ -> unify env u1 a
+
+unify env vl1@(VNe x sp) vl2@(VNe y sp')
+  | x == y    = traverse_ (uncurry unifySp) (zip sp sp')
+  | otherwise = throwIO $ Mismatch vl1 vl2
+  where
+    unifySp (PApp x) (PApp y) = unify env x y
+    unifySp (PPathP _a _x _y i) (PPathP _a' _x' _y' i') = unify env i i'
+    unifySp PProj1 PProj1 = pure ()
+    unifySp PProj2 PProj2 = pure ()
+
+unify env (VLam x _ k) e = unify env (k (VVar x)) (e @@ VVar x)
+unify env e (VLam x _ k) = unify env (e @@ VVar x) (k (VVar x))
+
+unify env (VPi x d r) (VPi _ d' r') = do
+  unify env d d'
+  unify env (r (VVar x)) (r' (VVar x))
+
+unify env (VSigma x d r) (VSigma _ d' r') = do
+  unify env d d'
+  unify env (r (VVar x)) (r' (VVar x))
+
+unify env VType VType = pure ()
+
+unify env VI  VI = pure ()
+
+unify env (VPair a b) (VPair c d) = unify env a c *> unify env b d
+unify env (VPath a x y) (VPath a' x' y') = unify env a a' *> unify env x x' *> unify env y y'
+
+unify env (VSystem fs) vl
+  | ((_, vl'):_) <- Map.toList (Map.filterWithKey (\f _ -> isTrue (toValue' env f)) (getSystem fs))
+  = unify env vl' vl
+
+unify env vl (VSystem fs)
+  | ((_, vl'):_) <- Map.toList (Map.filterWithKey (\f _ -> isTrue (toValue' env f)) (getSystem fs))
+  = unify env vl' vl
+
+unify env x y =
+  case sameCube env x y of
+    Just True -> pure ()
+    _ -> throwIO $ Mismatch x y
+
+reduceCube :: Env -> Value -> Maybe Formula
+reduceCube env x = fmap (toDNF . simplify) (toFormula x) where
+  simplify :: Formula -> Formula
+  simplify (P.Is0 x) =
+    case Map.lookup x (names env) of
+      Just (VI, VI0) -> P.Top
+      Just (VI, VI1) -> P.Bot
+      _ -> P.Is0 x
+  simplify (P.Is1 x) =
+    case Map.lookup x (names env) of
+      Just (VI, VI1) -> P.Top
+      Just (VI, VI0) -> P.Bot
+      _ -> P.Is0 x
+  simplify (P.And x y) = P.And (simplify x) (simplify y)
+  simplify (P.Or x y) = P.Or (simplify x) (simplify y)
+  simplify x = x
+
+sameCube :: Env -> Value -> Value -> Maybe Bool
+sameCube env x y =
+  case (reduceCube env x, reduceCube env y) of
+    (Just x, Just y) -> Just (x == y)
+    _ -> Nothing
+
+toFormula :: Value -> Maybe Formula
+toFormula VI0                = Just P.Bot
+toFormula VI1                = Just P.Top
+toFormula (VNe x [])  = Just (P.Is1 x)
+toFormula (VINot f)    = notFormula <$> toFormula f
+toFormula (VIAnd x y) = do
+  s <- toFormula y
+  t <- toFormula x
+  pure $ andFormula [s, t]
+toFormula (VIOr x y) = do
+  s <- toFormula y
+  t <- toFormula x
+  pure $ orFormula [s, t]
+toFormula _ = Nothing
+
+faceInEnv :: Env -> Face -> Bool
+faceInEnv e f = Map.isSubmapOf (getFace f) (faceOfEnv (names e)) where
+  faceOfEnv = Map.map (\(_, v) -> case v of { VI1 -> True; VEqGlued _ VI1 -> True; _ -> False }) . Map.filter (\(_, v) -> isI v)
+
+  isI VI1 = True
+  isI VI0 = True
+  isI (VEqGlued _ x) = isI x
+  isI _ = False
+
+isPiType :: Value -> IO (String, Value, Value -> Value)
+isPiType (VPi x d r) = pure (x, d, r)
+isPiType x           = throwIO $ NotPiType x
+
+isSigmaType :: Value -> IO (String, Value, Value -> Value)
+isSigmaType (VSigma x d r) = pure (x, d, r)
+isSigmaType x              = throwIO $ NotSigmaType x
+
+isPiOrPathType :: Value -> IO (Either (String, Value, Value -> Value) (Value, Value, Value))
+isPiOrPathType (VPi x d r)   = pure (Left (x, d, r))
+isPiOrPathType (VPath x d r) = pure (Right (x, d, r))
+isPiOrPathType x           = throwIO $ NotPiType x
+
+isPartialType :: Formula -> Value -> IO (Formula, Value)
+isPartialType f p@(VPartial x y) =
+  case toFormula x of
+    Just x -> pure (x, y)
+    Nothing -> throwIO $ NotPartialType f p
+isPartialType f x = throwIO $ NotPartialType f x
+
+getVar :: IO Value
+getVar =
+  do
+    n <- atomicModifyIORef ref \x -> (x + 1, x)
+    pure (VVar (show n))
+  where
+    ref :: IORef Int
+    ref = unsafePerformIO (newIORef 0)
+    {-# NOINLINE ref #-}
+
+fill :: Env
+     -> Value
+     -> (Value -> Value) -- (Γ i : I, A : Type)
+     -> Formula          -- (phi : I)
+     -> Value            -- (u : (i : I) -> Partial phi (A i))
+     -> Value            -- (Sub (A i0) phi (u i0))
+     -> Value            -- -> A i
+fill env i a phi u a0 =
+  comp env
+    (VLam "j" VI \j -> a (i `iand` j))
+    (phi `P.Or` ifc)
+    (VLam "j" VI \j ->
+      mkVSystem (Map.fromList [ (phi, uiand j)
+                              , (notFormula ifc, a0) ]))
+    a0
+  where
+    uiand j = u @@ (i `iand` j)
+    ifc = fromJust (reduceCube env i)
+
+toValue :: Formula -> Value
+toValue P.Top = VI1
+toValue P.Bot = VI0
+toValue (P.And x y) = toValue x `iand` toValue y
+toValue (P.Or x y) = toValue x `ior` toValue y
+toValue (P.Is0 x) = inot (VVar x)
+toValue (P.Is1 x) = VVar x
+
+toValue' :: Env -> Formula -> Value
+toValue' env P.Top = VI1
+toValue' env P.Bot = VI0
+toValue' env (P.And x y) = toValue x `iand` toValue y
+toValue' env (P.Or x y) = toValue x `ior` toValue y
+toValue' env (P.Is0 x) =
+  case Map.lookup x (names env) of
+    Just (VI, VI0) -> VI1
+    Just (VI, VI1) -> VI0
+    Just (VI, x) -> inot x
+    _ -> error $ "type error in toValue'"
+toValue' env (P.Is1 x) =
+  case Map.lookup x (names env) of
+    Just (VI, x) -> x
+    _ -> error $ "type error in toValue'"
+
+isTrue :: Value -> Bool
+isTrue VI1 = True
+isTrue _ = False

src/Main.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE LambdaCase #-}
+module Main where
+
+import Presyntax.Parser
+import Elab
+import Control.Monad.Catch
+import System.Exit
+import Syntax
+import System.Console.Haskeline (runInputT, defaultSettings, getInputLine)
+import Control.Monad.IO.Class
+import Presyntax
+import qualified Data.Map.Strict as Map
+import Eval (eval, UnifyError (..))
+import Systems (formulaOfFace, Face)
+import Data.List
+
+showTypeError :: Maybe [String] -> Elab.TypeError -> String
+showTypeError lines (NotInScope l_c)       = "Variable not in scope: " ++ l_c
+
+showTypeError lines (UnifyError (NotPiType vl)) = "Not a function type: " ++ show vl
+showTypeError lines (UnifyError (NotSigmaType vl)) = "Not a sigma type: " ++ show vl
+showTypeError lines (UnifyError (Mismatch a b)) =
+  unlines [ "Types are not equal: "
+          , "    " ++ show (quote a)
+          , " vs "
+          , "    " ++ show (quote b)
+          ]
+
+showTypeError lines (WrongFaces _ faces) = unlines (map face faces) where
+  face :: ([Value], Value, Elab.TypeError) -> String
+  face (ixs, rhs, err) =
+    "When checking face described by " ++ show ixs ++ ":\n" ++ showTypeError Nothing err
+
+showTypeError lines (InSpan start end err)
+  | Just lines <- lines, fst start == fst end
+  = makeRange (lines !! fst start) start end ++ '\n':showTypeError Nothing err
+  | otherwise = showTypeError Nothing err
+
+showTypeError lines (IncompleteSystem formula extent) =
+  unlines $ 
+    [ "Incomplete system: "
+    , "it is defined by " ++ show formula
+    , "but the context mandates extent " ++ show extent ]
+
+showTypeError lines (IncompatibleFaces (fa, ta) (fb, tb) err) =
+  unlines [ showTypeError lines err
+          , "while checking that these overlapping faces are compatible:"
+          , "* " ++ show fa ++ " -> " ++ show ta
+          , "* " ++ show fb ++ " -> " ++ show tb
+          ]
+
+showTypeError _ x = show x
+
+makeRange :: String -> (Int, Int) -> (Int, Int) -> String
+makeRange line (_, sc) (_, ec) = line ++ "\n" ++ replicate (sc + 1) ' ' ++ replicate (ec - sc) '~'
+
+main :: IO ()
+main = do
+  code <- readFile "test.itt"
+  case parseString body code of
+    Left e -> print e
+    Right x -> do
+      (tm, _) <- infer (Env mempty ) x `catch` \e -> do
+        putStrLn $ showTypeError (Just (lines code)) e
+        exitFailure
+      print tm
+
+repl :: IO ()
+repl = runInputT defaultSettings (go (Env mempty)) where
+  go env = getInputLine "λ " >>= \case
+    Just i | ":sq " `isPrefixOf` i -> do
+      case parseString body (replicate 4 ' ' ++ drop 4 i) of
+        Right exp -> 
+          (do
+            (tm, ty) <- liftIO $ infer env exp
+            liftIO $ drawExtent ty (eval env tm)
+          `catch` \e -> liftIO $ putStrLn (showTypeError (Just [i]) e))
+          `catch` \e -> liftIO $ print (e :: SomeException)
+        Left e -> liftIO (print e)
+      go env
+    Just i ->
+      case parseString statement i of
+        Left e -> liftIO (print e) *> go env
+        Right (Assume vs) ->
+          let
+            loop env ((v, t):vs) = do
+              tm <- liftIO $ check env t VType
+              let ty = eval env tm
+              loop env{ names = Map.insert v (ty, VVar v) (names env) } vs
+            loop env [] = go env
+          in (loop env vs
+              `catch` \e -> (liftIO $ putStrLn (showTypeError (Just [i]) e)) *> go env)
+              `catch` \e -> (liftIO $ print (e :: SomeException)) *> go env
+        Right (Eval v) -> do
+          liftIO $
+            (do
+              (tm, ty) <- infer env v
+              let v_nf = eval env tm
+              putStrLn $ show v_nf ++ " : " ++ show ty
+            `catch` \e -> putStrLn (showTypeError (Just [i]) e))
+            `catch` \e -> print (e :: SomeException)
+          go env
+        Right (Declare n t e) -> do
+          (do
+            t <- liftIO $ check env t VType
+            let t' = eval env t
+            b <- liftIO $ check env e t'
+            let b' = eval env b
+            go env{ names = Map.insert n (t', b') (names env) })
+          `catch` \e -> (liftIO $ putStrLn (showTypeError (Just [i]) e)) *> go env
+          `catch` \e -> (liftIO $ print (e :: SomeException)) *> go env
+    Nothing -> pure ()
+
+drawExtent :: Value -> Value -> IO ()
+drawExtent ty vl = nicely $ getDirections ty vl where
+  getDirections :: Value -> Value -> [([(String, Bool)], Value, Value)]
+  getDirections (VPi _ VI r) (VLam s VI k) =
+    let trues  = getDirections (r VI1) (k VI1)
+        falses = getDirections (r VI0) (k VI0)
+    in map (\(p, t, v) -> ((s, True):p, t, v))  trues
+    ++ map (\(p, t, v) -> ((s, False):p, t, v)) falses
+  getDirections ty t = [([], ty, t)]
+  
+  nicely :: [([(String, Bool)], Value, Value)] -> IO ()
+  nicely [] = pure ()
+  nicely ((bs, ty, el):fcs) = do
+    putStr . unwords $ theFace bs
+    putStrLn $ " => " ++ show el ++ " : " ++ show ty
+    nicely fcs
+
+  theFace = map (\(i, b) ->
+    if b
+      then "(" ++ i ++ "1)"
+      else "(" ++ i ++ "0)")

src/Presyntax.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE LambdaCase #-}
+module Presyntax where
+
+data Exp
+  = Var String
+  | App Exp Exp
+  | Lam String  Exp
+  | Let String Exp Exp Exp
+
+  | Sigma String Exp Exp
+  | Pair Exp Exp
+  | Proj1 Exp
+  | Proj2 Exp
+
+  | Pi  String Exp Exp
+  | Type
+
+  | I
+  | I0 | I1
+  | IAnd Exp Exp
+  | IOr  Exp Exp
+  | INot Exp
+
+  | Path
+
+  | Cut Exp Exp
+  | Span (Int, Int) (Int, Int) Exp
+
+  -- Formulas, partial elements, and the type of formulas
+  | Partial [(Formula, Exp)]
+  | PartialT
+
+  -- Compositions
+  | Comp
+  
+  -- Cubical subtypes
+  | SubT
+  deriving (Eq, Show, Ord)
+
+data Formula
+  = Is0 String
+  | Is1 String
+  | And Formula Formula
+  | Or Formula Formula
+  | Top | Bot
+  deriving (Eq, Ord)
+
+instance Show Formula where
+  showsPrec p =
+    \case
+      Is1 i -> showString i
+      Is0 i -> showString ('~':i)
+      And x y -> showParen (p > and_prec) $
+        showsPrec or_prec x
+        . showString " && "
+        . showsPrec or_prec y
+      Or x y -> showParen (p > or_prec) $
+        showsPrec or_prec x
+        . showString " || "
+        . showsPrec or_prec y
+      Top -> showString "i1"
+      Bot -> showString "i0"
+    where
+      and_prec = 2
+      or_prec = 1
+
+
+data Statement
+  = Assume [(String, Exp)]
+  | Declare String Exp Exp
+  | Eval Exp

src/Presyntax/Lexer.hs

@@ -0,0 +1,192 @@
+{-# LANGUAGE BangPatterns #-}
+module Presyntax.Lexer where
+
+import Data.Text (Text)
+
+import Data.Char
+import qualified Data.Text as T
+
+{- HLINT ignore -}
+data TokenClass
+  = Tok_var Text
+  | Tok_lambda
+
+  | Tok_type
+  | Tok_path
+  | Tok_phi
+  | Tok_sub
+  | Tok_comp
+  | Tok_tr
+
+  | Tok_I
+  | Tok_I0
+  | Tok_I1
+
+  | Tok_oparen
+  | Tok_cparen
+
+  | Tok_osquare
+  | Tok_csquare
+  
+  | Tok_colon
+  | Tok_arrow
+
+  | Tok_let
+  | Tok_equal
+  | Tok_in
+
+  | Tok_and
+  | Tok_not
+  | Tok_or
+
+  | Tok_fand
+  | Tok_for
+
+  | Tok_assume
+
+  | Tok_p1
+  | Tok_p2
+  | Tok_comma
+  | Tok_times
+  deriving (Eq, Show, Ord)
+
+data Token
+  = Token { tokLine  :: {-# UNPACK #-} !Int
+          , tokCol   :: {-# UNPACK #-} !Int
+          , tokSOff  :: {-# UNPACK #-} !Int
+          , tokOff   :: {-# UNPACK #-} !Int
+          , tokClass :: !TokenClass
+          }
+  deriving (Eq, Show, Ord)
+
+data LexError
+  = LexError { leChar :: {-# UNPACK #-} !Char
+             , leLine :: {-# UNPACK #-} !Int
+             , leCol  :: {-# UNPACK #-} !Int
+             }
+  | EOFInComment { leLine :: {-# UNPACK #-} !Int
+                 , leCol :: {-# UNPACK #-} !Int
+                 }
+  deriving (Eq, Show, Ord)
+
+lexString :: String -> Either LexError [Token]
+lexString = go 0 0 0 where
+  go :: Int -> Int -> Int -> String -> Either LexError [Token]
+  go !off !line !_   ('\n':xs) =
+    go (off + 1) (line + 1) 0 xs
+
+  go !off !line !col (' ':xs) =
+    go (off + 1) line (col + 1) xs
+
+  go !off !line !_ ('-':'-':xs) =
+    let (a, b) = span (/= '\n') xs
+     in go (off + length a) line 0 b
+  
+  go !off !line !col ('{':'-':xs) = skipComment off line col 1 xs
+
+  go !off !line !col ('~':cs) =
+    Token line col off (off + 1) Tok_not `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('(':cs) =
+    Token line col off (off + 1) Tok_oparen `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col (')':cs) =
+    Token line col off (off + 1) Tok_cparen `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('[':cs) =
+    Token line col off (off + 1) Tok_osquare `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col (']':cs) =
+    Token line col off (off + 1) Tok_csquare `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col (':':cs) =
+    Token line col off (off + 1) Tok_colon `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col (',':cs) =
+    Token line col off (off + 1) Tok_comma `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('=':cs) =
+    Token line col off (off + 1) Tok_equal `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('\\':'/':cs) =
+    Token line col off (off + 2) Tok_for `yield` go (off + 2) line (col + 2) cs
+
+  go !off !line !col ('\\':cs) =
+    Token line col off (off + 1) Tok_lambda `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('*':cs) =
+    Token line col off (off + 1) Tok_times `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('λ':cs) =
+    Token line col off (off + 1) Tok_lambda `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('→':cs) =
+    Token line col off (off + 1) Tok_lambda `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('-':'>':cs) =
+    Token line col off (off + 2) Tok_arrow `yield` go (off + 2) line (col + 2) cs
+
+  go !off !line !col ('&':'&':cs) =
+    Token line col off (off + 2) Tok_and `yield` go (off + 2) line (col + 2) cs
+
+  go !off !line !col ('&':cs) =
+    Token line col off (off + 1) Tok_fand `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('/':'\\':cs) =
+    Token line col off (off + 1) Tok_fand `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('|':'|':cs) =
+    Token line col off (off + 2) Tok_or `yield` go (off + 2) line (col + 2) cs
+
+  go !off !line !col ('|':cs) =
+    Token line col off (off + 1) Tok_for `yield` go (off + 1) line (col + 1) cs
+
+  go !off !line !col ('.':'1':cs) =
+    Token line col off (off + 2) Tok_p1 `yield` go (off + 2) line (col + 2) cs
+
+  go !off !line !col ('.':'2':cs) =
+    Token line col off (off + 2) Tok_p2 `yield` go (off + 2) line (col + 2) cs
+
+  go !off !line !col (c:cs)
+    | isAlpha c = goIdent off off line col (T.singleton c) cs
+
+  go !_ !line !col (c:_) = Left (LexError c line col)
+
+  go _ _ _ [] = pure []
+
+  goIdent !soff !off !line !col !acc [] =
+    pure [Token line col soff off (finishIdent acc)]
+
+  goIdent !soff !off !line !col !acc (c:cs)
+    | isAlphaNum c || c == '\''
+    = goIdent soff (off + 1) line (col + 1) (T.snoc acc c) cs
+    | otherwise
+    = Token line col soff off (finishIdent acc) `yield` go (off + 1) line (col + 1) (c:cs)
+
+  skipComment off line col level ('-':'}':cs)
+    | level == 1 = go (off + 2) line (col + 2) cs
+    | otherwise = skipComment (off + 2) line (col + 2) (level - 1) cs
+  skipComment off line col level ('{':'-':cs) =
+    skipComment (off + 2) line (col + 2) (level + 1) cs
+  skipComment off line col level ('\n':cs) =
+    skipComment (off + 1) (line + 1) 0 level cs
+  skipComment off line col level (c:cs) =
+    skipComment (off + 1) line (col + 1) level cs
+  skipComment _ line col _ [] = Left (EOFInComment line col)
+
+  yield c = fmap (c:)
+
+  finishIdent c
+    | T.pack "Type" == c    = Tok_type
+    | T.pack "Path" == c    = Tok_path
+    | T.pack "Partial" == c = Tok_phi
+    | T.pack "Sub" == c     = Tok_sub
+    | T.pack "comp" == c    = Tok_comp
+    | T.pack "tr" == c      = Tok_tr
+    | T.pack "I" == c       = Tok_I
+    | T.pack "i0" == c      = Tok_I0
+    | T.pack "i1" == c      = Tok_I1
+    | T.pack "let" == c     = Tok_let
+    | T.pack "in" == c      = Tok_in
+    | T.pack "assume" == c  = Tok_assume
+    | otherwise             = Tok_var c

src/Presyntax/Parser.hs

@@ -0,0 +1,284 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DerivingVia #-}
+module Presyntax.Parser where
+
+import Control.Applicative
+import Control.Monad.State
+
+import qualified Data.Text as T
+import Data.Text (Text)
+
+import Presyntax.Lexer
+import Presyntax
+
+
+data ParseError
+  = UnexpectedEof Int Int
+  | Unexpected Token
+  | Empty
+  | AltError ParseError ParseError
+  deriving (Show)
+
+data ParseState
+  = ParseState { ptTs   :: [Token]
+               , ptLine :: !Int
+               , ptCol  :: !Int
+               }
+
+newtype Parser a =
+  Parser { runParser :: ParseState -> Either ParseError (a, ParseState) }
+  deriving
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadState ParseState
+    )
+  via (StateT ParseState (Either ParseError))
+
+eof :: Parser ()
+eof = Parser $ \state ->
+  case ptTs state of
+    [] -> Right ((), state)
+    (x:_) -> Left (Unexpected x)
+
+parseString :: Parser a -> String -> Either (Either LexError ParseError) a
+parseString (Parser k) s =
+  case lexString s of
+    Left e -> Left (Left e)
+    Right xs ->
+      case k (ParseState xs 0 0) of
+        Left e -> Left (pure e)
+        Right (x, _) -> Right x
+
+selectToken :: (Token -> Maybe a) -> Parser a
+selectToken k = Parser \case
+  ParseState [] l c -> Left (UnexpectedEof l c)
+  ParseState (x:xs) _ _ ->
+    case k x of
+      Just p -> pure (p, ParseState xs (tokLine x) (tokCol x))
+      Nothing -> Left (Unexpected x)
+
+expect :: TokenClass -> Parser ()
+expect t = selectToken (\x -> if tokClass x == t then Just () else Nothing)
+
+var :: Parser Text
+var = selectToken \case
+  Token _ _ _ _ (Tok_var v) -> pure v
+  _ -> Nothing
+
+optionally :: Parser a -> Parser (Maybe a)
+optionally p = fmap Just p <|> pure Nothing
+
+parens :: Parser a -> Parser a
+parens k = do
+  expect Tok_oparen
+  x <- k
+  expect Tok_cparen
+  pure x
+
+square :: Parser a -> Parser a
+square k = do
+  expect Tok_osquare
+  x <- k
+  expect Tok_csquare
+  pure x
+
+instance Alternative Parser where
+  empty = Parser \_ -> Left Empty
+  Parser kx <|> Parser ky = Parser \x ->
+    case kx x of
+      Right x -> Right x
+      Left e  ->
+        case ky x of
+          Left _ -> Left e
+          Right y -> Right y
+
+attachPos :: Parser Exp -> Parser Exp
+attachPos k = do
+  start <- gets (\(ParseState ~(x:_) _ _) -> (tokLine x, tokCol x - (tokOff x - tokSOff x)))
+  x <- k
+  end <- gets (\(ParseState _ l c) -> (l, c))
+  pure (Span start end x)
+
+body :: Parser Exp
+body = attachPos letExpr <|> attachPos lamExpr <|> attachPos exprPi where
+  lamExpr = do
+    expect Tok_lambda
+    vs <- some arg
+    expect Tok_arrow
+    e <- body
+    pure (foldr Lam e vs)
+
+  letExpr = do
+    expect Tok_let
+    v <- T.unpack <$> var
+    expect Tok_colon
+    t <- body
+    expect Tok_equal
+    b <- body
+    expect Tok_in
+    Let v t b <$> body
+
+  arg = T.unpack <$> var
+
+exprPi :: Parser Exp
+exprPi = attachPos $
+  do
+    bs <- optionally binder
+    case bs of
+      Just k -> foldl (.) id k <$> attachPos exprPi
+      Nothing -> attachPos exprArr
+  where
+    binder = (some (parens bind) <* expect Tok_arrow)
+         <|> (fmap pure (parens sigma) <* expect Tok_times)
+
+    bind = do
+      names <- some (T.unpack <$> var)
+      expect Tok_colon
+      t <- exprPi
+      pure (foldr (\n k -> Pi n t . k) id names)
+
+    sigma = do
+      names <- some (T.unpack <$> var)
+      expect Tok_colon
+      t <- exprPi
+      pure (foldr (\n k -> Sigma n t . k) id names)
+
+exprArr :: Parser Exp
+exprArr = attachPos $ do
+  t <- attachPos exprConj
+  c <- optionally (fmap (const True) (expect Tok_arrow) <|> fmap (const False) (expect Tok_times))
+  case c of
+    Just True -> Pi "_" t <$> exprPi
+    Just False -> Sigma "_" t <$> exprPi
+    Nothing -> pure t
+
+exprApp :: Parser Exp
+exprApp = attachPos $
+  do
+    head <- atom
+    spine <- many spineEntry
+    pure (foldl app head spine)
+  where
+    spineEntry = atom
+    app f s = App f s
+
+exprDisj :: Parser Exp
+exprDisj = attachPos $
+  do
+    first <- exprApp
+    rest <- many disjunct
+    pure (foldl IOr first rest)
+  where
+    disjunct = expect Tok_or *> exprApp
+
+exprConj :: Parser Exp
+exprConj = attachPos $
+  do
+    first <- exprDisj
+    rest <- many conjunct
+    pure (foldl IAnd first rest)
+  where
+    conjunct = expect Tok_and *> exprDisj
+
+atom0 :: Parser Exp
+atom0 = attachPos $
+       fmap (Var . T.unpack) var
+   <|> fmap (const Type)     (expect Tok_type)
+   <|> fmap (const I)        (expect Tok_I)
+   <|> fmap (const I0)       (expect Tok_I0)
+   <|> fmap (const I1)       (expect Tok_I1)
+   <|> fmap (const Path)     (expect Tok_path)
+   <|> fmap (const SubT)     (expect Tok_sub)
+   <|> fmap (const PartialT) (expect Tok_phi)
+   <|> fmap (const Comp)     (expect Tok_comp)
+   <|> fmap INot           (expect Tok_not *> atom)
+   <|> parens pair
+   <|> square (Partial <$> (system <|> pure []))
+
+atom :: Parser Exp
+atom = attachPos $
+  do
+    e <- atom0
+    c <- many (selectToken (projection . tokClass))
+    pure $ case c of
+      []  -> e
+      sls -> foldl (flip ($)) e sls
+  where
+    projection Tok_p1 = pure Proj1
+    projection Tok_p2 = pure Proj2
+    projection _      = Nothing
+
+
+system :: Parser [(Formula, Exp)]
+system =
+  do
+    t <- comp
+    x <- optionally (expect Tok_comma)
+    case x of
+      Just () -> (t:) <$> system
+      Nothing -> pure [t]
+  where
+    comp = do
+      t <- formula
+      expect Tok_arrow
+      (t,) <$> body
+
+pair :: Parser Exp
+pair = do
+  t <- body
+  x <- optionally (expect Tok_comma)
+  case x of
+    Just () -> Pair t <$> pair
+    Nothing -> pure t
+
+statement :: Parser Statement
+statement = (assume <|> declare <|> (Eval <$> body)) <* eof where
+  assume = do
+    expect Tok_assume
+    Assume <$> vars
+
+  declare = do
+    expect Tok_let
+    x <- T.unpack <$> var
+    expect Tok_colon
+    ty <- body
+    expect Tok_equal
+    Declare x ty <$> body
+
+  bind = do
+    var <- some (T.unpack <$> var)
+    expect Tok_colon
+    body <- body
+    pure $ map ((, body)) var
+
+  vars = do
+    var <- bind
+    t <- optionally (expect Tok_comma)
+    case t of
+      Nothing -> pure var
+      Just x -> (var ++) <$> vars
+
+formula :: Parser Formula
+formula = conjunction where
+  conjunction, disjunction, atom :: Parser Formula
+  conjunction = do
+    d <- disjunction
+    t <- optionally (expect Tok_and)
+    case t of
+      Nothing -> pure d
+      Just x -> And d <$> conjunction
+
+  disjunction = do
+    d <- atom
+    t <- optionally (expect Tok_or)
+    case t of
+      Nothing -> pure d
+      Just x -> Or d <$> disjunction
+
+  atom = (Is1 . T.unpack) <$> var
+     <|> (Is0 . T.unpack) <$> (expect Tok_not *> var)
+     <|> Top <$ expect Tok_I1
+     <|> Bot <$ expect Tok_I0

src/Syntax.hs

@@ -0,0 +1,250 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Syntax where
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map.Strict (Map)
+import Systems
+import qualified Data.Map.Strict as Map
+import Text.Show (showListWith)
+import Presyntax (Formula)
+
+type Space = Term
+
+data Term
+  = Var String
+  | App Term   Term
+  | Lam String Term Term
+  | Let String Term Term Term
+
+  | Pi  String Term Term
+  | Type
+
+  | I
+  | I0 | I1
+  | IAnd Term Term
+  | IOr  Term Term
+  | INot Term
+
+  | Path  Space Term Term
+  | PathI Space Term Term String Term
+  | PathP Space Term Term Term Term
+
+  | Sigma String Term Term
+  | Pair Term Term
+  | Proj1 Term
+  | Proj2 Term
+
+  | System (System Term)
+  | Partial Term Term
+  | Comp Term Term Term Term
+  | Sub Term Term Term
+  | InclSub Term Term Term Term
+  deriving (Eq, Ord)
+
+instance Show Term where
+  showsPrec p =
+    \case
+      Var s -> showString s
+      System fs -> showListWith showPE (Map.toList (getSystem fs))
+      -- ew
+      App (App (App (Lam _ _ (Lam _ _ (Lam _ _ Path{}))) a) x) y -> showsPrec p (Path a x y)
+      App (App (App (Lam _ _ (Lam _ _ (Lam _ _ Sub{}))) a) x) y -> showsPrec p (Sub a x y)
+      App (App (Lam _ _ (Lam _ _ Partial{})) phi) r -> showsPrec p (Partial phi r)
+
+      App (App (App (App (Lam _ _ (Lam _ _ (Lam _ _ (Lam _ _ Comp{})))) a) phi) u) a0 ->
+        showsPrec p (Comp a phi u a0)
+
+      App f x -> showParen (p >= app_prec) $
+        showsPrec fun_prec f
+        . showChar ' '
+        . showsPrec app_prec x
+
+      Lam s t b ->
+        let
+          getLams (Lam s _ b) =
+            let (as, b') = getLams b
+             in (s:as, b')
+          getLams (PathI _a _x _y s b) =
+            let (as, b') = getLams b
+             in (("(" ++ s ++ " : I)"):as, b')
+          getLams t = ([], t)
+          (args, bd) = getLams (Lam s t b)
+        in showParen (p >= fun_prec) $
+            showString ("λ " ++ unwords args ++ " -> ")
+            . shows bd
+
+      Let s t d b -> showParen (p > fun_prec) $
+        showString "let\n  "
+        . showString s
+        . showString " : "
+        . shows t
+        . showString " = "
+        . shows d
+        . showString " in "
+        . shows b
+
+      Pi "_" d r ->
+        showParen (p >= domain_prec) $
+          showsPrec domain_prec d
+          . showString " -> "
+          . shows r
+
+      Pi v d r -> showParen (p >= domain_prec) $
+        let
+          showBinder (Pi "_" d r) =
+            showsPrec domain_prec d
+            . showString " -> "
+            . shows r
+          showBinder (Pi n d r) =
+            let 
+              arr = case r of
+                Pi n _ _ | n /= "_" -> " "
+                _ -> " -> "
+             in
+               showParen True (showString n . showString " : " . shows d)
+               . showString arr
+               . showBinder r
+          showBinder t = shows t
+         in showBinder (Pi v d r)
+
+      Type -> showString "Type"
+      I    -> showChar 'I'
+      I0   -> showString "i0"
+      I1   -> showString "i1"
+
+      IAnd i j -> showParen (p >= and_prec) $
+        showsPrec or_prec i
+        . showString " && "
+        . showsPrec or_prec j
+
+      IOr i j -> showParen (p >= or_prec) $
+        showsPrec app_prec i
+        . showString " || "
+        . showsPrec app_prec j
+
+      INot s -> showChar '~' . showsPrec p s
+
+      Path a x y -> showsPrec p (App (App (App (Var "Path") a) x) y)
+      Sub a x y -> showsPrec p (App (App (App (Var "Sub") a) x) y)
+      Partial r a -> showsPrec p (App (App (Var "Partial") r) a)
+      Comp a phi u a0 -> showsPrec p (foldl App (Var "comp") [a, phi, u, a0])
+      InclSub _a _phi _u0 a0 -> showsPrec p a0
+
+      PathI a x y s b -> showParen (p >= fun_prec) $
+        showString ("λ " ++ s ++ " -> ")
+        . shows b
+      PathP _a _x _y f i -> showsPrec p (App f i)
+
+      Pair a b -> showParen True $
+        shows a
+        . showString ", "
+        . shows b
+
+      Proj1 b -> showsPrec p b . showString ".1"
+      Proj2 b -> showsPrec p b . showString ".1"
+      Sigma v d r ->
+        showParen (p >= app_prec) $
+          showParen True (showString v . showString " : " . shows d)
+          . showString " × "
+          . shows r
+    where
+      app_prec    = 6
+      domain_prec = 5
+      and_prec    = 4
+      or_prec     = 3
+      fun_prec    = 1
+
+showPE :: (Formula, Term) -> String -> String
+showPE (f, t) = shows f . showString " -> " . shows t
+
+data Value
+  = VNe   String [Proj]
+  | VLam  String Value (Value -> Value)
+  | VPi   String Value (Value -> Value)
+  | VType
+  | VI | VI0 | VI1
+  | VEqGlued Value Value -- e which is def. eq. to e'
+  | VPair Value Value
+  | VSigma String Value (Value -> Value)
+  | VLine Value Value Value (Value -> Value)
+    -- (λ i → ...) : Path A x y
+    -- order: A x y k
+  | VSystem (System Value)
+  | VOfSub Value Value Value Value
+
+  | VIAnd Value Value
+  | VIOr Value Value
+  | VINot Value
+
+  | VPath Value Value Value
+  | VSub Value Value Value
+  | VPartial Value Value
+  | VComp Value Value Value Value
+
+data Proj
+  = PApp Value
+  | PPathP Value Value Value Value
+    -- a x y i
+  | PProj1
+  | PProj2
+
+pattern VVar :: String -> Value
+pattern VVar x = VNe x []
+
+quote :: Value -> Term
+quote = go mempty where
+  go :: Set String -> Value -> Term
+  go scope (VNe hd spine) = foldl (goSpine scope) (Var hd) (reverse spine)
+  go scope (VLam s a k) =
+    let n = rename s scope
+     in Lam n (go scope a) (go (Set.insert n scope) (k (VVar n)))
+  go scope (VPi s d r) =
+    let n = rename s scope
+     in Pi n (go scope d) (go (Set.insert n scope) (r (VVar n)))
+  go scope (VSigma s d r) =
+    let n = rename s scope
+     in Sigma n (go scope d) (go (Set.insert n scope) (r (VVar n)))
+
+  go scope VType = Type
+  go scope VI0   = I0
+  go scope VI1   = I1
+  go scope VI    = I
+
+  go scope (VIAnd x y) = IAnd (go scope x) (go scope y)
+  go scope (VIOr x y) = IOr (go scope x) (go scope y)
+  go scope (VINot x) = INot (go scope x)
+
+  go scope (VPath a x y) = Path (go scope a) (go scope x) (go scope y)
+  go scope (VSub a x y) = Sub (go scope a) (go scope x) (go scope y)
+  go scope (VPartial r a) = Partial (go scope r) (go scope a)
+  go scope (VComp a b c d) = Comp (go scope a) (go scope b) (go scope c) (go scope d)
+
+  go scope (VEqGlued e _) = go scope e
+  go scope (VPair a b) = Pair (go scope a) (go scope b)
+  go scope (VLine a x y k) =
+    let n = rename "i" scope
+     in PathI (go scope a) (go scope x) (go scope y) n (go (Set.insert n scope) (k (VVar n)))
+  go scope (VSystem (FMap fs)) = System (FMap (fmap (go scope) fs))
+  go scope (VOfSub _ _ _ x) = go scope x
+
+  goSpine :: Set String -> Term -> Proj -> Term
+  goSpine scope t (PApp x) = App t (go scope x)
+  goSpine scope t (PPathP a x y i) = PathP (go scope a) (go scope x) (go scope y) t (go scope i)
+  goSpine scope t PProj1 = Proj1 t
+  goSpine scope t PProj2 = Proj2 t
+
+rename :: String -> Set String -> String
+rename x s
+  | x == "_"         = x
+  | x `Set.member` s = rename (x ++ "'") s
+  | otherwise        = x
+
+instance Show Value where
+  showsPrec p = showsPrec p . quote
+
+data Env =
+  Env { names :: Map String (Value, Value)
+      }
+  deriving (Show)

src/Systems.hs

@@ -0,0 +1,96 @@
+module Systems where
+
+import Data.Map.Strict (Map)
+import Presyntax
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.List
+
+newtype Face = Face { getFace :: Map String Bool }
+  deriving (Eq, Show, Ord)
+
+evalFormula :: Formula -> Face -> Bool
+evalFormula (Is0 x) f =
+  case Map.lookup x (getFace f) of
+    Just x -> not x
+    Nothing -> error $ "dimension not bound in formula: " ++ show x
+
+evalFormula (Is1 x) f =
+  case Map.lookup x (getFace f) of
+    Just x -> x
+    Nothing -> error $ "dimension not bound in formula: " ++ show x
+
+evalFormula (And a b) f = evalFormula a f && evalFormula b f
+evalFormula (Or a b) f = evalFormula a f || evalFormula b f
+
+evalFormula Top _ = True
+evalFormula Bot _ = False
+
+freeVarsFormula :: Formula -> Set String
+freeVarsFormula (Is0 x)   = Set.singleton x
+freeVarsFormula (Is1 x)   = Set.singleton x
+freeVarsFormula (And a b) = Set.union (freeVarsFormula a) (freeVarsFormula b)
+freeVarsFormula (Or a b)  = Set.union (freeVarsFormula a) (freeVarsFormula b)
+freeVarsFormula Top = mempty
+freeVarsFormula Bot = mempty
+
+faces :: Formula -> ([Face], [Face])
+faces formula = partition (evalFormula formula) allPossible where
+  truths []     = [mempty]
+  truths (x:xs) = uncurry Map.insert <$> [(x, True), (x, False)] <*> truths xs
+
+  allPossible = Face <$> truths (Set.toList (freeVarsFormula formula)) 
+
+impossible, possible, tautological :: Formula -> Bool
+impossible = null . fst . faces
+possible = not . null . fst . faces
+tautological = not . null . snd . faces
+
+toDNF :: Formula -> Formula
+toDNF = orFormula . map formulaOfFace . fst . faces 
+
+formulaOfFace :: Face -> Formula
+formulaOfFace = andFormula . map (\(x, i) -> if i then Is1 x else Is0 x) . Map.toDescList . getFace
+
+andFormula :: [Formula] -> Formula
+andFormula = foldr and Top where
+  and x y =
+    case x of
+      Top -> case y of
+        Bot -> Bot
+        _ -> y
+      Bot -> Bot
+      _ -> case y of
+        Top -> x
+        _ -> And x y
+
+orFormula :: [Formula] -> Formula
+orFormula [] = Bot
+orFormula (x:xs) = or x (orFormula xs) where
+  or x y =
+    case x of
+      Top -> Top
+      Bot -> case y of
+        Top -> Top
+        _ -> y
+      _ -> case y of
+        Bot -> x
+        _ -> Or x y
+
+notFormula :: Formula -> Formula
+notFormula Top = Bot
+notFormula Bot = Top
+notFormula (Is0 x) = Is1 x
+notFormula (Is1 x) = Is0 x
+notFormula (And x y) = Or (notFormula x) (notFormula y)
+notFormula (Or x y) = And (notFormula x) (notFormula y)
+
+newtype System a = FMap { getSystem :: Map Formula a }
+  deriving (Eq, Show, Ord)
+
+emptySystem :: System a
+emptySystem = FMap mempty
+
+mapSystem :: System a -> (a -> b) -> System b
+mapSystem (FMap x) f = FMap (fmap f x)

stack.yaml

@@ -0,0 +1,67 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/1.yaml
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.5"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack.yaml.lock

@@ -0,0 +1,13 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 563098
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/1.yaml
+    sha256: 395775c03e66a4286f134d50346b0b6f1432131cf542886252984b4cfa5fef69
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/1.yaml

test.itt

@@ -0,0 +1,52 @@
+{- let
+  sym : (A : Type) (x y : A) -> Path (\x -> A) x y -> Path (\x -> A) y x
+    = λ A x y p i -> p (~ i)
+in let
+  funext : (A : Type) (B : A -> Type) (f g : (x : A) -> B x) -> ((x : A) -> Path (\i -> B x) (f x) (g x)) -> Path (\i -> (x : A) -> B x) f g
+    = λ A B f g h i x -> h x i
+in let
+  i0IsI1 : Path (\x -> I) i0 i1
+    = λ i -> i
+in let
+  singContr : (A : Type) (a b : A) (p : Path (\j -> A) a b) -> Path (\i -> (x : A) * (Path (\j -> A) a x)) (a, \i -> a) (b, p)
+    = λ A a b p i -> (p i, λ j -> p (i && j))
+in -} let
+  transport : (A : I -> Type) (a : A i0) -> A i1
+    = \A a -> comp A i0 (\i -> []) a
+in {- let
+  Jay : (A : Type) (x : A)
+        (P : (y : A) -> Path (\i -> A) x y -> Type)
+        (d : P x (\i -> x))
+        (y : A) (p : Path (\i -> A) x y)
+     -> P y p
+    = \A x P d y p -> transport (\i -> P (p i) (\j -> p (i && j))) d
+in -}
+let
+  fill : (i : I) (A : I -> Type)
+         (phi : I) (u : (i : I) -> Partial phi (A i))
+      -> Sub (A i0) phi (u i0) -> A i
+    = \i A phi u a0 ->
+      comp (\j -> A (i && j)) (phi || ~i) (\j -> [ phi -> u (i && j), ~i -> a0 ]) a0
+in let
+  trans : (A : Type) (a b c : A)
+       -> Path (\i -> A) a b
+       -> Path (\i -> A) b c
+       -> Path (\i -> A) a c
+    = \A a b c p q i ->
+      comp (\j -> A) (i || ~i)
+           (\j -> [ ~i -> a, i -> q j ])
+           (p i)
+in let
+  elimI : (P : I -> Type)
+          (a : P i0)
+          (b : P i1)
+       -> Path P a b
+       -> (i : I) -> P i
+    = \P a b p i -> p i
+in let
+  contrI : (i : I) -> Path (\i -> I) i0 i
+    = \i -> elimI (\x -> Path (\i -> I) i0 x) (\i -> i0) (\i -> i) (\i j -> i && j) i
+in let
+  IisContr : (i : I) * ((j : I) -> Path (\i -> I) i j)
+    = (i0, contrI)
+in IisContr