initial commit

3 years ago · f673499664
--- a/.gitignore
+++ b/.gitignore
@ -0,0 +1 @@
 .stack-work
--- a/+ 30
+++ b/+ 30
@ -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.
--- a/README.md
+++ b/README.md
@ -0,0 +1 @@
 # indexed
--- a/Setup.hs
+++ b/Setup.hs
@ -0,0 +1,2 @@
 import Distribution.Simple
 main = defaultMain
--- a/hie.yaml
+++ b/hie.yaml
@ -0,0 +1,2 @@
 cradle:
 stack:
--- a/indexed.cabal
+++ b/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
--- a/src/Elab.hs
+++ b/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)
--- a/src/Eval.hs
+++ b/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
--- a/src/Main.hs
+++ b/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)")
--- a/src/Presyntax.hs
+++ b/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
--- a/src/Presyntax/Lexer.hs
+++ b/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
--- a/src/Presyntax/Parser.hs
+++ b/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
--- a/src/Syntax.hs
+++ b/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)
--- a/src/Systems.hs
+++ b/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)
--- a/stack.yaml
+++ b/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
--- a/stack.yaml.lock
+++ b/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
--- a/test.itt
+++ b/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