├── .gitignore ├── CTT.hs ├── Cartesian.hs ├── Eval.hs ├── Exp.cf ├── GNUmakefile ├── LICENSE ├── Main.hs ├── Makefile ├── README.md ├── Resolver.hs ├── Setup.hs ├── TypeChecker.hs ├── examples ├── bool.ytt ├── circle.ytt ├── hedberg.ytt ├── int.ytt ├── prelude.ytt └── univalence.ytt ├── stack.yaml ├── yacctt.cabal └── yacctt.el /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | Exp/ 22 | -------------------------------------------------------------------------------- /CTT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | module CTT where 3 | 4 | 5 | import Prelude hiding ((<>)) 6 | import Control.Applicative 7 | import Data.List 8 | import Data.Maybe 9 | import qualified Data.Map as Map 10 | import Text.PrettyPrint as PP 11 | import qualified Data.Set as Set 12 | 13 | import Cartesian 14 | 15 | -------------------------------------------------------------------------------- 16 | -- | Terms 17 | 18 | data Loc = Loc { locFile :: String 19 | , locPos :: (Int,Int) } 20 | deriving Eq 21 | 22 | type Ident = String 23 | type LIdent = String 24 | 25 | -- Telescope (x1 : A1) .. (xn : An) 26 | type Tele = [(Ident,Ter)] 27 | 28 | data Label = OLabel LIdent Tele -- Object label 29 | | PLabel LIdent Tele [Name] (System Ter) -- Path label 30 | deriving (Eq,Show) 31 | 32 | -- OBranch of the form: c x1 .. xn -> e 33 | -- PBranch of the form: c x1 .. xn i1 .. im -> e 34 | data Branch = OBranch LIdent [Ident] Ter 35 | | PBranch LIdent [Ident] [Name] Ter 36 | deriving (Eq,Show) 37 | 38 | -- Declarations: x : A = e 39 | -- A group of mutual declarations is identified by its location. It is used to 40 | -- speed up the Eq instance for Ctxt. 41 | type Decl = (Ident,(Ter,Ter)) 42 | data Decls = MutualDecls Loc [Decl] 43 | | OpaqueDecl Ident 44 | | TransparentDecl Ident 45 | | TransparentAllDecl 46 | deriving Eq 47 | 48 | declIdents :: [Decl] -> [Ident] 49 | declIdents decls = [ x | (x,_) <- decls ] 50 | 51 | declTers :: [Decl] -> [Ter] 52 | declTers decls = [ d | (_,(_,d)) <- decls ] 53 | 54 | declTele :: [Decl] -> Tele 55 | declTele decls = [ (x,t) | (x,(t,_)) <- decls ] 56 | 57 | declDefs :: [Decl] -> [(Ident,Ter)] 58 | declDefs decls = [ (x,d) | (x,(_,d)) <- decls ] 59 | 60 | labelTele :: Label -> (LIdent,Tele) 61 | labelTele (OLabel c ts) = (c,ts) 62 | labelTele (PLabel c ts _ _) = (c,ts) 63 | 64 | labelName :: Label -> LIdent 65 | labelName = fst . labelTele 66 | 67 | labelTeles :: [Label] -> [(LIdent,Tele)] 68 | labelTeles = map labelTele 69 | 70 | lookupLabel :: LIdent -> [Label] -> Maybe Tele 71 | lookupLabel x xs = lookup x (labelTeles xs) 72 | 73 | lookupPLabel :: LIdent -> [Label] -> Maybe (Tele,[Name],System Ter) 74 | lookupPLabel x xs = listToMaybe [ (ts,is,es) | PLabel y ts is es <- xs, x == y ] 75 | 76 | branchName :: Branch -> LIdent 77 | branchName (OBranch c _ _) = c 78 | branchName (PBranch c _ _ _) = c 79 | 80 | lookupBranch :: LIdent -> [Branch] -> Maybe Branch 81 | lookupBranch _ [] = Nothing 82 | lookupBranch x (b:brs) = case b of 83 | OBranch c _ _ | x == c -> Just b 84 | | otherwise -> lookupBranch x brs 85 | PBranch c _ _ _ | x == c -> Just b 86 | | otherwise -> lookupBranch x brs 87 | 88 | -- Terms 89 | data Ter = Pi Ter 90 | | App Ter Ter 91 | | Lam Ident Ter Ter 92 | | Where Ter Decls 93 | | Var Ident 94 | | U 95 | -- Sigma types: 96 | | Sigma Ter 97 | | Pair Ter Ter 98 | | Fst Ter 99 | | Snd Ter 100 | -- constructor c Ms 101 | | Con LIdent [Ter] 102 | | PCon LIdent Ter [Ter] [II] -- c A ts phis (A is the data type) 103 | -- branches c1 xs1 -> M1,..., cn xsn -> Mn 104 | | Split Ident Loc Ter [Branch] 105 | -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors) 106 | | Sum Loc Ident [Label] -- TODO: should only contain OLabels 107 | | HSum Loc Ident [Label] 108 | -- undefined and holes 109 | | Undef Loc Ter -- Location and type 110 | | Hole Loc 111 | -- Path and line types 112 | | PathP Ter Ter Ter 113 | | LineP Ter 114 | | PLam Name Ter 115 | | AppII Ter II 116 | -- Coe 117 | | Coe II II Ter Ter 118 | -- Homogeneous Kan composition 119 | | HCom II II Ter (System Ter) Ter 120 | -- Heterogeneous Kan composition (derived) 121 | | Com II II Ter (System Ter) Ter 122 | 123 | -- V-types 124 | | V II Ter Ter Ter -- V r A B E (where E : A ~= B) 125 | | Vin II Ter Ter -- Vin r M N (where M : A and N : B) 126 | | Vproj II Ter Ter Ter Ter -- Vproj r O A B E (where O : V r A B E) 127 | 128 | -- Universes 129 | | Box II II (System Ter) Ter 130 | | Cap II II (System Ter) Ter 131 | 132 | -- Glue 133 | -- | Glue Ter (System Ter) 134 | -- | GlueElem Ter (System Ter) 135 | -- | UnGlueElem Ter Ter (System Ter) 136 | deriving Eq 137 | 138 | -- For an expression t, returns (u,ts) where u is no application and t = u ts 139 | unApps :: Ter -> (Ter,[Ter]) 140 | unApps = aux [] 141 | where aux :: [Ter] -> Ter -> (Ter,[Ter]) 142 | aux acc (App r s) = aux (s:acc) r 143 | aux acc t = (t,acc) 144 | 145 | mkApps :: Ter -> [Ter] -> Ter 146 | mkApps (Con l us) vs = Con l (us ++ vs) 147 | mkApps t ts = foldl App t ts 148 | 149 | mkWheres :: [Decls] -> Ter -> Ter 150 | mkWheres [] e = e 151 | mkWheres (d:ds) e = Where (mkWheres ds e) d 152 | 153 | -------------------------------------------------------------------------------- 154 | -- | Values 155 | 156 | data Val = VU 157 | | Ter Ter Env 158 | | VPi Val Val 159 | | VSigma Val Val 160 | | VPair Val Val 161 | | VCon LIdent [Val] 162 | | VPCon LIdent Val [Val] [II] 163 | 164 | -- Path values 165 | | VPathP Val Val Val 166 | | VLineP Val 167 | | VPLam Name Val 168 | 169 | -- Homogeneous composition; the type is constant 170 | | VHCom II II Val (System Val) Val 171 | 172 | -- Coe 173 | | VCoe II II Val Val 174 | 175 | -- V-types values 176 | | VV Name Val Val Val -- V i A B E (where E : A ~= B) 177 | | VVin Name Val Val -- Vin i M N (where M : A and N : B) 178 | | VVproj Name Val Val Val Val -- Vproj i O A B E (where O : V i A B E) 179 | 180 | -- Glue values 181 | -- | VGlue Val (System Val) 182 | -- | VGlueElem Val (System Val) 183 | -- | VUnGlueElem Val Val (System Val) -- unglue u A [phi -> (T,w)] 184 | 185 | -- Universe values 186 | | VHComU II II (System Val) Val -- r s bs a 187 | | VBox II II (System Val) Val -- r s ns m 188 | | VCap II II (System Val) Val -- r s bs m 189 | 190 | -- Neutral values: 191 | | VVar Ident Val 192 | | VOpaque Ident Val 193 | | VFst Val 194 | | VSnd Val 195 | | VSplit Val Val 196 | | VApp Val Val 197 | | VAppII Val II 198 | | VLam Ident Val Val 199 | -- | VUnGlueElemU Val Val (System Val) 200 | deriving Eq 201 | 202 | isNeutral :: Val -> Bool 203 | isNeutral v = case v of 204 | Ter Undef{} _ -> True 205 | Ter Hole{} _ -> True 206 | VVar{} -> True 207 | VOpaque{} -> True 208 | VHCom{} -> True 209 | VCoe{} -> True 210 | VFst{} -> True 211 | VSnd{} -> True 212 | VSplit{} -> True 213 | VApp{} -> True 214 | VAppII{} -> True 215 | -- VUnGlueElemU{} -> True 216 | -- VUnGlueElem{} -> True 217 | VCap{} -> True 218 | VVproj{} -> True 219 | _ -> False 220 | 221 | isNeutralSystem :: System Val -> Bool 222 | isNeutralSystem (Sys xs) = any isNeutral (Map.elems xs) 223 | isNeutralSystem (Triv a) = isNeutral a 224 | 225 | -- isNeutralPath :: Val -> Bool 226 | -- isNeutralPath (VPath _ v) = isNeutral v 227 | -- isNeutralPath _ = True 228 | 229 | mkVar :: Int -> String -> Val -> Val 230 | mkVar k x = VVar (x ++ show k) 231 | 232 | mkVarNice :: [String] -> String -> Val -> Val 233 | mkVarNice xs x = VVar (head (ys \\ xs)) 234 | where ys = x:map (\n -> x ++ show n) [0..] 235 | 236 | unCon :: Val -> [Val] 237 | unCon (VCon _ vs) = vs 238 | unCon v = error $ "unCon: not a constructor: " ++ show v 239 | 240 | isCon :: Val -> Bool 241 | isCon VCon{} = True 242 | isCon _ = False 243 | 244 | -- Constant path: <_> v 245 | constPath :: Val -> Val 246 | constPath = VPLam (N "_") 247 | 248 | 249 | -------------------------------------------------------------------------------- 250 | -- | Environments 251 | 252 | data Ctxt = Empty 253 | | Upd Ident Ctxt 254 | | Sub Name Ctxt 255 | | Def Loc [Decl] Ctxt 256 | deriving (Show) 257 | 258 | instance Eq Ctxt where 259 | c == d = case (c, d) of 260 | (Empty, Empty) -> True 261 | (Upd x c', Upd y d') -> x == y && c' == d' 262 | (Sub i c', Sub j d') -> i == j && c' == d' 263 | (Def m xs c', Def n ys d') -> (m == n || xs == ys) && c' == d' 264 | -- Invariant: if two declaration groups come from the same 265 | -- location, they are equal and their contents are not compared. 266 | _ -> False 267 | 268 | -- The Idents and Names in the Ctxt refer to the elements in the two 269 | -- lists. This is more efficient because acting on an environment now 270 | -- only need to affect the lists and not the whole context. 271 | -- The last list is the list of opaque names 272 | newtype Env = Env (Ctxt,[Val],[II],Nameless (Set.Set Ident)) 273 | deriving (Eq) 274 | 275 | emptyEnv :: Env 276 | emptyEnv = Env (Empty,[],[],Nameless Set.empty) 277 | 278 | def :: Decls -> Env -> Env 279 | def (MutualDecls m ds) (Env (rho,vs,fs,Nameless os)) = 280 | Env (Def m ds rho,vs,fs,Nameless (os Set.\\ Set.fromList (declIdents ds))) 281 | def (OpaqueDecl n) (Env (rho,vs,fs,Nameless os)) = Env (rho,vs,fs,Nameless (Set.insert n os)) 282 | def (TransparentDecl n) (Env (rho,vs,fs,Nameless os)) = Env (rho,vs,fs,Nameless (Set.delete n os)) 283 | def TransparentAllDecl (Env (rho,vs,fs,Nameless os)) = Env (rho,vs,fs,Nameless Set.empty) 284 | 285 | defWhere :: Decls -> Env -> Env 286 | defWhere (MutualDecls m ds) (Env (rho,vs,fs,Nameless os)) = 287 | Env (Def m ds rho,vs,fs,Nameless (os Set.\\ Set.fromList (declIdents ds))) 288 | defWhere (OpaqueDecl _) rho = rho 289 | defWhere (TransparentDecl _) rho = rho 290 | defWhere TransparentAllDecl rho = rho 291 | 292 | sub :: (Name,II) -> Env -> Env 293 | sub (i,phi) (Env (rho,vs,fs,os)) = Env (Sub i rho,vs,phi:fs,os) 294 | 295 | upd :: (Ident,Val) -> Env -> Env 296 | upd (x,v) (Env (rho,vs,fs,Nameless os)) = Env (Upd x rho,v:vs,fs,Nameless (Set.delete x os)) 297 | 298 | upds :: [(Ident,Val)] -> Env -> Env 299 | upds xus rho = foldl (flip upd) rho xus 300 | 301 | updsTele :: Tele -> [Val] -> Env -> Env 302 | updsTele tele vs = upds (zip (map fst tele) vs) 303 | 304 | subs :: [(Name,II)] -> Env -> Env 305 | subs iphis rho = foldl (flip sub) rho iphis 306 | 307 | mapEnv :: (Val -> Val) -> (II -> II) -> Env -> Env 308 | mapEnv f g (Env (rho,vs,fs,os)) = Env (rho,map f vs,map g fs,os) 309 | 310 | valAndIIOfEnv :: Env -> ([Val],[II]) 311 | valAndIIOfEnv (Env (_,vs,fs,_)) = (vs,fs) 312 | 313 | valOfEnv :: Env -> [Val] 314 | valOfEnv = fst . valAndIIOfEnv 315 | 316 | formulaOfEnv :: Env -> [II] 317 | formulaOfEnv = snd . valAndIIOfEnv 318 | 319 | domainEnv :: Env -> [Name] 320 | domainEnv (Env (rho,_,_,_)) = domCtxt rho 321 | where domCtxt rho = case rho of 322 | Empty -> [] 323 | Upd _ e -> domCtxt e 324 | Def _ ts e -> domCtxt e 325 | Sub i e -> i : domCtxt e 326 | 327 | -- Extract the context from the environment, used when printing holes 328 | contextOfEnv :: Env -> [String] 329 | contextOfEnv rho = case rho of 330 | Env (Empty,_,_,_) -> [] 331 | Env (Upd x e,VVar n t:vs,fs,os) -> (n ++ " : " ++ show t) : contextOfEnv (Env (e,vs,fs,os)) 332 | Env (Upd x e,v:vs,fs,os) -> (x ++ " = " ++ show v) : contextOfEnv (Env (e,vs,fs,os)) 333 | Env (Def _ _ e,vs,fs,os) -> contextOfEnv (Env (e,vs,fs,os)) 334 | Env (Sub i e,vs,phi:fs,os) -> (show i ++ " = " ++ show phi) : contextOfEnv (Env (e,vs,fs,os)) 335 | 336 | -------------------------------------------------------------------------------- 337 | -- | Pretty printing 338 | 339 | instance Show Env where 340 | show = render . showEnv True 341 | 342 | showEnv :: Bool -> Env -> Doc 343 | showEnv b e = 344 | let -- This decides if we should print "x = " or not 345 | names x = if b then text x <+> equals else PP.empty 346 | par x = if b then parens x else x 347 | com = if b then comma else PP.empty 348 | showEnv1 e = case e of 349 | Env (Upd x env,u:us,fs,os) -> 350 | showEnv1 (Env (env,us,fs,os)) <+> names x <+> showVal1 u <> com 351 | Env (Sub i env,us,phi:fs,os) -> 352 | showEnv1 (Env (env,us,fs,os)) <+> names (show i) <+> text (show phi) <> com 353 | Env (Def _ _ env,vs,fs,os) -> showEnv1 (Env (env,vs,fs,os)) 354 | _ -> showEnv b e 355 | in case e of 356 | Env (Empty,_,_,_) -> PP.empty 357 | Env (Def _ _ env,vs,fs,os) -> showEnv b (Env (env,vs,fs,os)) 358 | Env (Upd x env,u:us,fs,os) -> 359 | par $ showEnv1 (Env (env,us,fs,os)) <+> names x <+> showVal1 u 360 | Env (Sub i env,us,phi:fs,os) -> 361 | par $ showEnv1 (Env (env,us,fs,os)) <+> names (show i) <+> text (show phi) 362 | 363 | instance Show Loc where 364 | show = render . showLoc 365 | 366 | showLoc :: Loc -> Doc 367 | showLoc (Loc name (i,j)) = text (show (i,j) ++ " in " ++ name) 368 | 369 | showII :: II -> Doc 370 | showII = text . show 371 | 372 | instance Show Ter where 373 | show = render . showTer 374 | 375 | showTer :: Ter -> Doc 376 | showTer v = case v of 377 | U -> char 'U' 378 | App e0 e1 -> showTer e0 <+> showTer1 e1 379 | Pi e0 -> text "Pi" <+> showTer e0 380 | Lam x t e -> 381 | char '\\' <> parens (text x <+> colon <+> showTer t) <+> text " ->" <+> showTer e 382 | Fst e -> showTer1 e <> text ".1" 383 | Snd e -> showTer1 e <> text ".2" 384 | Sigma e0 -> text "Sigma" <+> showTer1 e0 385 | Pair e0 e1 -> parens (showTer e0 <> comma <> showTer e1) 386 | Where e d -> showTer e <+> text "where" <+> showDecls d 387 | Var x -> text x 388 | Con c es -> text c <+> showTers es 389 | PCon c a es phis -> 390 | text c <+> braces (showTer a) <+> showTers es <+> hsep (map ((char '@' <+>) . showII) phis) 391 | Split f _ _ _ -> text f 392 | Sum _ n _ -> text n 393 | HSum _ n _ -> text n 394 | Undef{} -> text "undefined" 395 | Hole{} -> text "?" 396 | PathP e0 e1 e2 -> text "PathP" <+> showTers [e0,e1,e2] 397 | LineP e -> text "LineP" <+> showTer e 398 | PLam i e -> char '<' <> text (show i) <> char '>' <+> showTer e 399 | AppII e phi -> showTer1 e <+> char '@' <+> showII phi 400 | Com r s a ts t -> 401 | text "com" <+> showII r <> text "->" <> showII s <+> showTer1 a <+> text (show ts) <+> showTer1 t 402 | HCom r s a ts t -> 403 | text "hcom" <+> showII r <> text "->" <> showII s <+> showTer1 a <+> text (show ts) <+> showTer1 t 404 | Coe r s e t0 -> 405 | text "coe" <+> showII r <> text "->" <> showII s <+> showTer1 e <+> showTer1 t0 406 | -- Comp e t ts -> text "comp" <+> showTers [e,t] <+> text (show ts) 407 | V r a b e -> text "V" <+> showII r <+> showTers [a,b,e] 408 | Vin r m n -> text "Vin" <+> showII r <+> showTers [m,n] 409 | Vproj r o a b e -> text "Vproj" <+> showII r <+> showTers [o,a,b,e] 410 | Box r s ts t -> 411 | text "box" <+> showII r <> text "->" <> showII s <+> text (show ts) <+> showTer1 t 412 | Cap r s ts t -> 413 | text "cap" <+> showII r <> text "<-" <> showII s <+> text (show ts) <+> showTer1 t 414 | -- Glue a ts -> text "Glue" <+> showTer1 a <+> text (show ts) 415 | -- GlueElem a ts -> text "glue" <+> showTer1 a <+> text (show ts) 416 | -- UnGlueElem a b ts -> text "unglue" <+> showTers [a,b] <+> text (show ts) 417 | 418 | showTers :: [Ter] -> Doc 419 | showTers = hsep . map showTer1 420 | 421 | showTer1 :: Ter -> Doc 422 | showTer1 t = case t of 423 | U -> char 'U' 424 | Con c [] -> text c 425 | Var{} -> showTer t 426 | Undef{} -> showTer t 427 | Hole{} -> showTer t 428 | Split{} -> showTer t 429 | Sum{} -> showTer t 430 | HSum{} -> showTer t 431 | Fst{} -> showTer t 432 | Snd{} -> showTer t 433 | _ -> parens (showTer t) 434 | 435 | showDecls :: Decls -> Doc 436 | showDecls (MutualDecls _ defs) = 437 | hsep $ punctuate comma 438 | [ text x <+> equals <+> showTer d | (x,(_,d)) <- defs ] 439 | showDecls (OpaqueDecl i) = text "opaque" <+> text i 440 | showDecls (TransparentDecl i) = text "transparent" <+> text i 441 | showDecls TransparentAllDecl = text "transparent_all" 442 | 443 | instance Show Val where 444 | show = render . showVal 445 | 446 | showVal :: Val -> Doc 447 | showVal v = case v of 448 | VU -> char 'U' 449 | Ter t@Sum{} rho -> showTer t <+> showEnv False rho 450 | Ter t@HSum{} rho -> showTer t <+> showEnv False rho 451 | Ter t@Split{} rho -> showTer t <+> showEnv False rho 452 | Ter t rho -> showTer1 t <+> showEnv True rho 453 | VCon c us -> text c <+> showVals us 454 | VPCon c a us phis -> text c <+> braces (showVal a) <+> showVals us <+> hsep (map ((char '@' <+>) . showII) phis) 455 | VHCom r s v0 vs v1 -> text "hcom" <+> showII r <> text "->" <> showII s <+> showVal1 v0 <+> text (show vs) <+> showVal1 v1 456 | VCoe r s u v0 -> text "coe" <+> showII r <> text "->" <> showII s <+> showVal1 u <+> showVal1 v0 457 | VPi a l@(VLam x t b) 458 | | "_" `isPrefixOf` x -> showVal1 a <+> text "->" <+> showVal1 b 459 | | otherwise -> char '(' <> showLam v 460 | VPi a b -> text "Pi" <+> showVals [a,b] 461 | VPair u v -> parens (showVal u <> comma <> showVal v) 462 | VSigma u v -> text "Sigma" <+> showVals [u,v] 463 | VApp u v -> showVal u <+> showVal1 v 464 | VLam{} -> text "\\(" <> showLam v 465 | VPLam{} -> char '<' <> showPLam v 466 | VSplit u v -> showVal u <+> showVal1 v 467 | VVar x _ -> text x 468 | VOpaque x _ -> text ('#':x) 469 | VFst u -> showVal1 u <> text ".1" 470 | VSnd u -> showVal1 u <> text ".2" 471 | VPathP v0 v1 v2 -> text "PathP" <+> showVals [v0,v1,v2] 472 | VLineP v -> text "LineP" <+> showVal v 473 | VAppII v phi -> showVal v <+> char '@' <+> showII phi 474 | VV i a b e -> text "V" <+> text (show i) <+> showVals [a,b,e] 475 | VVin i m n -> text "Vin" <+> text (show i) <+> showVals [m,n] 476 | VVproj i o a b e -> text "Vproj" <+> text (show i) <+> showVals [o,a,b,e] 477 | VBox r s ts t -> 478 | text "box" <+> showII r <> text "->" <> showII s <+> text (show ts) <+> showVal1 t 479 | VCap r s ts t -> 480 | text "cap" <+> showII r <> text "<-" <> showII s <+> text (show ts) <+> showVal1 t 481 | VHComU r s ts t -> 482 | text "hcomp U" <+> showII r <> text "->" <> showII s <+> text (show ts) <+> showVal1 t 483 | -- VGlue a ts -> text "Glue" <+> showVal1 a <+> text (show ts) 484 | -- VGlueElem a ts -> text "glue" <+> showVal1 a <+> text (show ts) 485 | -- VUnGlueElem v a ts -> text "unglue" <+> showVals [v,a] <+> text (show ts) 486 | -- VUnGlueElemU v b es -> text "unglue U" <+> showVals [v,b] <+> text (show es) 487 | 488 | showPLam :: Val -> Doc 489 | showPLam e = case e of 490 | VPLam i a@VPLam{} -> text (show i) <+> showPLam a 491 | VPLam i a -> text (show i) <> char '>' <+> showVal a 492 | _ -> showVal e 493 | 494 | -- Merge lambdas of the same type 495 | showLam :: Val -> Doc 496 | showLam e = case e of 497 | VLam x t a@(VLam _ t' _) 498 | | t == t' -> text x <+> showLam a 499 | | otherwise -> 500 | text x <+> colon <+> showVal t <> char ')' <+> text "->" <+> showVal a 501 | VPi _ (VLam x t a@(VPi _ (VLam _ t' _))) 502 | | t == t' -> text x <+> showLam a 503 | | otherwise -> 504 | text x <+> colon <+> showVal t <> char ')' <+> text "->" <+> showVal a 505 | VLam x t e -> 506 | text x <+> colon <+> showVal t <> char ')' <+> text "->" <+> showVal e 507 | VPi _ (VLam x t e) -> 508 | text x <+> colon <+> showVal t <> char ')' <+> text "->" <+> showVal e 509 | _ -> showVal e 510 | 511 | showVal1 :: Val -> Doc 512 | showVal1 v = case v of 513 | VU -> showVal v 514 | VCon c [] -> showVal v 515 | VVar{} -> showVal v 516 | VFst{} -> showVal v 517 | VSnd{} -> showVal v 518 | Ter t rho | isEmpty (showEnv False rho) -> showTer1 t 519 | _ -> parens (showVal v) 520 | 521 | showVals :: [Val] -> Doc 522 | showVals = hsep . map showVal1 523 | -------------------------------------------------------------------------------- /Cartesian.hs: -------------------------------------------------------------------------------- 1 | -- Random stuff that we need for Cartesian cubicaltt 2 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, 3 | GeneralizedNewtypeDeriving, TupleSections #-} 4 | module Cartesian where 5 | 6 | import Control.Applicative 7 | import Control.Monad.Gen 8 | import Data.List 9 | import qualified Data.Map as Map 10 | import Data.Maybe 11 | import qualified Data.Traversable as T 12 | 13 | -- The evaluation monad 14 | type Eval a = GenT Int IO a 15 | 16 | runEval :: Eval a -> IO a 17 | runEval = runGenT 18 | 19 | data Name = N String 20 | | Gen {-# UNPACK #-} !Int 21 | deriving (Eq,Ord) 22 | 23 | instance Show Name where 24 | show (N i) = i 25 | show (Gen x) = 'i' : show x 26 | 27 | swapName :: Name -> (Name,Name) -> Name 28 | swapName k (i,j) | k == i = j 29 | | k == j = i 30 | | otherwise = k 31 | 32 | -- | Directions 33 | 34 | -- Maybe merge with II? 35 | data Dir = Zero | One 36 | deriving (Eq,Ord) 37 | 38 | instance Show Dir where 39 | show Zero = "0" 40 | show One = "1" 41 | 42 | instance Num Dir where 43 | Zero + Zero = Zero 44 | _ + _ = One 45 | 46 | Zero * _ = Zero 47 | One * x = x 48 | 49 | abs = id 50 | signum _ = One 51 | 52 | negate Zero = One 53 | negate One = Zero 54 | 55 | fromInteger 0 = Zero 56 | fromInteger 1 = One 57 | fromInteger _ = error "fromInteger Dir" 58 | 59 | -- | Interval 60 | 61 | data II = Dir Dir 62 | | Name Name 63 | deriving (Eq,Ord) 64 | 65 | instance Show II where 66 | show (Dir x) = show x 67 | show (Name x) = show x 68 | 69 | class ToII a where 70 | toII :: a -> II 71 | 72 | instance ToII II where 73 | toII = id 74 | 75 | instance ToII Name where 76 | toII = Name 77 | 78 | instance ToII Dir where 79 | toII = Dir 80 | 81 | -- This is a bit of a hack 82 | instance Num II where 83 | (+) = undefined 84 | (*) = undefined 85 | abs = undefined 86 | signum = undefined 87 | negate= undefined 88 | fromInteger 0 = Dir Zero 89 | fromInteger 1 = Dir One 90 | fromInteger _ = error "fromInteger Dir" 91 | 92 | -- | Equations 93 | 94 | -- Invariant: Eqn r s means r >= s 95 | -- Important: Name > Dir 96 | data Eqn = Eqn II II 97 | deriving (Eq,Ord) 98 | 99 | eqn :: (II,II) -> Eqn 100 | eqn (r,s) = Eqn (max r s) (min r s) 101 | 102 | isConsistent :: Eqn -> Bool 103 | isConsistent (Eqn (Dir Zero) (Dir One)) = False -- This is not necessary 104 | isConsistent (Eqn (Dir One) (Dir Zero)) = False 105 | isConsistent _ = True 106 | 107 | instance Show Eqn where 108 | show (Eqn r s) = "(" ++ show r ++ " = " ++ show s ++ ")" 109 | 110 | -- Check if two equations are compatible 111 | compatible :: Eqn -> Eqn -> Bool 112 | compatible (Eqn i (Dir d)) (Eqn j (Dir d')) | i == j = d == d' 113 | compatible _ _ = True 114 | 115 | allCompatible :: [Eqn] -> [(Eqn,Eqn)] 116 | allCompatible [] = [] 117 | allCompatible (f:fs) = map (f,) (filter (compatible f) fs) ++ allCompatible fs 118 | 119 | (~>) :: ToII a => a -> II -> Eqn 120 | i ~> d = eqn (toII i,d) 121 | 122 | -- | Nominal 123 | 124 | class Nominal a where 125 | -- support :: a -> [Name] 126 | occurs :: Name -> a -> Bool 127 | -- occurs x v = x `elem` support v 128 | subst :: a -> (Name,II) -> Eval a 129 | swap :: a -> (Name,Name) -> a 130 | 131 | notOccurs :: Nominal a => Name -> a -> Bool 132 | notOccurs i x = not (i `occurs` x) 133 | 134 | fresh :: Eval Name 135 | fresh = do 136 | n <- gen 137 | return $ Gen n 138 | 139 | freshs :: Eval [Name] 140 | freshs = do 141 | n <- fresh 142 | ns <- freshs 143 | return (n : ns) 144 | 145 | newtype Nameless a = Nameless { unNameless :: a } 146 | deriving (Eq, Ord) 147 | 148 | instance Nominal (Nameless a) where 149 | -- support _ = [] 150 | occurs _ _ = False 151 | subst x _ = return x 152 | swap x _ = x 153 | 154 | instance Nominal () where 155 | -- support () = [] 156 | occurs _ _ = False 157 | subst () _ = return () 158 | swap () _ = () 159 | 160 | instance (Nominal a, Nominal b) => Nominal (a, b) where 161 | -- support (a, b) = support a `union` support b 162 | occurs x (a,b) = occurs x a || occurs x b 163 | subst (a,b) f = (,) <$> subst a f <*> subst b f 164 | swap (a,b) n = (swap a n,swap b n) 165 | 166 | instance (Nominal a, Nominal b, Nominal c) => Nominal (a, b, c) where 167 | -- support (a,b,c) = unions [support a, support b, support c] 168 | occurs x (a,b,c) = or [occurs x a,occurs x b,occurs x c] 169 | subst (a,b,c) f = do 170 | af <- subst a f 171 | bf <- subst b f 172 | cf <- subst c f 173 | return (af,bf,cf) 174 | swap (a,b,c) n = (swap a n,swap b n,swap c n) 175 | 176 | instance (Nominal a, Nominal b, Nominal c, Nominal d) => 177 | Nominal (a, b, c, d) where 178 | -- support (a,b,c,d) = unions [support a, support b, support c, support d] 179 | occurs x (a,b,c,d) = or [occurs x a,occurs x b,occurs x c,occurs x d] 180 | subst (a,b,c,d) f = do 181 | af <- subst a f 182 | bf <- subst b f 183 | cf <- subst c f 184 | df <- subst d f 185 | return (af,bf,cf,df) 186 | swap (a,b,c,d) n = (swap a n,swap b n,swap c n,swap d n) 187 | 188 | instance (Nominal a, Nominal b, Nominal c, Nominal d, Nominal e) => 189 | Nominal (a, b, c, d, e) where 190 | -- support (a,b,c,d,e) = 191 | -- unions [support a, support b, support c, support d, support e] 192 | occurs x (a,b,c,d,e) = 193 | or [occurs x a,occurs x b,occurs x c,occurs x d,occurs x e] 194 | subst (a,b,c,d,e) f = do 195 | af <- subst a f 196 | bf <- subst b f 197 | cf <- subst c f 198 | df <- subst d f 199 | ef <- subst e f 200 | return (af,bf,cf,df,ef) 201 | swap (a,b,c,d,e) n = 202 | (swap a n,swap b n,swap c n,swap d n,swap e n) 203 | 204 | instance (Nominal a, Nominal b, Nominal c, Nominal d, Nominal e, Nominal h) => 205 | Nominal (a, b, c, d, e, h) where 206 | -- support (a,b,c,d,e,h) = 207 | -- unions [support a, support b, support c, support d, support e, support h] 208 | occurs x (a,b,c,d,e,h) = 209 | or [occurs x a,occurs x b,occurs x c,occurs x d,occurs x e,occurs x h] 210 | subst (a,b,c,d,e,h) f = do 211 | af <- subst a f 212 | bf <- subst b f 213 | cf <- subst c f 214 | df <- subst d f 215 | ef <- subst e f 216 | hf <- subst h f 217 | return (af,bf,cf,df,ef,hf) 218 | swap (a,b,c,d,e,h) n = 219 | (swap a n,swap b n,swap c n,swap d n,swap e n,swap h n) 220 | 221 | instance Nominal a => Nominal [a] where 222 | -- support xs = unions (map support xs) 223 | occurs x xs = any (occurs x) xs 224 | subst xs f = T.sequence [ subst x f | x <- xs ] 225 | swap xs n = [ swap x n | x <- xs ] 226 | 227 | instance Nominal a => Nominal (Maybe a) where 228 | -- support = maybe [] support 229 | occurs x = maybe False (occurs x) 230 | subst v f = T.sequence (fmap (\y -> subst y f) v) 231 | swap a n = fmap (`swap` n) a 232 | 233 | instance Nominal II where 234 | -- support (Dir _) = [] 235 | -- support (Name i) = [i] 236 | 237 | occurs x (Dir _) = False 238 | occurs x (Name i) = x == i 239 | 240 | subst (Dir b) (i,r) = return $ Dir b 241 | subst (Name j) (i,r) | i == j = return r 242 | | otherwise = return $ Name j 243 | 244 | swap (Dir b) (i,j) = Dir b 245 | swap (Name k) (i,j) | k == i = Name j 246 | | k == j = Name i 247 | | otherwise = Name k 248 | 249 | instance Nominal Eqn where 250 | occurs x (Eqn r s) = occurs x r || occurs x s 251 | subst (Eqn r s) f = curry eqn <$> subst r f <*> subst s f 252 | swap (Eqn r s) f = eqn (swap r f, swap s f) 253 | 254 | supportII :: II -> [Name] 255 | supportII (Dir _) = [] 256 | supportII (Name i) = [i] 257 | 258 | -- Invariant: No false equations; turns into Triv if any true equations. 259 | data System a = Sys (Map.Map Eqn a) 260 | | Triv a 261 | deriving Eq 262 | 263 | instance Show a => Show (System a) where 264 | show (Sys xs) = case Map.toList xs of 265 | [] -> "[]" 266 | ts -> "[ " ++ intercalate ", " [ show alpha ++ " -> " ++ show u 267 | | (alpha,u) <- ts ] ++ " ]" 268 | show (Triv a) = "[ T -> " ++ show a ++ " ]" 269 | 270 | -- The empty system 271 | eps :: System a 272 | eps = Sys (Map.empty) 273 | 274 | -- relies on (and preserves) System invariant 275 | insertSystem :: (Eqn,a) -> System a -> System a 276 | insertSystem _ (Triv a) = Triv a 277 | insertSystem (eqn,a) (Sys xs) = case eqn of 278 | -- equation is always false 279 | Eqn (Dir One) (Dir Zero) -> Sys xs 280 | -- equation is always true 281 | Eqn r s | r == s -> Triv a 282 | -- otherwise 283 | Eqn r s -> Sys (Map.insert eqn a xs) 284 | 285 | insertsSystem :: [(Eqn,a)] -> System a -> System a 286 | insertsSystem xs sys = foldr insertSystem sys xs 287 | 288 | mkSystem :: [(Eqn,a)] -> System a 289 | mkSystem xs = insertsSystem xs eps 290 | 291 | mergeSystem :: System a -> System a -> System a 292 | mergeSystem (Triv x) _ = Triv x 293 | mergeSystem _ (Triv y) = Triv y 294 | mergeSystem (Sys xs) ys = Map.toList xs `insertsSystem` ys 295 | 296 | -- allSystem :: Name -> System a -> System a 297 | -- allSystem i (Sys xs) = Sys (Map.filterWithKey (\eqn _ -> i `occurs` eqn) xs) 298 | -- allSystem _ (Triv x) = Triv x 299 | 300 | -- notAllSystem :: Name -> System a -> System a 301 | -- notAllSystem i (Sys xs) = Sys (Map.filterWithKey (\eqn _ -> i `notOccurs` eqn) xs) 302 | -- notAllSystem _ (Triv x) = Triv x 303 | 304 | instance Nominal a => Nominal (System a) where 305 | occurs x (Sys xs) = Map.foldrWithKey fn False xs 306 | where fn eqn a accum = accum || occurs x eqn || occurs x a 307 | occurs x (Triv a) = occurs x a 308 | 309 | subst (Sys xs) f = 310 | mkSystem <$> mapM (\(eqn,a) -> (,) <$> subst eqn f <*> subst a f) (Map.assocs xs) 311 | subst (Triv x) f = Triv <$> subst x f 312 | 313 | swap (Sys xs) ij = Map.foldrWithKey fn eps xs 314 | where fn eqn a = insertSystem (swap eqn ij,swap a ij) 315 | swap (Triv a) ij = Triv (swap a ij) 316 | 317 | toSubst :: Eqn -> (Name,II) 318 | toSubst (Eqn (Name i) r) = (i,r) 319 | toSubst eqn = error $ "toSubst: encountered " ++ show eqn ++ " in system" 320 | 321 | face :: Nominal a => a -> Eqn -> Eval a 322 | face a (Eqn (Name (N "_")) (Name (N "_"))) = return a -- handle dummy case separately 323 | face a f = a `subst` toSubst f 324 | 325 | -- carve a using the same shape as the system b 326 | border :: a -> System b -> System a 327 | border v (Sys xs) = Sys (Map.map (const v) xs) 328 | border v (Triv _) = Triv v 329 | 330 | shape :: System a -> System () 331 | shape = border () 332 | 333 | intersectWith :: (a -> b -> c) -> System a -> System b -> System c 334 | intersectWith f (Triv x) (Triv y) = Triv (f x y) 335 | intersectWith f (Sys xs) (Sys ys) = Sys (Map.intersectionWith f xs ys) 336 | intersectWith _ _ _ = error "intersectWith not matching input" 337 | 338 | runSystem :: System (Eval a) -> Eval (System a) 339 | runSystem (Triv x) = Triv <$> x 340 | runSystem (Sys xs) = do 341 | xs' <- T.sequence xs 342 | return $ Sys xs' 343 | 344 | -- TODO: optimize so that we don't apply the face everywhere before computing this 345 | -- assumes alpha <= shape us 346 | -- proj :: (Nominal a, Show a) => System a -> (Name,II) -> a 347 | -- proj us ir = case us `subst` ir of 348 | -- Triv a -> a 349 | -- _ -> error "proj" 350 | 351 | eqnSupport :: System a -> [Name] 352 | eqnSupport (Triv _) = [] 353 | eqnSupport (Sys xs) = concatMap support (Map.keys xs) 354 | where support (Eqn (Name i) (Dir _)) = [i] 355 | support (Eqn (Name i) (Name j)) = [i,j] 356 | support eqn = error $ "eqnSupport: encountered " ++ show eqn ++ " in system" 357 | -------------------------------------------------------------------------------- /Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TupleSections #-} 2 | module Eval where 3 | 4 | import Debug.Trace 5 | import Control.Monad 6 | import Control.Monad.Gen 7 | import Data.List 8 | import qualified Data.Map as Map 9 | import qualified Data.Set as Set 10 | import qualified Data.Traversable as T 11 | 12 | import Cartesian 13 | import CTT 14 | 15 | debug :: Bool 16 | debug = False 17 | 18 | traceb :: String -> a -> a 19 | traceb s x = if debug then trace s x else x 20 | 21 | ----------------------------------------------------------------------- 22 | -- Lookup functions 23 | 24 | look :: String -> Env -> Eval Val 25 | look x (Env (Upd y rho,v:vs,fs,os)) | x == y = return v 26 | | otherwise = look x (Env (rho,vs,fs,os)) 27 | look x r@(Env (Def _ decls rho,vs,fs,Nameless os)) = case lookup x decls of 28 | Just (_,t) -> eval r t 29 | Nothing -> look x (Env (rho,vs,fs,Nameless os)) 30 | look x (Env (Sub _ rho,vs,_:fs,os)) = look x (Env (rho,vs,fs,os)) 31 | look x (Env (Empty,_,_,_)) = error $ "look: not found " ++ show x 32 | 33 | lookType :: String -> Env -> Eval Val 34 | lookType x (Env (Upd y rho,v:vs,fs,os)) 35 | | x /= y = lookType x (Env (rho,vs,fs,os)) 36 | | VVar _ a <- v = return a 37 | | otherwise = error "" 38 | lookType x r@(Env (Def _ decls rho,vs,fs,os)) = case lookup x decls of 39 | Just (a,_) -> eval r a 40 | Nothing -> lookType x (Env (rho,vs,fs,os)) 41 | lookType x (Env (Sub _ rho,vs,_:fs,os)) = lookType x (Env (rho,vs,fs,os)) 42 | lookType x (Env (Empty,_,_,_)) = error $ "lookType: not found " ++ show x 43 | 44 | lookName :: Name -> Env -> II 45 | lookName i (Env (Upd _ rho,v:vs,fs,os)) = lookName i (Env (rho,vs,fs,os)) 46 | lookName i (Env (Def _ _ rho,vs,fs,os)) = lookName i (Env (rho,vs,fs,os)) 47 | lookName i (Env (Sub j rho,vs,r:fs,os)) | i == j = r 48 | | otherwise = lookName i (Env (rho,vs,fs,os)) 49 | lookName i _ = error $ "lookName: not found " ++ show i 50 | 51 | 52 | ----------------------------------------------------------------------- 53 | -- Nominal instances 54 | 55 | instance Nominal Ctxt where 56 | occurs _ _ = False 57 | subst e _ = return e 58 | swap e _ = e 59 | 60 | instance Nominal Env where 61 | occurs x (Env (rho,vs,fs,os)) = occurs x (rho,vs,fs,os) 62 | subst (Env (rho,vs,fs,os)) iphi = do 63 | vs' <- subst vs iphi 64 | fs' <- subst fs iphi 65 | return $ Env (rho,vs',fs',os) 66 | swap (Env (rho,vs,fs,os)) ij = Env $ swap (rho,vs,fs,os) ij 67 | 68 | instance Nominal Val where 69 | occurs x v = case v of 70 | VU -> False 71 | Ter _ e -> occurs x e 72 | VPi u v -> occurs x (u,v) 73 | VPathP a v0 v1 -> occurs x [a,v0,v1] 74 | VLineP a -> occurs x a 75 | VPLam i v -> if x == i then False else occurs x v 76 | VSigma u v -> occurs x (u,v) 77 | VPair u v -> occurs x (u,v) 78 | VFst u -> occurs x u 79 | VSnd u -> occurs x u 80 | VCon _ vs -> occurs x vs 81 | VPCon _ a vs phis -> occurs x (a,vs,phis) 82 | VHCom r s a ts u -> occurs x (r,s,a,u,ts) 83 | VCoe r s a u -> occurs x (r,s,a,u) 84 | VVar _ v -> occurs x v 85 | VOpaque _ v -> occurs x v 86 | VApp u v -> occurs x (u,v) 87 | VLam _ u v -> occurs x (u,v) 88 | VAppII u phi -> occurs x (u,phi) 89 | VSplit u v -> occurs x (u,v) 90 | VV i a b e -> x == i || occurs x (a,b,e) 91 | VVin i m n -> x == i || occurs x (m,n) 92 | VVproj i o a b e -> x == i || occurs x (o,a,b,e) 93 | VHComU r s t ts -> occurs x (r,s,t,ts) 94 | VBox r s t ts -> occurs x (r,s,t,ts) 95 | VCap r s t ts -> occurs x (r,s,t,ts) 96 | 97 | subst u (i,r) | i `notOccurs` u = return u -- WARNING: this can be very bad! 98 | | otherwise = case u of 99 | VU -> return VU 100 | Ter t e -> Ter t <$> subst e (i,r) 101 | VPi a f -> VPi <$> subst a (i,r) <*> subst f (i,r) 102 | VPathP a u v -> VPathP <$> subst a (i,r) <*> subst u (i,r) <*> subst v (i,r) 103 | VLineP a -> VLineP <$> subst a (i,r) 104 | VPLam j v | j == i -> return u 105 | | not (j `occurs` r) -> VPLam j <$> subst v (i,r) 106 | | otherwise -> do 107 | k <- fresh 108 | VPLam k <$> subst (v `swap` (j,k)) (i,r) 109 | VSigma a f -> VSigma <$> subst a (i,r) <*> subst f (i,r) 110 | VPair u v -> VPair <$> subst u (i,r) <*> subst v (i,r) 111 | VFst u -> fstVal <$> subst u (i,r) 112 | VSnd u -> sndVal <$> subst u (i,r) 113 | VCon c vs -> VCon c <$> subst vs (i,r) 114 | VPCon c a vs phis -> join $ pcon c <$> subst a (i,r) <*> subst vs (i,r) <*> subst phis (i,r) 115 | VHCom s s' a us u0 -> join $ hcom <$> subst s (i,r) <*> subst s' (i,r) <*> subst a (i,r) <*> subst us (i,r) <*> subst u0 (i,r) 116 | VCoe s s' a u -> join $ coe <$> subst s (i,r) <*> subst s' (i,r) <*> subst a (i,r) <*> subst u (i,r) 117 | VVar x v -> VVar x <$> subst v (i,r) 118 | VOpaque x v -> VOpaque x <$> subst v (i,r) 119 | VAppII u s -> join $ (@@) <$> subst u (i,r) <*> subst s (i,r) 120 | VApp u v -> join $ app <$> subst u (i,r) <*> subst v (i,r) 121 | VLam x t u -> VLam x <$> subst t (i,r) <*> subst u (i,r) 122 | VSplit u v -> join $ app <$> subst u (i,r) <*> subst v (i,r) 123 | VV j a b e -> 124 | vtype <$> subst (Name j) (i,r) <*> subst a (i,r) <*> subst b (i,r) <*> subst e (i,r) 125 | VVin j m n -> 126 | vin <$> subst (Name j) (i,r) <*> subst m (i,r) <*> subst n (i,r) 127 | VVproj j o a b e -> 128 | join $ vproj <$> subst (Name j) (i,r) <*> subst o (i,r) <*> subst a (i,r) <*> subst b (i,r) <*> subst e (i,r) 129 | VHComU s s' ts t -> join $ hcomU <$> subst s (i,r) <*> subst s' (i,r) <*> subst ts (i,r) <*> subst t (i,r) 130 | VBox s s' ts t -> join $ box <$> subst s (i,r) <*> subst s' (i,r) <*> subst ts (i,r) <*> subst t (i,r) 131 | VCap s s' ts t -> join $ cap <$> subst s (i,r) <*> subst s' (i,r) <*> subst ts (i,r) <*> subst t (i,r) 132 | 133 | -- This increases efficiency as it won't trigger computation. 134 | swap u ij = 135 | let sw :: Nominal a => a -> a 136 | sw u = swap u ij 137 | in case u of 138 | VU -> VU 139 | Ter t e -> Ter t (sw e) 140 | VPi a f -> VPi (sw a) (sw f) 141 | VPathP a u v -> VPathP (sw a) (sw u) (sw v) 142 | VLineP a -> VLineP (sw a) 143 | VPLam k v -> VPLam (swapName k ij) (sw v) 144 | VSigma a f -> VSigma (sw a) (sw f) 145 | VPair u v -> VPair (sw u) (sw v) 146 | VFst u -> VFst (sw u) 147 | VSnd u -> VSnd (sw u) 148 | VCon c vs -> VCon c (sw vs) 149 | VPCon c a vs phis -> VPCon c (sw a) (sw vs) (sw phis) 150 | VHCom r s a us u -> VHCom (sw r) (sw s) (sw a) (sw us) (sw u) 151 | VCoe r s a u -> VCoe (sw r) (sw s) (sw a) (sw u) 152 | VVar x v -> VVar x (sw v) 153 | VOpaque x v -> VOpaque x (sw v) 154 | VAppII u psi -> VAppII (sw u) (sw psi) 155 | VApp u v -> VApp (sw u) (sw v) 156 | VLam x u v -> VLam x (sw u) (sw v) 157 | VSplit u v -> VSplit (sw u) (sw v) 158 | VV i a b e -> VV (swapName i ij) (sw a) (sw b) (sw e) 159 | VVin i m n -> VVin (swapName i ij) (sw m) (sw n) 160 | VVproj i o a b e -> VVproj (swapName i ij) (sw o) (sw a) (sw b) (sw e) 161 | VHComU s s' ts t -> VHComU (sw s) (sw s') (sw ts) (sw t) 162 | VBox s s' ts t -> VBox (sw s) (sw s') (sw ts) (sw t) 163 | VCap s s' ts t -> VCap (sw s) (sw s') (sw ts) (sw t) 164 | 165 | ----------------------------------------------------------------------- 166 | -- The evaluator 167 | 168 | eval :: Env -> Ter -> Eval Val 169 | eval rho@(Env (_,_,_,Nameless os)) v = case v of 170 | U -> return VU 171 | App r s -> join $ app <$> eval rho r <*> eval rho s 172 | Var i 173 | | i `Set.member` os -> VOpaque i <$> lookType i rho 174 | | otherwise -> look i rho 175 | Pi t@(Lam _ a _) -> VPi <$> eval rho a <*> eval rho t 176 | Sigma t@(Lam _ a _) -> VSigma <$> eval rho a <*> eval rho t 177 | Pair a b -> VPair <$> eval rho a <*> eval rho b 178 | Fst a -> fstVal <$> eval rho a 179 | Snd a -> sndVal <$> eval rho a 180 | Where t decls -> eval (defWhere decls rho) t 181 | Con name ts -> VCon name <$> mapM (eval rho) ts 182 | PCon name a ts phis -> 183 | join $ pcon name <$> eval rho a <*> mapM (eval rho) ts <*> pure (map (evalII rho) phis) 184 | Lam{} -> return $ Ter v rho 185 | Split{} -> return $ Ter v rho 186 | Sum{} -> return $ Ter v rho 187 | HSum{} -> return $ Ter v rho 188 | Undef{} -> return $ Ter v rho 189 | Hole{} -> return $ Ter v rho 190 | PathP a e0 e1 -> VPathP <$> eval rho a <*> eval rho e0 <*> eval rho e1 191 | LineP a -> VLineP <$> eval rho a 192 | PLam i t -> do 193 | j <- fresh 194 | VPLam j <$> eval (sub (i,Name j) rho) t 195 | AppII e phi -> join $ (@@) <$> eval rho e <*> pure (evalII rho phi) 196 | HCom r s a us u0 -> 197 | join $ hcom (evalII rho r) (evalII rho s) <$> eval rho a <*> evalSystem rho us <*> eval rho u0 198 | Com r s a us u0 -> 199 | join $ com (evalII rho r) (evalII rho s) <$> eval rho a <*> evalSystem rho us <*> eval rho u0 200 | Coe r s a t -> join $ coe (evalII rho r) (evalII rho s) <$> eval rho a <*> eval rho t 201 | -- Comp a t0 ts -> compLine (eval rho a) (eval rho t0) (evalSystem rho ts) 202 | V r a b e -> vtype (evalII rho r) <$> eval rho a <*> eval rho b <*> eval rho e 203 | Vin r m n -> vin (evalII rho r) <$> eval rho m <*> eval rho n 204 | Vproj r o a b e -> 205 | join $ vproj (evalII rho r) <$> eval rho o <*> eval rho a <*> eval rho b <*> eval rho e 206 | Box r s ts t -> join $ box (evalII rho r) (evalII rho s) <$> evalSystem rho ts <*> eval rho t 207 | Cap r s ts t -> join $ cap (evalII rho r) (evalII rho s) <$> evalSystem rho ts <*> eval rho t 208 | _ -> error $ "Cannot evaluate " ++ show v 209 | 210 | evals :: Env -> [(Ident,Ter)] -> Eval [(Ident,Val)] 211 | evals rho bts = mapM (\(b,t) -> (b,) <$> eval rho t) bts 212 | 213 | evalII :: Env -> II -> II 214 | evalII rho phi = case phi of 215 | Name i -> lookName i rho 216 | _ -> phi 217 | 218 | evalEqn :: Env -> Eqn -> Eqn 219 | evalEqn rho (Eqn r s) = eqn (evalII rho r,evalII rho s) 220 | 221 | evalSystem :: Env -> System Ter -> Eval (System Val) 222 | evalSystem rho (Triv u) = Triv <$> eval rho u 223 | evalSystem rho (Sys us) = 224 | case Map.foldrWithKey (\eqn u -> insertSystem (evalEqn rho eqn,u)) eps us of 225 | Triv u -> Triv <$> eval rho u 226 | Sys sys' -> do 227 | xs <- sequence $ Map.mapWithKey (\eqn u -> 228 | join $ eval <$> rho `face` eqn <*> pure u) sys' 229 | return $ Sys xs 230 | 231 | app :: Val -> Val -> Eval Val 232 | app u v = case (u,v) of 233 | (Ter (Lam x _ t) e,_) -> eval (upd (x,v) e) t 234 | (Ter (Split _ _ _ nvs) e,VCon c vs) -> case lookupBranch c nvs of 235 | Just (OBranch _ xs t) -> eval (upds (zip xs vs) e) t 236 | _ -> error $ "app: missing case in split for " ++ c 237 | (Ter (Split _ _ _ nvs) e,VPCon c _ us phis) -> case lookupBranch c nvs of 238 | Just (PBranch _ xs is t) -> eval (subs (zip is phis) (upds (zip xs us) e)) t 239 | _ -> error $ "app: missing case in split for " ++ c 240 | (Ter (Split _ _ ty _) e,VHCom r s a ws w) -> 241 | traceb "split hcom" $ eval e ty >>= \x -> case x of 242 | VPi _ f -> do 243 | j <- fresh 244 | fill <- hcom r (Name j) a ws w 245 | ffill <- VPLam j <$> app f fill 246 | w' <- app u w 247 | ws' <- mapSystem (\alpha _ w -> do u' <- u `face` alpha 248 | app u' w) ws 249 | com r s ffill ws' w' 250 | _ -> error $ "app: Split annotation not a Pi type " ++ show u 251 | (Ter Split{} _,_) -- | isNeutral v 252 | -> return (VSplit u v) 253 | (VCoe r s (VPLam i (VPi a b)) u0, v) -> traceb "coe pi" $ do 254 | j <- fresh 255 | let bij = b `swap` (i,j) 256 | w <- coe s (Name j) (VPLam i a) v 257 | w0 <- coe s r (VPLam i a) v 258 | bijw <- VPLam j <$> app bij w 259 | coe r s bijw =<< app u0 w0 260 | (VHCom r s (VPi a b) us u0, v) -> traceb "hcom pi" $ do 261 | us' <- mapSystem (\alpha _ u -> app u =<< (v `face` alpha)) us 262 | join $ hcom r s <$> app b v <*> pure us' <*> app u0 v 263 | (VHCom _ _ _ (Triv u) _, v) -> error "app: trying to apply vhcom in triv" 264 | _ -> return $ VApp u v -- error $ "app \n " ++ show u ++ "\n " ++ show v 265 | 266 | fstVal, sndVal :: Val -> Val 267 | fstVal (VPair a b) = a 268 | -- fstVal u | isNeutral u = VFst u 269 | fstVal u = VFst u -- error $ "fstVal: " ++ show u ++ " is not neutral." 270 | sndVal (VPair a b) = b 271 | -- sndVal u | isNeutral u = VSnd u 272 | sndVal u = VSnd u -- error $ "sndVal: " ++ show u ++ " is not neutral." 273 | 274 | -- infer the type of a neutral value 275 | inferType :: Val -> Eval Val 276 | inferType v = case v of 277 | VVar _ t -> return t 278 | VOpaque _ t -> return t 279 | Ter (Undef _ t) rho -> eval rho t 280 | VFst t -> inferType t >>= \t' -> case t' of -- LambdaCase? 281 | VSigma a _ -> return a 282 | ty -> error $ "inferType: expected Sigma type for " ++ show v 283 | ++ ", got " ++ show ty 284 | VSnd t -> inferType t >>= \t' -> case t' of 285 | VSigma _ f -> app f (VFst t) 286 | ty -> error $ "inferType: expected Sigma type for " ++ show v 287 | ++ ", got " ++ show ty 288 | VSplit s@(Ter (Split _ _ t _) rho) v1 -> eval rho t >>= \t' -> case t' of 289 | VPi _ f -> app f v1 290 | ty -> error $ "inferType: Pi type expected for split annotation in " 291 | ++ show v ++ ", got " ++ show ty 292 | VApp t0 t1 -> inferType t0 >>= \t' -> case t' of 293 | VPi _ f -> app f t1 294 | ty -> error $ "inferType: expected Pi type for " ++ show v 295 | ++ ", got " ++ show ty 296 | VAppII t r -> inferType t >>= \t' -> case t' of 297 | VPathP a _ _ -> a @@ r 298 | VLineP a -> a @@ r 299 | ty -> error $ "inferType: expected PathP/LineP type for " ++ show v 300 | ++ ", got " ++ show ty 301 | VHCom r s a _ _ -> return a 302 | VCoe r s a _ -> a @@ s 303 | VVproj _ _ _ b _ -> return b 304 | VHComU _ _ _ _ -> return VU 305 | VCap _ _ _ t -> inferType t >>= \t' -> case t' of 306 | VHComU _ _ _ a -> return a 307 | ty -> error $ "inferType: expected VHComU type for " ++ show v 308 | ++ ", got " ++ show ty 309 | _ -> error $ "inferType: not neutral " ++ show v 310 | 311 | (@@) :: ToII a => Val -> a -> Eval Val 312 | (VPLam i u) @@ phi = u `subst` (i,toII phi) 313 | v@(Ter Hole{} _) @@ phi = return $ VAppII v (toII phi) 314 | v @@ phi = do 315 | t <- inferType v 316 | case (t,toII phi) of 317 | (VPathP _ a0 _,Dir 0) -> return a0 318 | (VPathP _ _ a1,Dir 1) -> return a1 319 | _ -> return $ VAppII v (toII phi) 320 | -- v @@ phi = error $ "(@@): " ++ show v ++ " should be neutral." 321 | 322 | ------------------------------------------------------------------------------- 323 | -- com and hcom 324 | 325 | com :: II -> II -> Val -> System Val -> Val -> Eval Val 326 | com r s a _ u0 | r == s = return u0 327 | com _ s _ (Triv u) _ = u @@ s 328 | com r s a us u0 = do 329 | us' <- mapSystem (\alpha j u -> a `face` alpha >>= \a' -> coe (Name j) s a' u) us 330 | join $ hcom r s <$> a @@ s <*> pure us' <*> coe r s a u0 331 | 332 | -- apply f to each face, eta-expanding where needed, without freshening 333 | mapSystemUnsafe :: (Eqn -> Val -> Eval Val) -> System Val -> Eval (System Val) 334 | mapSystemUnsafe f us = do 335 | j <- fresh 336 | let etaMap e (VPLam i u) = VPLam i <$> f e u 337 | etaMap e u = do 338 | uj <- u @@ j 339 | VPLam j <$> f e uj 340 | case us of 341 | Sys us -> do bs <- T.sequence $ Map.mapWithKey etaMap us 342 | return (Sys bs) 343 | Triv u -> Triv <$> etaMap (eqn (Name (N "_"),Name (N "_"))) u 344 | 345 | -- apply f to each face, with binder, with freshening 346 | mapSystem :: (Eqn -> Name -> Val -> Eval Val) -> System Val -> Eval (System Val) 347 | mapSystem f us = do 348 | j <- fresh 349 | let etaMap e (VPLam i u) = VPLam j <$> f e j (u `swap` (i,j)) 350 | etaMap e u = do 351 | uj <- u @@ j 352 | VPLam j <$> f e j uj 353 | case us of 354 | Sys us -> do bs <- T.sequence $ Map.mapWithKey etaMap us 355 | return (Sys bs) 356 | Triv u -> Triv <$> etaMap (eqn (Name (N "_"),Name (N "_"))) u 357 | 358 | mapSystemNoEta :: (Eqn -> Val -> Eval Val) -> System Val -> Eval (System Val) 359 | mapSystemNoEta f (Sys us) = runSystem $ Sys $ Map.mapWithKey (\alpha u -> f alpha u) us 360 | mapSystemNoEta f (Triv u) = runSystem $ Triv $ f (eqn (Name (N "_"),Name (N "_"))) u 361 | 362 | hcom :: II -> II -> Val -> System Val -> Val -> Eval Val 363 | hcom r s _ _ u0 | r == s = return u0 364 | hcom r s _ (Triv u) _ = u @@ s 365 | hcom r s a us u0 = case a of 366 | VPathP a v0 v1 -> traceb "hcom path" $ do 367 | j <- fresh 368 | us' <- insertsSystem [(j~>0,VPLam (N "_") v0),(j~>1,VPLam (N "_") v1)] <$> 369 | mapSystemUnsafe (const (@@ j)) us 370 | aj <- a @@ j 371 | u0j <- u0 @@ j 372 | VPLam j <$> hcom r s aj us' u0j 373 | VLineP a -> traceb "hcom line" $ do 374 | j <- fresh 375 | us' <- mapSystemUnsafe (const (@@ j)) us 376 | aj <- a @@ j 377 | u0j <- u0 @@ j 378 | VPLam j <$> hcom r s aj us' u0j 379 | VSigma a b -> traceb "hcom sigma" $ do 380 | j <- fresh 381 | us1 <- mapSystemUnsafe (const (return . fstVal)) us 382 | us2 <- mapSystemUnsafe (const (return . sndVal)) us 383 | let (u1,u2) = (fstVal u0,sndVal u0) 384 | u1fill <- hcom r (Name j) a us1 u1 385 | u1hcom <- hcom r s a us1 u1 386 | bj <- VPLam j <$> app b u1fill 387 | VPair u1hcom <$> com r s bj us2 u2 388 | VU -> hcomU r s us u0 389 | v@VV{} -> vvhcom v r s us u0 390 | v@VHComU{} -> hcomHComU v r s us u0 391 | Ter (Sum _ n nass) env 392 | | n `elem` ["nat","Z","bool"] -> return u0 -- hardcode hack 393 | -- Ter (Sum _ _ nass) env -- | VCon n vs <- u0, all isCon (elems us) 394 | -- -> error "hcom sum" 395 | -- Ter (HSum _ _ _) _ -> error "hcom hsum" -- return $ VHCom r s a (Sys us) u0 396 | VPi{} -> return $ VHCom r s a us u0 397 | _ -> -- error "hcom: undefined case" 398 | return $ VHCom r s a us u0 399 | 400 | ----------------------------------------------------------- 401 | -- Coe 402 | 403 | coe :: II -> II -> Val -> Val -> Eval Val 404 | coe r s a u | r == s = return u 405 | coe r s (VPLam i a) u = case a of 406 | VPathP a v0 v1 -> traceb "coe path" $ do 407 | j <- fresh 408 | aij <- VPLam i <$> (a @@ j) 409 | out <- join $ com r s aij (mkSystem [(j~>0,VPLam i v0),(j~>1,VPLam i v1)]) <$> u @@ j 410 | return $ VPLam j out 411 | VLineP a -> traceb "coe line" $ do 412 | j <- fresh 413 | aij <- VPLam i <$> (a @@ j) 414 | out <- join $ coe r s aij <$> u @@ j 415 | return $ VPLam j out 416 | VSigma a b -> traceb "coe sigma" $ do 417 | j <- fresh 418 | let (u1,u2) = (fstVal u, sndVal u) 419 | u1' <- coe r (Name j) (VPLam i a) u1 420 | bij <- app (b `swap` (i,j)) u1' 421 | v1 <- coe r s (VPLam i a) u1 422 | v2 <- coe r s (VPLam j bij) u2 423 | return $ VPair v1 v2 424 | VPi{} -> return $ VCoe r s (VPLam i a) u 425 | VU -> return u 426 | v@VHComU{} -> coeHComU (VPLam i v) r s u 427 | v@VV{} -> vvcoe (VPLam i v) r s u 428 | Ter (Sum _ n nass) env 429 | | n `elem` ["nat","Z","bool"] -> return u -- hardcode hack 430 | | otherwise -> error $ "coe sum: " ++ show n 431 | Ter (HSum _ n nass) env 432 | | n `elem` ["S1","S2","S3"] -> return u -- hardcode hack 433 | | otherwise -> error "coe hsum" 434 | _ -> -- error "missing case in coe" -- 435 | return $ VCoe r s (VPLam i a) u 436 | coe r s a u = return $ VCoe r s a u 437 | 438 | ------------------------------------------------------------------------------- 439 | -- | HITs 440 | 441 | pcon :: LIdent -> Val -> [Val] -> [II] -> Eval Val 442 | pcon c a@(Ter (HSum _ _ lbls) rho) us phis = case lookupPLabel c lbls of 443 | Just (tele,is,ts) -> evalSystem (subs (zip is phis) (updsTele tele us rho)) ts >>= \t' -> case t' of 444 | Triv x -> return x 445 | _ -> return $ VPCon c a us phis 446 | Nothing -> error "pcon" 447 | pcon c a us phi = return $ VPCon c a us phi 448 | 449 | 450 | ------------------------------------------------------------------------------- 451 | -- | V-types 452 | 453 | -- TODO: eta for V-types? 454 | 455 | -- We are currently using RedPRL/UniMath style equiv between A and B: 456 | -- f : A -> B 457 | -- p : (x : B) -> isContr ((y : A) * Path B (f y) x) 458 | -- with isContr C = (s : C) * ((z : C) -> Path C z s) 459 | 460 | equivFun :: Val -> Val 461 | equivFun = fstVal 462 | 463 | equivContr :: Val -> Val 464 | equivContr = sndVal 465 | 466 | vtype :: II -> Val -> Val -> Val -> Val 467 | vtype (Dir Zero) a _ _ = a 468 | vtype (Dir One) _ b _ = b 469 | vtype (Name i) a b e = VV i a b e 470 | 471 | vin :: II -> Val -> Val -> Val 472 | vin (Dir Zero) m _ = m 473 | vin (Dir One) _ n = n 474 | vin (Name i) m (VVproj j o _ _ _) | i == j = o -- TODO? 475 | vin (Name i) m n = VVin i m n 476 | 477 | vproj :: II -> Val -> Val -> Val -> Val -> Eval Val 478 | vproj (Dir Zero) o _ _ e = app (equivFun e) o 479 | vproj (Dir One) o _ _ _ = return o 480 | vproj (Name i) x@(VVin j m n) _ _ _ 481 | | i == j = return n 482 | | otherwise = error $ "vproj: " ++ show i ++ " and " ++ show x 483 | vproj (Name i) o a b e = return $ VVproj i o a b e 484 | 485 | 486 | -- Coe for V-types 487 | vvcoe :: Val -> II -> II -> Val -> Eval Val 488 | vvcoe (VPLam i (VV j a b e)) r s m | i /= j = traceb "vvcoe i != j" $ do 489 | vj0 <- VApp (equivFun e) (VCoe r (Name i) (VPLam i a) m) `subst` (j,0) 490 | vj1 <- VCoe r (Name i) (VPLam i b) m `subst` (j,1) 491 | let tvec = mkSystem [(j~>0,VPLam i vj0),(j~>1,VPLam i vj1)] 492 | (ar,br,er) <- (a,b,e) `subst` (i,r) 493 | vr <- vproj (Name j) m ar br er 494 | vin (Name j) <$> coe r s (VPLam i a) m 495 | <*> com r s (VPLam i b) tvec vr 496 | vvcoe (VPLam i (VV j a b e)) r s m | i == j = traceb "vvcoe i == j" $ do 497 | (ar,br,er) <- (a,b,e) `subst` (i,r) 498 | (as,bs,es) <- (a,b,e) `subst` (i,s) 499 | m' <- vproj r m ar br er 500 | n <- coe r s (VPLam i b) m' 501 | c <- app (equivContr es) n 502 | let fibty = VSigma as (VLam "a" as (VPathP (VPLam (N "_") bs) (VApp (VFst es) (VVar "a" as)) n)) 503 | -- This is kinda bad, how to implement it properly? 504 | osys <- case r of 505 | Dir Zero -> Triv `liftM` app (sndVal c) (VPair m n) 506 | Dir One -> return eps 507 | _ -> do or0 <- (VApp (sndVal c) (VPair m n)) `face` (eqn (r,0)) 508 | return $ mkSystem [(r~>0,or0)] 509 | o <- hcom 1 0 fibty osys (fstVal c) 510 | -- TODO: we probably need to take appropriate faces in the branches 511 | p <- hcom 1 0 bs (mkSystem [(s~>0,sndVal o),(s~>1,VPLam (N "_") n),(eqn (r,s),VPLam (N "_") m')]) n 512 | return $ vin s (fstVal o) p 513 | vvcoe _ _ _ _ = error "vvcoe: case not implemented" 514 | 515 | -- hcom for V-types 516 | vvhcom :: Val -> II -> II -> System Val -> Val -> Eval Val 517 | vvhcom (VV i a b e) r s us m = traceb "vvhcom" $ do 518 | j <- fresh 519 | -- i can occur in e and a 520 | ti0 <- VPLam j <$> (VApp (equivFun e) (VHCom r (Name j) a us m)) `subst` (i,0) 521 | ti1 <- VPLam j <$> (VHCom r (Name j) b us m) `subst` (i,1) 522 | let tvec = [(i~>0,ti0),(i~>1,ti1)] 523 | us' <- mapSystem (\alpha _ n -> (VVproj i n a b e) `face` alpha) us 524 | m' <- vproj (Name i) m a b e 525 | vin (Name i) <$> hcom r s a us m 526 | <*> hcom r s b (insertsSystem tvec us') m' 527 | vvhcom _ _ _ _ _ = error "vvhcom: case not implemented" 528 | 529 | ------------------------------------------------------------------------------- 530 | -- | Universe 531 | 532 | -- TODO: eta for box/cap? 533 | 534 | -- This doesn't have to be monadic 535 | box :: II -> II -> System Val -> Val -> Eval Val 536 | box r s _ m | r == s = return m 537 | box _ s (Triv t) _ = return t 538 | box r s ts m = return $ VBox r s ts m 539 | 540 | cap :: II -> II -> System Val -> Val -> Eval Val 541 | cap r s _ m | r == s = return m 542 | cap r s (Triv b) m = coe s r b m 543 | cap r s _ (VBox r' s' _ t) | r == r' && s == s' = return t -- TODO: error if false? 544 | cap r s ts t = return $ VCap r s ts t 545 | 546 | hcomU :: II -> II -> System Val -> Val -> Eval Val 547 | hcomU r s _ u0 | r == s = return u0 548 | hcomU r s (Triv u) _ = u @@ s 549 | hcomU r s ts t = return $ VHComU r s ts t 550 | 551 | 552 | -- Helper function that only substitutes on faces of a system 553 | substOnFaces :: Nominal a => System a -> (Name,II) -> Eval (System a) 554 | substOnFaces (Sys xs) f = 555 | mkSystem <$> mapM (\(eqn,a) -> (,) <$> subst eqn f <*> pure a) (Map.assocs xs) 556 | substOnFaces (Triv x) f = return $ Triv x 557 | 558 | coeHComU :: Val -> II -> II -> Val -> Eval Val 559 | coeHComU (VPLam i (VHComU si s'i (Sys bisi) ai)) r r' m = traceb "coe hcomU" $ do 560 | -- First decompose the system 561 | let -- The part of bis that doesn't mention i in its faces 562 | bs' = Sys $ Map.filterWithKey (\alpha _ -> i `notOccurs` alpha) bisi 563 | -- The part of bis that mentions i in its faces 564 | bsi = Map.filterWithKey (\alpha _ -> i `occurs` alpha) bisi 565 | 566 | -- Substitute for r and r' directly every *except* for the system 567 | -- (the reason is that we need to recover the B_i without the 568 | -- substitution!) 569 | (sr,s'r,ar) <- (si,s'i,ai) `subst` (i,r) 570 | (sr',s'r',ar') <- (si,s'i,ai) `subst` (i,r') 571 | 572 | -- Do the substitution, *only* on the faces, not on the types 573 | bsi <- Sys bsi `substOnFaces` (i,r') 574 | 575 | -- We can use this in otm as we never need the original B_i! 576 | bisr <- Sys bisi `subst` (i,r) 577 | -- Define O 578 | let otm z = do 579 | -- Here I do not use ntm like in Part 3. Instead I unfold it so 580 | -- that I can take appropriate faces and do some optimization. 581 | -- z' is the name bound in bi. 582 | osys <- mapSystem (\alpha z' bi -> do 583 | let m' = VCoe s'r (Name z') (VPLam z' bi) m 584 | (VCoe (Name z') sr (VPLam z' bi) m') `face` alpha) bisr 585 | ocap <- cap sr s'r bisr m 586 | hcom s'r z ar osys ocap 587 | 588 | -- Define P(r'/x) 589 | ptm <- do 590 | otmsr <- otm sr 591 | -- TODO: psys is quite sketchy! 592 | psys <- mapSystem (\alpha x bi -> do 593 | let m' = VCoe r (Name x) (VPLam i (VAppII bi s'i)) m 594 | (VCoe s'i si (VPLam (N "_") bi) m') `face` alpha) bs' -- NB: we only take (r'/x) on the faces! 595 | 596 | psys' <- if Name i `notElem` [si,s'i] && isConsistent (eqn (si,s'i)) 597 | then do m' <- (VCoe r (Name i) (VPLam i ai) m) `face` (eqn (si,s'i)) 598 | return $ insertSystem (eqn (si,s'i),VPLam i m') psys 599 | else return psys 600 | com r r' (VPLam i ai) psys' otmsr 601 | 602 | -- Define Q_k. Take the face alpha (s_i = s'_i), free variable w 603 | -- (called z) and bk without (r'/x) 604 | let qtm alpha w bk = do 605 | (bk,m,bs') <- (bk,m,bs') `face` alpha 606 | 607 | qsys <- mapSystem (\alpha' z' bi -> do 608 | (bia,s'r'a,ra,r'a,ma) <- (bi,s'r',r,r',m) `face` alpha' 609 | bia' <- bia `subst` (z',s'r'a) 610 | ma' <- coe ra r'a (VPLam i bia') ma 611 | bia <- bia `subst` (i,r'a) 612 | coe s'r'a (Name z') (VPLam z' bia) ma') bs' -- NB: we only take (r'/x) of the faces! 613 | bk' <- bk `subst` (i,r') 614 | qsys' <- if isConsistent (eqn (r,r')) 615 | then do (srr',bk'r,mr) <- (s'r',bk',m) `face` (eqn (r,r')) 616 | l <- fresh 617 | m' <- coe srr' (Name l) (VPLam l bk'r) mr 618 | return $ insertSystem (eqn (r,r'),VPLam l m') qsys 619 | else return qsys 620 | 621 | com sr' w bk' qsys' ptm 622 | 623 | -- The part of outtmsys where the faces of the system depend on i 624 | -- (i.e. where we have to use qtm as the system doesn't simplify). 625 | tveci <- mapSystem (\alpha z bi -> do 626 | (bia,sr'a,r'a) <- (bi,sr',r') `face` alpha 627 | bra <- bia `subst` (i,r'a) 628 | coe (Name z) sr'a (VPLam z bra) =<< qtm alpha (Name z) (VPLam z bia)) bsi 629 | 630 | -- The part of outtmsys where the faces of the system doesn't depend on i 631 | -- (i.e. where qtm simplifies). 632 | tvec' <- mapSystem (\alpha z bi -> do 633 | (bia,sr'a,s'r'a,ra,r'a,ma) <- (bi,sr',s'r',r,r',m) `face` alpha 634 | bia' <- bia `subst` (z,s'r'a) 635 | biar' <- bia `subst` (i,r'a) 636 | ma' <- coe ra r'a (VPLam i bia') ma 637 | ma'' <- coe s'r'a (Name z) (VPLam z biar') ma' 638 | coe (Name z) sr'a (VPLam z biar') ma'') bs' 639 | let outtmsys = mergeSystem tveci tvec' 640 | 641 | tvec <- if isConsistent (eqn (r,r')) 642 | then do k <- fresh 643 | otmk <- otm (Name k) 644 | -- TODO: can we take the eqn into account like this: 645 | otmk' <- otmk `face` (eqn (r,r')) 646 | return $ insertSystem (eqn (r,r'),VPLam k otmk') outtmsys 647 | else return outtmsys 648 | outtm <- hcom sr' s'r' ar' tvec ptm 649 | 650 | -- Like above we only use qtm when i does not occur in the faces 651 | uveci <- mapSystemNoEta (\alpha bi -> qtm alpha s'r' bi) bsi 652 | -- And in the case when i does occur in the face we do the simplification 653 | uvec' <- mapSystemNoEta (\alpha bi -> (VCoe r r' (VPLam i (VAppII bi s'r')) m) `face` alpha) bs' 654 | let uvec = mergeSystem uveci uvec' 655 | 656 | box sr' s'r' uvec outtm 657 | coeHComU _ _ _ _ = error "coeHComU: case not implemented" 658 | 659 | hcomHComU :: Val -> II -> II -> System Val -> Val -> Eval Val 660 | hcomHComU (VHComU s s' bs a) r r' ns m = traceb "hcom hcomU" $ do 661 | -- Define P and parametrize by z 662 | let ptm bi z = do 663 | -- TODO: take alpha into account 664 | psys <- mapSystem (\alpha _ ni -> coe s' (Name z) (VPLam z bi) ni) ns 665 | pcap <- coe s' (Name z) (VPLam z bi) m 666 | hcom r r' bi psys pcap 667 | 668 | -- Define F[c] and parametrize by z 669 | let ftm c z = do 670 | fsys <- mapSystem (\alpha z' bi -> do 671 | let c' = VCoe s' (Name z') (VPLam z' bi) c 672 | (VCoe (Name z') s (VPLam z' bi) c') `face` alpha) bs 673 | fcap <- cap s s' bs c 674 | hcom s' z a fsys fcap 675 | 676 | -- Define O 677 | otm <- do 678 | -- TODO: take alpha into account 679 | osys <- mapSystem (\alpha _ ni -> ftm ni s) ns 680 | ocap <- ftm m s 681 | hcom r r' a osys ocap 682 | 683 | -- Define Q 684 | qtm <- do 685 | -- TODO: take alpha into account? 686 | qsys1 <- mapSystem (\alpha z ni -> do ni' <- ni `subst` (z,r') 687 | ftm ni' (Name z)) ns 688 | qsys2 <- mapSystem (\alpha z bi -> do p' <- ptm bi z 689 | coe (Name z) s (VPLam z bi) p') bs 690 | k <- fresh 691 | m' <- ftm m (Name k) 692 | -- TODO: take r=r' into account in m' 693 | let qsys = insertSystem (eqn (r,r'),VPLam k m') $ mergeSystem qsys1 qsys2 694 | hcom s s' a qsys otm 695 | 696 | -- inline P and optimize 697 | outsys <- mapSystemNoEta (\alpha bj -> (VHCom r r' bj ns m) `face` alpha) bs 698 | box s s' outsys qtm 699 | hcomHComU _ _ _ _ _ = error "hcomHComU: case not implemented" 700 | 701 | ------------------------------------------------------------------------------- 702 | -- | Conversion 703 | 704 | class Convertible a where 705 | conv :: [String] -> a -> a -> Eval Bool 706 | 707 | -- relies on Eqn invariant 708 | isCompSystem :: (Nominal a, Convertible a) => [String] -> System a -> Eval Bool 709 | isCompSystem ns (Triv _) = return True 710 | isCompSystem ns (Sys us) = 711 | and <$> sequence [ join (conv ns <$> getFace alpha beta <*> getFace beta alpha) 712 | | (alpha,beta) <- allCompatible (Map.keys us) ] 713 | where 714 | getFace a b = do 715 | usa <- us Map.! a `face` a 716 | ba <- b `face` a 717 | usa `face` ba 718 | -- getFace a@(Eqn (Name i) (Name j)) (Eqn (Name k) (Dir d)) 719 | -- | i == k || j == k = us ! a `subst` (i,Dir d) `subst` (j,Dir d) 720 | -- getFace a@(Eqn (Name k) (Dir d)) (Eqn (Name i) (Name j)) 721 | -- | i == k || j == k = us ! a `subst` (i,Dir d) `subst` (j,Dir d) 722 | -- getFace a b = (us ! a) `subst` toSubst b 723 | 724 | instance Convertible Env where 725 | conv ns (Env (rho1,vs1,fs1,os1)) (Env (rho2,vs2,fs2,os2)) = 726 | conv ns (rho1,vs1,fs1,os1) (rho2,vs2,fs2,os2) 727 | 728 | instance Convertible Val where 729 | conv ns u v | u == v = return True 730 | | otherwise = do 731 | j <- fresh 732 | case (u,v) of 733 | (Ter (Lam x a u) e,Ter (Lam x' a' u') e') -> do 734 | v@(VVar n _) <- mkVarNice ns x <$> eval e a 735 | join $ conv (n:ns) <$> eval (upd (x,v) e) u <*> eval (upd (x',v) e') u' 736 | (Ter (Lam x a u) e,u') -> do 737 | v@(VVar n _) <- mkVarNice ns x <$> eval e a 738 | join $ conv (n:ns) <$> eval (upd (x,v) e) u <*> app u' v 739 | (u',Ter (Lam x a u) e) -> do 740 | v@(VVar n _) <- mkVarNice ns x <$> eval e a 741 | join $ conv (n:ns) <$> app u' v <*> eval (upd (x,v) e) u 742 | (Ter (Split _ p _ _) e,Ter (Split _ p' _ _) e') -> pure (p == p') <&&> conv ns e e' 743 | (Ter (Sum p _ _) e,Ter (Sum p' _ _) e') -> pure (p == p') <&&> conv ns e e' 744 | (Ter (HSum p _ _) e,Ter (HSum p' _ _) e') -> pure (p == p') <&&> conv ns e e' 745 | (Ter (Undef p _) e,Ter (Undef p' _) e') -> pure (p == p') <&&> conv ns e e' 746 | (Ter (Hole p) e,Ter (Hole p') e') -> pure (p == p') <&&> conv ns e e' 747 | -- (Ter Hole{} e,_) -> return True 748 | -- (_,Ter Hole{} e') -> return True 749 | (VPi u v,VPi u' v') -> do 750 | let w@(VVar n _) = mkVarNice ns "X" u 751 | conv ns u u' <&&> join (conv (n:ns) <$> app v w <*> app v' w) 752 | (VSigma u v,VSigma u' v') -> do 753 | let w@(VVar n _) = mkVarNice ns "X" u 754 | conv ns u u' <&&> join (conv (n:ns) <$> app v w <*> app v' w) 755 | (VCon c us,VCon c' us') -> pure (c == c') <&&> conv ns us us' 756 | (VPCon c v us phis,VPCon c' v' us' phis') -> 757 | pure (c == c') <&&> conv ns (v,us,phis) (v',us',phis') 758 | (VPair u v,VPair u' v') -> conv ns u u' <&&> conv ns v v' 759 | (VPair u v,w) -> conv ns u (fstVal w) <&&> conv ns v (sndVal w) 760 | (w,VPair u v) -> conv ns (fstVal w) u <&&> conv ns (sndVal w) v 761 | (VFst u,VFst u') -> conv ns u u' 762 | (VSnd u,VSnd u') -> conv ns u u' 763 | (VApp u v,VApp u' v') -> conv ns u u' <&&> conv ns v v' 764 | (VSplit u v,VSplit u' v') -> conv ns u u' <&&> conv ns v v' 765 | (VOpaque x _, VOpaque x' _) -> return $ x == x' 766 | (VVar x _, VVar x' _) -> return $ x == x' 767 | (VPathP a b c,VPathP a' b' c') -> conv ns a a' <&&> conv ns b b' <&&> conv ns c c' 768 | (VLineP a,VLineP a') -> conv ns a a' 769 | (VPLam i a,VPLam i' a') -> conv ns (a `swap` (i,j)) (a' `swap` (i',j)) 770 | (VPLam i a,p') -> join $ conv ns (a `swap` (i,j)) <$> p' @@ j 771 | (p,VPLam i' a') -> join $ conv ns <$> p @@ j <*> pure (a' `swap` (i',j)) 772 | (VAppII u x,VAppII u' x') -> conv ns (u,x) (u',x') 773 | (VCoe r s a u,VCoe r' s' a' u') -> conv ns (r,s,a,u) (r',s',a',u') 774 | -- -- TODO: Maybe identify via (- = 1)? Or change argument to a system.. 775 | -- conv ns (a,invSystem phi One,u) (a',invSystem phi' One,u') 776 | -- conv ns (a,phi,u) (a',phi',u') 777 | (VHCom r s a us u0,VHCom r' s' a' us' u0') -> conv ns (r,s,a,us,u0) (r',s',a',us',u0') 778 | (VV i a b e,VV i' a' b' e') -> pure (i == i') <&&> conv ns (a,b,e) (a',b',e') 779 | (VVin _ m n,VVin _ m' n') -> conv ns (m,n) (m',n') 780 | (VVproj i o _ _ _,VVproj i' o' _ _ _) -> pure (i == i') <&&> conv ns o o' 781 | (VHComU r s ts t,VHComU r' s' ts' t') -> conv ns (r,s,ts,t) (r',s',ts',t') 782 | -- TODO: are the following two cases correct? 783 | (VCap r s ts t,VCap r' s' ts' t') -> conv ns (r,s,ts,t) (r',s',ts',t') 784 | (VBox r s ts t,VBox r' s' ts' t') -> conv ns (r,s,ts,t) (r',s',ts',t') 785 | _ -> return False 786 | 787 | instance Convertible Ctxt where 788 | conv _ _ _ = return True 789 | 790 | instance Convertible () where 791 | conv _ _ _ = return True 792 | 793 | (<&&>) :: Monad m => m Bool -> m Bool -> m Bool 794 | u <&&> v = do 795 | b1 <- u 796 | b2 <- v 797 | return (b1 && b2) 798 | 799 | instance (Convertible a, Convertible b) => Convertible (a, b) where 800 | conv ns (u,v) (u',v') = conv ns u u' <&&> conv ns v v' 801 | 802 | instance (Convertible a, Convertible b, Convertible c) 803 | => Convertible (a, b, c) where 804 | conv ns (u,v,w) (u',v',w') = 805 | conv ns u u' <&&> conv ns v v' <&&> conv ns w w' 806 | 807 | instance (Convertible a,Convertible b,Convertible c,Convertible d) 808 | => Convertible (a,b,c,d) where 809 | conv ns (u,v,w,x) (u',v',w',x') = 810 | conv ns u u' <&&> conv ns v v' <&&> conv ns w w' <&&> conv ns x x' 811 | 812 | instance (Convertible a,Convertible b,Convertible c,Convertible d,Convertible e) 813 | => Convertible (a,b,c,d,e) where 814 | conv ns (u,v,w,x,y) (u',v',w',x',y') = 815 | conv ns u u' <&&> conv ns v v' <&&> conv ns w w' <&&> conv ns x x' <&&> 816 | conv ns y y' 817 | 818 | instance (Convertible a,Convertible b,Convertible c,Convertible d,Convertible e,Convertible f) 819 | => Convertible (a,b,c,d,e,f) where 820 | conv ns (u,v,w,x,y,z) (u',v',w',x',y',z') = 821 | conv ns u u' <&&> conv ns v v' <&&> conv ns w w' <&&> conv ns x x' <&&> 822 | conv ns y y' <&&> conv ns z z' 823 | 824 | instance Convertible a => Convertible [a] where 825 | conv ns us us' = do 826 | bs <- sequence [ conv ns u u' | (u,u') <- zip us us' ] 827 | return (length us == length us' && and bs) 828 | 829 | instance (Convertible a,Nominal a) => Convertible (System a) where 830 | conv ns (Triv u) (Triv u') = conv ns u u' 831 | conv ns (Sys us) (Sys us') = do 832 | let compare eqn u u' = join $ conv ns <$> u `face` eqn <*> u' `face` eqn 833 | bs <- T.sequence $ Map.elems (Map.intersectionWithKey compare us us') 834 | return $ Map.keys us == Map.keys us' && and bs 835 | 836 | instance Convertible II where 837 | conv _ r s = return $ r == s 838 | 839 | instance Convertible (Nameless a) where 840 | conv _ _ _ = return True 841 | 842 | ------------------------------------------------------------------------------- 843 | -- | Normalization 844 | 845 | class Normal a where 846 | normal :: [String] -> a -> Eval a 847 | 848 | instance Normal Env where 849 | normal ns (Env (rho,vs,fs,os)) = Env <$> normal ns (rho,vs,fs,os) 850 | 851 | instance Normal Val where 852 | normal ns v = case v of 853 | VU -> return VU 854 | Ter (Lam x t u) e -> do 855 | w <- eval e t 856 | let v@(VVar n _) = mkVarNice ns x w 857 | u' <- eval (upd (x,v) e) u 858 | VLam n <$> normal ns w <*> normal (n:ns) u' 859 | Ter t e -> Ter t <$> normal ns e 860 | VPi u v -> VPi <$> normal ns u <*> normal ns v 861 | VSigma u v -> VSigma <$> normal ns u <*> normal ns v 862 | VPair u v -> VPair <$> normal ns u <*> normal ns v 863 | VCon n us -> VCon n <$> normal ns us 864 | VPCon n u us phis -> VPCon n <$> normal ns u <*> normal ns us <*> pure phis 865 | VPathP a u0 u1 -> VPathP <$> normal ns a <*> normal ns u0 <*> normal ns u1 866 | VLineP a -> VLineP <$> normal ns a 867 | VPLam i u -> VPLam i <$> normal ns u 868 | VCoe r s a u -> VCoe <$> normal ns r <*> normal ns s <*> normal ns a <*> normal ns u 869 | VHCom r s u vs v -> VHCom <$> normal ns r <*> normal ns s <*> normal ns u <*> normal ns vs <*> normal ns v 870 | VV i a b e -> VV i <$> normal ns a <*> normal ns b <*> normal ns e 871 | VVin i m n -> VVin i <$> normal ns m <*> normal ns n 872 | VVproj i o a b e -> VVproj i <$> normal ns o <*> normal ns a <*> normal ns b <*> normal ns e 873 | VHComU r s ts t -> VHComU <$> normal ns r <*> normal ns s <*> normal ns ts <*> normal ns t 874 | VCap r s ts t -> VCap <$> normal ns r <*> normal ns s <*> normal ns ts <*> normal ns t 875 | VBox r s ts t -> VBox <$> normal ns r <*> normal ns s <*> normal ns ts <*> normal ns t 876 | VVar x t -> VVar x <$> normal ns t 877 | VFst t -> VFst <$> normal ns t 878 | VSnd t -> VSnd <$> normal ns t 879 | VSplit u t -> VSplit <$> normal ns u <*> normal ns t 880 | VApp u v -> VApp <$> normal ns u <*> normal ns v 881 | VAppII u phi -> VAppII <$> normal ns u <*> normal ns phi 882 | _ -> return v 883 | 884 | instance Normal (Nameless a) where 885 | normal _ = return 886 | 887 | instance Normal Ctxt where 888 | normal _ = return 889 | 890 | instance Normal II where 891 | normal _ = return 892 | 893 | instance (Nominal a, Normal a) => Normal (System a) where 894 | normal ns (Triv u) = Triv <$> normal ns u 895 | normal ns (Sys us) = do 896 | us' <- T.sequence $ 897 | Map.mapWithKey (\eqn u -> join (normal ns <$> u `face` eqn)) us 898 | return $ Sys us' 899 | 900 | instance (Normal a,Normal b) => Normal (a,b) where 901 | normal ns (u,v) = do 902 | u' <- normal ns u 903 | v' <- normal ns v 904 | return (u',v') 905 | 906 | instance (Normal a,Normal b,Normal c) => Normal (a,b,c) where 907 | normal ns (u,v,w) = do 908 | u' <- normal ns u 909 | v' <- normal ns v 910 | w' <- normal ns w 911 | return (u',v',w') 912 | 913 | instance (Normal a,Normal b,Normal c,Normal d) => Normal (a,b,c,d) where 914 | normal ns (u,v,w,x) = do 915 | u' <- normal ns u 916 | v' <- normal ns v 917 | w' <- normal ns w 918 | x' <- normal ns x 919 | return (u',v',w',x') 920 | 921 | instance Normal a => Normal [a] where 922 | normal ns = mapM (normal ns) 923 | -------------------------------------------------------------------------------- /Exp.cf: -------------------------------------------------------------------------------- 1 | entrypoints Module, Exp ; 2 | 3 | comment "--" ; 4 | comment "{-" "-}" ; 5 | 6 | layout "where", "let", "split", "mutual", "with" ; 7 | layout stop "in" ; 8 | -- Do not use layout toplevel as it makes pExp fail! 9 | 10 | Module. Module ::= "module" AIdent "where" "{" [Imp] [Decl] "}" ; 11 | 12 | Import. Imp ::= "import" AIdent ; 13 | separator Imp ";" ; 14 | 15 | DeclDef. Decl ::= AIdent [Tele] ":" Exp "=" ExpWhere ; 16 | DeclData. Decl ::= "data" AIdent [Tele] "=" [Label] ; 17 | DeclHData. Decl ::= "hdata" AIdent [Tele] "=" [Label] ; 18 | DeclSplit. Decl ::= AIdent [Tele] ":" Exp "=" "split" "{" [Branch] "}" ; 19 | DeclUndef. Decl ::= AIdent [Tele] ":" Exp "=" "undefined" ; 20 | DeclMutual. Decl ::= "mutual" "{" [Decl] "}" ; 21 | DeclOpaque. Decl ::= "opaque" AIdent ; 22 | DeclTransparent. Decl ::= "transparent" AIdent ; 23 | DeclTransparentAll. Decl ::= "transparent_all" ; 24 | separator Decl ";" ; 25 | 26 | Where. ExpWhere ::= Exp "where" "{" [Decl] "}" ; 27 | NoWhere. ExpWhere ::= Exp ; 28 | 29 | Let. Exp ::= "let" "{" [Decl] "}" "in" Exp ; 30 | Lam. Exp ::= "\\" [PTele] "->" Exp ; 31 | PLam. Exp ::= "<" [AIdent] ">" Exp ; 32 | Split. Exp ::= "split@" Exp "with" "{" [Branch] "}" ; 33 | Fun. Exp1 ::= Exp2 "->" Exp1 ; 34 | Pi. Exp1 ::= [PTele] "->" Exp1 ; 35 | Sigma. Exp1 ::= [PTele] "*" Exp1 ; 36 | AppII. Exp2 ::= Exp2 "@" II ; 37 | App. Exp2 ::= Exp2 Exp3 ; 38 | PathP. Exp3 ::= "PathP" Exp4 Exp4 Exp4 ; 39 | LineP. Exp3 ::= "LineP" Exp4 ; 40 | Coe. Exp3 ::= "coe" II "->" II Exp4 Exp4 ; 41 | HCom. Exp3 ::= "hcom" II "->" II Exp4 System Exp4 ; 42 | Com. Exp3 ::= "com" II "->" II Exp4 System Exp4 ; 43 | Box. Exp3 ::= "box" II "->" II System Exp4 ; 44 | Cap. Exp3 ::= "cap" II "<-" II System Exp4 ; 45 | V. Exp3 ::= "V" II Exp4 Exp4 Exp4 ; 46 | Vin. Exp3 ::= "Vin" II Exp4 Exp4 ; 47 | Vproj. Exp3 ::= "Vproj" II Exp4 Exp4 Exp4 Exp4 ; 48 | Fst. Exp4 ::= Exp4 ".1" ; 49 | Snd. Exp4 ::= Exp4 ".2" ; 50 | Pair. Exp5 ::= "(" Exp "," [Exp] ")" ; 51 | Var. Exp5 ::= AIdent ; 52 | PCon. Exp5 ::= AIdent "{" Exp "}" ; -- c{T A B} x1 x2 @ phi 53 | U. Exp5 ::= "U" ; 54 | Hole. Exp5 ::= HoleIdent ; 55 | coercions Exp 5 ; 56 | separator nonempty Exp "," ; 57 | 58 | Dir0. Dir ::= "0" ; 59 | Dir1. Dir ::= "1" ; 60 | 61 | System. System ::= "[" [Side] "]" ; 62 | 63 | Side. Side ::= Face "->" Exp ; 64 | separator Side "," ; 65 | 66 | Face. Face ::= "(" II "=" II ")" ; -- Maybe (AIdent,II)? 67 | 68 | Atom. II ::= AIdent ; 69 | Dir. II ::= Dir ; 70 | 71 | -- Branches 72 | OBranch. Branch ::= AIdent [AIdent] "->" ExpWhere ; 73 | -- TODO: better have ... @ i @ j @ k -> ... ? 74 | PBranch. Branch ::= AIdent [AIdent] "@" [AIdent] "->" ExpWhere ; 75 | separator Branch ";" ; 76 | 77 | -- Labelled sum alternatives 78 | OLabel. Label ::= AIdent [Tele] ; 79 | PLabel. Label ::= AIdent [Tele] "<" [AIdent] ">" System ; 80 | separator Label "|" ; 81 | 82 | -- Telescopes 83 | Tele. Tele ::= "(" AIdent [AIdent] ":" Exp ")" ; 84 | terminator Tele "" ; 85 | 86 | -- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities 87 | -- in the grammar when parsing Pi 88 | PTele. PTele ::= "(" Exp ":" Exp ")" ; 89 | terminator nonempty PTele "" ; 90 | 91 | position token AIdent ('_')|(letter)(letter|digit|'\''|'_')*|('!')(digit)* ; 92 | separator AIdent "" ; 93 | 94 | position token HoleIdent '?' ; 95 | -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | # ghc and bnfc don't update their output files' timestamps if the contents are 2 | # unchanged, but "make" expects commands to actually produce their output 3 | # files, so this is a poor match. (By contrast, alex and happy do update their 4 | # output files.) To defeat that, we touch the output files when trying to make them. 5 | 6 | GHC = ghc 7 | # or: 8 | # GHC = cabal exec ghc -- 9 | INPUT = CTT.hs Cartesian.hs Eval.hs Main.hs Resolver.hs TypeChecker.hs 10 | GRAMMAR = Exp.cf 11 | GRAMMAR_X_FILES = Exp/Lex.x 12 | GRAMMAR_Y_FILES = Exp/Par.y 13 | GRAMMAR_HS_FILES = Exp/Abs.hs Exp/ErrM.hs Exp/Layout.hs Exp/Print.hs Exp/Skel.hs Exp/Test.hs 14 | GRAMMAR_FILES := $(GRAMMAR_HS_FILES) $(GRAMMAR_X_FILES) $(GRAMMAR_Y_FILES) Exp/Doc.txt 15 | GRAMMAR_HS_FILES += $(GRAMMAR_X_FILES:.x=.hs) 16 | GRAMMAR_HS_FILES += $(GRAMMAR_Y_FILES:.y=.hs) 17 | GRAMMAR_OBJECT_FILES = $(GRAMMAR_HS_FILES:.hs=.o) 18 | PROFILING = # -prof -fprof-auto 19 | GHCOPTIONS = -O2 -rtsopts -v0 $(PROFILING) 20 | 21 | all: yacctt 22 | 23 | # There should be a way to make ghc link with the appropriate libraries, 24 | # without using the --make option, but I can't figure it out. The libraries 25 | # used are: 26 | # QuickCheck array bytestring containers deepseq directory filepath haskeline 27 | # mtl old pretty random template terminfo time transformers unix 28 | # This is what I tried: 29 | # yacctt: $(INPUT:.hs=.o) $(GRAMMAR_OBJECT_FILES); $(GHC) -o $@ $(GHCOPTIONS) $^ 30 | 31 | yacctt: $(INPUT:.hs=.o) $(GRAMMAR_OBJECT_FILES) 32 | $(GHC) -M -dep-suffix "" $(INPUT) $(GRAMMAR_HS_FILES) 33 | $(GHC) --make $(GHCOPTIONS) -o yacctt Main 34 | 35 | build-Makefile: $(INPUT) $(GRAMMAR_HS_FILES) 36 | $(GHC) -M -dep-suffix "" $^ 37 | 38 | include Makefile 39 | 40 | %.hi %.o: %.hs 41 | $(GHC) $(GHCOPTIONS) $< 42 | @ touch $*.hi $*.o 43 | %.hs: %.y 44 | happy -gca $< 45 | %.hs: %.x 46 | alex -g $< 47 | 48 | bnfc $(GRAMMAR_FILES): Exp.cf 49 | bnfc --haskell -d Exp.cf 50 | @ touch $(GRAMMAR_FILES) 51 | 52 | TAGS:; hasktags --etags $(INPUT) $(GRAMMAR) 53 | 54 | clean:; rm -rf Exp *.log *.aux *.hi *.o yacctt TAGS Makefile.bak 55 | git-clean:; git clean -Xdfq 56 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Anders Mörtberg and Carlo Angiuli 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.Reader 4 | import qualified Control.Exception as E 5 | import Data.List 6 | import Data.Time 7 | import System.Directory 8 | import System.FilePath 9 | import System.Environment 10 | import System.Console.GetOpt 11 | import System.Console.Haskeline 12 | import System.Console.Haskeline.History 13 | import Text.Printf 14 | 15 | import Exp.Lex 16 | import Exp.Par 17 | import Exp.Print 18 | import Exp.Abs hiding (NoArg) 19 | import Exp.Layout 20 | import Exp.ErrM 21 | 22 | import CTT 23 | import Cartesian 24 | import Resolver 25 | import qualified TypeChecker as TC 26 | import qualified Eval as E 27 | 28 | type Interpreter a = InputT IO a 29 | 30 | -- Flag handling 31 | data Flag = Debug | Batch | Help | Version | Time 32 | deriving (Eq,Show) 33 | 34 | options :: [OptDescr Flag] 35 | options = [ Option "d" ["debug"] (NoArg Debug) "run in debugging mode" 36 | , Option "b" ["batch"] (NoArg Batch) "run in batch mode" 37 | , Option "" ["help"] (NoArg Help) "print help" 38 | , Option "-t" ["time"] (NoArg Time) "measure time spent computing" 39 | , Option "" ["version"] (NoArg Version) "print version number" ] 40 | 41 | -- Version number, welcome message, usage and prompt strings 42 | version, welcome, usage, prompt :: String 43 | version = "1.0" 44 | welcome = "yacctt, version: " ++ version ++ " (:h for help)\n" 45 | usage = "Usage: yacctt [options] \nOptions:" 46 | prompt = "> " 47 | 48 | lexer :: String -> [Token] 49 | lexer = resolveLayout True . myLexer 50 | 51 | showTree :: (Show a, Print a) => a -> IO () 52 | showTree tree = do 53 | putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree 54 | putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree 55 | 56 | -- Used for auto completion 57 | searchFunc :: [String] -> String -> [Completion] 58 | searchFunc ns str = map simpleCompletion $ filter (str `isPrefixOf`) ns 59 | 60 | settings :: [String] -> Settings IO 61 | settings ns = Settings 62 | { historyFile = Nothing 63 | , complete = completeWord Nothing " \t" $ return . searchFunc ns 64 | , autoAddHistory = True } 65 | 66 | main :: IO () 67 | main = do 68 | args <- getArgs 69 | case getOpt Permute options args of 70 | (flags,files,[]) 71 | | Help `elem` flags -> putStrLn $ usageInfo usage options 72 | | Version `elem` flags -> putStrLn version 73 | | otherwise -> case files of 74 | [] -> do 75 | putStrLn welcome 76 | runInputT (settings []) (loop flags [] [] TC.verboseEnv) 77 | [f] -> do 78 | putStrLn welcome 79 | putStrLn $ "Loading " ++ show f 80 | initLoop flags f emptyHistory 81 | _ -> putStrLn $ "Input error: zero or one file expected\n\n" ++ 82 | usageInfo usage options 83 | (_,_,errs) -> putStrLn $ "Input error: " ++ concat errs ++ "\n" ++ 84 | usageInfo usage options 85 | 86 | shrink :: String -> String 87 | shrink s = s -- if length s > 1000 then take 1000 s ++ "..." else s 88 | 89 | -- Initialize the main loop 90 | initLoop :: [Flag] -> FilePath -> History -> IO () 91 | initLoop flags f hist = do 92 | -- Parse and type check files 93 | (_,_,mods) <- E.catch (imports True ([],[],[]) f) 94 | (\e -> do putStrLn $ unlines $ 95 | ("Exception: " : 96 | (takeWhile (/= "CallStack (from HasCallStack):") 97 | (lines $ show (e :: SomeException)))) 98 | return ([],[],[])) 99 | -- Translate to TT 100 | let res = runResolver $ resolveModules mods 101 | case res of 102 | Left err -> do 103 | putStrLn $ "Resolver failed: " ++ err 104 | runInputT (settings []) (putHistory hist >> loop flags f [] TC.verboseEnv) 105 | Right (adefs,names) -> do 106 | -- After resolivng the file check if some definitions were shadowed: 107 | let ns = map fst names 108 | uns = nub ns 109 | dups = ns \\ uns 110 | unless (dups == []) $ 111 | putStrLn $ "Warning: the following definitions were shadowed [" ++ 112 | intercalate ", " dups ++ "]" 113 | (merr,tenv) <- TC.runDeclss TC.verboseEnv adefs 114 | case merr of 115 | Just err -> putStrLn $ "Type checking failed: " ++ shrink err 116 | Nothing -> unless (mods == []) $ putStrLn "File loaded." 117 | if Batch `elem` flags 118 | then return () 119 | else -- Compute names for auto completion 120 | runInputT (settings [n | (n,_) <- names]) 121 | (putHistory hist >> loop flags f names tenv) 122 | 123 | -- The main loop 124 | loop :: [Flag] -> FilePath -> [(CTT.Ident,SymKind)] -> TC.TEnv -> Interpreter () 125 | loop flags f names tenv = do 126 | input <- getInputLine prompt 127 | case input of 128 | Nothing -> outputStrLn help >> loop flags f names tenv 129 | Just ":q" -> return () 130 | Just ":r" -> getHistory >>= lift . initLoop flags f 131 | Just (':':'l':' ':str) 132 | | ' ' `elem` str -> do outputStrLn "Only one file allowed after :l" 133 | loop flags f names tenv 134 | | otherwise -> getHistory >>= lift . initLoop flags str 135 | Just (':':'c':'d':' ':str) -> do lift (setCurrentDirectory str) 136 | loop flags f names tenv 137 | Just ":h" -> outputStrLn help >> loop flags f names tenv 138 | Just str' -> 139 | let (msg,str,mod) = case str' of 140 | (':':'n':' ':str) -> 141 | ("NORMEVAL: ",str,E.normal []) 142 | str -> ("EVAL: ",str,return) 143 | in case pExp (lexer str) of 144 | Bad err -> outputStrLn ("Parse error: " ++ err) >> loop flags f names tenv 145 | Ok exp -> 146 | case runResolver $ local (insertIdents names) $ resolveExp exp of 147 | Left err -> do outputStrLn ("Resolver failed: " ++ err) 148 | loop flags f names tenv 149 | Right body -> do 150 | x <- liftIO $ TC.runInfer tenv body 151 | case x of 152 | Left err -> do outputStrLn ("Could not type-check: " ++ err) 153 | loop flags f names tenv 154 | Right _ -> do 155 | start <- liftIO getCurrentTime 156 | e <- liftIO $ runEval $ join (mod <$> E.eval (TC.env tenv) body) 157 | -- Let's not crash if the evaluation raises an error: 158 | liftIO $ catch (putStrLn (msg ++ shrink (show e))) 159 | (\e -> putStrLn ("Exception: " ++ 160 | show (e :: SomeException))) 161 | stop <- liftIO getCurrentTime 162 | -- Compute time and print nicely 163 | let time = diffUTCTime stop start 164 | secs = read (takeWhile (/='.') (init (show time))) 165 | rest = read ('0':dropWhile (/='.') (init (show time))) 166 | mins = secs `quot` 60 167 | sec = printf "%.3f" (fromInteger (secs `rem` 60) + rest :: Float) 168 | when (Time `elem` flags) $ 169 | outputStrLn $ "Time: " ++ show mins ++ "m" ++ sec ++ "s" 170 | -- Only print in seconds: 171 | -- when (Time `elem` flags) $ outputStrLn $ "Time: " ++ show time 172 | loop flags f names tenv 173 | 174 | -- (not ok,loaded,already loaded defs) -> to load -> 175 | -- (new not ok, new loaded, new defs) 176 | -- the bool determines if it should be verbose or not 177 | imports :: Bool -> ([String],[String],[Module]) -> String -> 178 | IO ([String],[String],[Module]) 179 | imports v st@(notok,loaded,mods) f 180 | | f `elem` notok = error ("Looping imports in " ++ f) 181 | | f `elem` loaded = return st 182 | | otherwise = do 183 | b <- doesFileExist f 184 | when (not b) $ error (f ++ " does not exist") 185 | let prefix = dropFileName f 186 | s <- readFile f 187 | let ts = lexer s 188 | case pModule ts of 189 | Bad s -> error ("Parse failed in " ++ show f ++ "\n" ++ show s) 190 | Ok mod@(Module (AIdent (_,name)) imp decls) -> do 191 | let imp_ytt = [prefix ++ i ++ ".ytt" | Import (AIdent (_,i)) <- imp] 192 | when (name /= dropExtension (takeFileName f)) $ 193 | error ("Module name mismatch in " ++ show f ++ " with wrong name " ++ name) 194 | (notok1,loaded1,mods1) <- 195 | foldM (imports v) (f:notok,loaded,mods) imp_ytt 196 | when v $ putStrLn $ "Parsed " ++ show f ++ " successfully!" 197 | return (notok,f:loaded1,mods1 ++ [mod]) 198 | 199 | help :: String 200 | help = "\nAvailable commands:\n" ++ 201 | " infer type and evaluate statement\n" ++ 202 | " :n normalize statement\n" ++ 203 | " :q quit\n" ++ 204 | " :l loads filename (and resets environment before)\n" ++ 205 | " :cd change directory to path\n" ++ 206 | " :r reload\n" ++ 207 | " :h display this message\n" 208 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # DO NOT DELETE: Beginning of Haskell dependencies 2 | Cartesian.o : Cartesian.hs 3 | CTT.o : CTT.hs 4 | CTT.o : Cartesian.hi 5 | Eval.o : Eval.hs 6 | Eval.o : CTT.hi 7 | Eval.o : Cartesian.hi 8 | Exp/Abs.o : Exp/Abs.hs 9 | Exp/ErrM.o : Exp/ErrM.hs 10 | Exp/Lex.o : Exp/Lex.hs 11 | Exp/Layout.o : Exp/Layout.hs 12 | Exp/Layout.o : Exp/Lex.hi 13 | Exp/Par.o : Exp/Par.hs 14 | Exp/Par.o : Exp/ErrM.hi 15 | Exp/Par.o : Exp/Lex.hi 16 | Exp/Par.o : Exp/Abs.hi 17 | Exp/Print.o : Exp/Print.hs 18 | Exp/Print.o : Exp/Abs.hi 19 | Exp/Skel.o : Exp/Skel.hs 20 | Exp/Skel.o : Exp/ErrM.hi 21 | Exp/Skel.o : Exp/Abs.hi 22 | Exp/Test.o : Exp/Test.hs 23 | Exp/Test.o : Exp/ErrM.hi 24 | Exp/Test.o : Exp/Layout.hi 25 | Exp/Test.o : Exp/Abs.hi 26 | Exp/Test.o : Exp/Print.hi 27 | Exp/Test.o : Exp/Skel.hi 28 | Exp/Test.o : Exp/Par.hi 29 | Exp/Test.o : Exp/Lex.hi 30 | Resolver.o : Resolver.hs 31 | Resolver.o : Cartesian.hi 32 | Resolver.o : Eval.hi 33 | Resolver.o : CTT.hi 34 | Resolver.o : CTT.hi 35 | Resolver.o : Exp/Abs.hi 36 | TypeChecker.o : TypeChecker.hs 37 | TypeChecker.o : Eval.hi 38 | TypeChecker.o : CTT.hi 39 | TypeChecker.o : Cartesian.hi 40 | Main.o : Main.hs 41 | Main.o : Eval.hi 42 | Main.o : TypeChecker.hi 43 | Main.o : Resolver.hi 44 | Main.o : Cartesian.hi 45 | Main.o : CTT.hi 46 | Main.o : Exp/ErrM.hi 47 | Main.o : Exp/Layout.hi 48 | Main.o : Exp/Abs.hi 49 | Main.o : Exp/Print.hi 50 | Main.o : Exp/Par.hi 51 | Main.o : Exp/Lex.hi 52 | # DO NOT DELETE: End of Haskell dependencies 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # yacctt: Yet Another Cartesian Cubical Type Theory 2 | 3 | This is an extremely experimental implementation of a cartesian 4 | cubical type theory based on https://arxiv.org/abs/1712.01800 written by 5 | Anders Mörtberg and Carlo Angiuli. It is mainly meant as proof of 6 | concept and for experimentation with new cubical features and ideas. 7 | 8 | It is based on the code base of https://github.com/mortberg/cubicaltt/. 9 | -------------------------------------------------------------------------------- /Resolver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | -- | Convert the concrete syntax into the syntax of yacctt 3 | module Resolver where 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import Control.Monad.Reader 8 | import Control.Monad.Except 9 | import Control.Monad.Identity 10 | import Data.Maybe 11 | import Data.List 12 | import Data.Map (Map,(!)) 13 | import qualified Data.Map as Map 14 | 15 | import Exp.Abs 16 | import CTT (Ter,Ident,Loc(..),mkApps,mkWheres) 17 | import qualified CTT 18 | import qualified Eval 19 | import qualified Cartesian as C 20 | 21 | -- | Useful auxiliary functions 22 | 23 | -- Applicative cons 24 | (<:>) :: Applicative f => f a -> f [a] -> f [a] 25 | a <:> b = (:) <$> a <*> b 26 | 27 | -- Un-something functions 28 | unVar :: Exp -> Maybe Ident 29 | unVar (Var (AIdent (_,x))) = Just x 30 | unVar _ = Nothing 31 | 32 | unWhere :: ExpWhere -> Exp 33 | unWhere (Where e ds) = Let ds e 34 | unWhere (NoWhere e) = e 35 | 36 | -- Tail recursive form to transform a sequence of applications 37 | -- App (App (App u v) ...) w into (u, [v, …, w]) 38 | -- (cleaner than the previous version of unApps) 39 | unApps :: Exp -> [Exp] -> (Exp, [Exp]) 40 | unApps (App u v) ws = unApps u (v : ws) 41 | unApps u ws = (u, ws) 42 | 43 | -- Turns an expression of the form App (... (App id1 id2) ... idn) 44 | -- into a list of idents 45 | appsToIdents :: Exp -> Maybe [Ident] 46 | appsToIdents = mapM unVar . uncurry (:) . flip unApps [] 47 | 48 | -- Transform a sequence of applications 49 | -- (((u v1) .. vn) phi1) .. phim into (u,[v1,..,vn],[phi1,..,phim]) 50 | unAppsIIs :: Exp -> [II]-> (Exp,[Exp],[II]) 51 | unAppsIIs (AppII u phi) phis = unAppsIIs u (phi:phis) 52 | unAppsIIs u phis = (x,xs,phis) 53 | where (x,xs) = unApps u [] 54 | 55 | -- Flatten a tele 56 | flattenTele :: [Tele] -> [(Ident,Exp)] 57 | flattenTele tele = 58 | [ (unAIdent i,typ) | Tele id ids typ <- tele, i <- id:ids ] 59 | 60 | -- Flatten a PTele 61 | flattenPTele :: [PTele] -> Resolver [(Ident,Exp)] 62 | flattenPTele [] = return [] 63 | flattenPTele (PTele exp typ : xs) = case appsToIdents exp of 64 | Just ids -> do 65 | pt <- flattenPTele xs 66 | return $ map (,typ) ids ++ pt 67 | Nothing -> throwError "malformed ptele" 68 | 69 | ------------------------------------------------------------------------------- 70 | -- | Resolver and environment 71 | 72 | data SymKind = Variable | Constructor | PConstructor | Name 73 | deriving (Eq,Show) 74 | 75 | -- local environment for constructors 76 | data Env = Env { envModule :: String, 77 | variables :: [(Ident,SymKind)] } 78 | deriving (Eq,Show) 79 | 80 | type Resolver a = ReaderT Env (ExceptT String Identity) a 81 | 82 | emptyEnv :: Env 83 | emptyEnv = Env "" [] 84 | 85 | runResolver :: Resolver a -> Either String a 86 | runResolver x = runIdentity $ runExceptT $ runReaderT x emptyEnv 87 | 88 | updateModule :: String -> Env -> Env 89 | updateModule mod e = e{envModule = mod} 90 | 91 | insertIdent :: (Ident,SymKind) -> Env -> Env 92 | insertIdent (n,var) e 93 | | n == "_" = e 94 | | otherwise = e{variables = (n,var) : variables e} 95 | 96 | insertIdents :: [(Ident,SymKind)] -> Env -> Env 97 | insertIdents = flip $ foldr insertIdent 98 | 99 | insertName :: AIdent -> Env -> Env 100 | insertName (AIdent (_,x)) = insertIdent (x,Name) 101 | 102 | insertNames :: [AIdent] -> Env -> Env 103 | insertNames = flip $ foldr insertName 104 | 105 | insertVar :: Ident -> Env -> Env 106 | insertVar x = insertIdent (x,Variable) 107 | 108 | insertVars :: [Ident] -> Env -> Env 109 | insertVars = flip $ foldr insertVar 110 | 111 | insertAIdent :: AIdent -> Env -> Env 112 | insertAIdent (AIdent (_,x)) = insertIdent (x,Variable) 113 | 114 | insertAIdents :: [AIdent] -> Env -> Env 115 | insertAIdents = flip $ foldr insertAIdent 116 | 117 | getLoc :: (Int,Int) -> Resolver Loc 118 | getLoc l = Loc <$> asks envModule <*> pure l 119 | 120 | unAIdent :: AIdent -> Ident 121 | unAIdent (AIdent (_,x)) = x 122 | 123 | resolveName :: AIdent -> Resolver C.Name 124 | resolveName (AIdent (l,x)) = do 125 | modName <- asks envModule 126 | vars <- asks variables 127 | case lookup x vars of 128 | Just Name -> return $ C.N x 129 | _ -> throwError $ "Cannot resolve name " ++ x ++ " at position " ++ 130 | show l ++ " in module " ++ modName 131 | 132 | resolveVar :: AIdent -> Resolver Ter 133 | resolveVar (AIdent (l,x)) = do 134 | modName <- asks envModule 135 | vars <- asks variables 136 | case lookup x vars of 137 | Just Variable -> return $ CTT.Var x 138 | Just Constructor -> return $ CTT.Con x [] 139 | Just PConstructor -> 140 | throwError $ "The path constructor " ++ x ++ " is used as a" ++ 141 | " variable at " ++ show l ++ " in " ++ modName ++ 142 | " (path constructors should have their type in" ++ 143 | " curly braces as first argument)" 144 | Just Name -> 145 | throwError $ "Name " ++ x ++ " used as a variable at position " ++ 146 | show l ++ " in module " ++ modName 147 | _ -> throwError $ "Cannot resolve variable " ++ x ++ " at position " ++ 148 | show l ++ " in module " ++ modName 149 | 150 | lam :: (Ident,Exp) -> Resolver Ter -> Resolver Ter 151 | lam (a,t) e = CTT.Lam a <$> resolveExp t <*> local (insertVar a) e 152 | 153 | lams :: [(Ident,Exp)] -> Resolver Ter -> Resolver Ter 154 | lams = flip $ foldr lam 155 | 156 | plam :: AIdent -> Resolver Ter -> Resolver Ter 157 | plam i e = CTT.PLam (C.N (unAIdent i)) <$> local (insertName i) e 158 | 159 | plams :: [AIdent] -> Resolver Ter -> Resolver Ter 160 | plams [] _ = throwError "Empty plam abstraction" 161 | plams xs e = foldr plam e xs 162 | 163 | bind :: (Ter -> Ter) -> (Ident,Exp) -> Resolver Ter -> Resolver Ter 164 | bind f (x,t) e = f <$> lam (x,t) e 165 | 166 | binds :: (Ter -> Ter) -> [(Ident,Exp)] -> Resolver Ter -> Resolver Ter 167 | binds f = flip $ foldr $ bind f 168 | 169 | resolveApps :: Exp -> [Exp] -> Resolver Ter 170 | resolveApps x xs = mkApps <$> resolveExp x <*> mapM resolveExp xs 171 | 172 | resolveExp :: Exp -> Resolver Ter 173 | resolveExp e = case e of 174 | U -> return CTT.U 175 | Var x -> resolveVar x 176 | App t s -> resolveApps x xs 177 | where (x,xs) = unApps t [s] 178 | Sigma ptele b -> do 179 | tele <- flattenPTele ptele 180 | binds CTT.Sigma tele (resolveExp b) 181 | Pi ptele b -> do 182 | tele <- flattenPTele ptele 183 | binds CTT.Pi tele (resolveExp b) 184 | Fun a b -> bind CTT.Pi ("_",a) (resolveExp b) 185 | Lam ptele t -> do 186 | tele <- flattenPTele ptele 187 | lams tele (resolveExp t) 188 | Fst t -> CTT.Fst <$> resolveExp t 189 | Snd t -> CTT.Snd <$> resolveExp t 190 | Pair t0 ts -> do 191 | e <- resolveExp t0 192 | es <- mapM resolveExp ts 193 | return $ foldr1 CTT.Pair (e:es) 194 | Split t brs -> do 195 | t' <- resolveExp t 196 | brs' <- mapM resolveBranch brs 197 | l@(Loc n (i,j)) <- getLoc (case brs of 198 | OBranch (AIdent (l,_)) _ _:_ -> l 199 | PBranch (AIdent (l,_)) _ _ _:_ -> l 200 | _ -> (0,0)) 201 | return $ CTT.Split (n ++ "_L" ++ show i ++ "_C" ++ show j) l t' brs' 202 | Let decls e -> do 203 | (rdecls,names) <- resolveDecls decls 204 | mkWheres rdecls <$> local (insertIdents names) (resolveExp e) 205 | PLam is e -> plams is (resolveExp e) 206 | Hole (HoleIdent (l,_)) -> CTT.Hole <$> getLoc l 207 | AppII t phi -> 208 | let (x,xs,phis) = unAppsIIs e [] 209 | in case x of 210 | PCon n a -> 211 | CTT.PCon (unAIdent n) <$> resolveExp a <*> mapM resolveExp xs 212 | <*> mapM resolveII phis 213 | _ -> CTT.AppII <$> resolveExp t <*> resolveII phi 214 | PathP a u v -> CTT.PathP <$> resolveExp a <*> resolveExp u <*> resolveExp v 215 | LineP a -> CTT.LineP <$> resolveExp a 216 | Coe r s u v -> CTT.Coe <$> resolveII r <*> resolveII s <*> resolveExp u <*> resolveExp v 217 | HCom r s u ts v -> CTT.HCom <$> resolveII r <*> resolveII s <*> resolveExp u <*> resolveSystem ts <*> resolveExp v 218 | Com r s u ts v -> CTT.Com <$> resolveII r <*> resolveII s <*> resolveExp u <*> resolveSystem ts <*> resolveExp v 219 | -- Glue u ts -> CTT.Glue <$> resolveExp u <*> resolveSystem ts 220 | -- GlueElem u ts -> CTT.GlueElem <$> resolveExp u <*> resolveSystem ts 221 | -- UnGlueElem u v ts -> 222 | -- CTT.UnGlueElem <$> resolveExp u <*> resolveExp v <*> resolveSystem ts 223 | Box r s ts t -> CTT.Box <$> resolveII r <*> resolveII s <*> resolveSystem ts <*> resolveExp t 224 | Cap r s ts t -> CTT.Cap <$> resolveII r <*> resolveII s <*> resolveSystem ts <*> resolveExp t 225 | V r a b e -> CTT.V <$> resolveII r <*> resolveExp a <*> resolveExp b <*> resolveExp e 226 | Vin r m n -> CTT.Vin <$> resolveII r <*> resolveExp m <*> resolveExp n 227 | Vproj r o a b e -> CTT.Vproj <$> resolveII r <*> resolveExp o <*> resolveExp a <*> resolveExp b <*> resolveExp e 228 | _ -> do 229 | modName <- asks envModule 230 | throwError ("Could not resolve " ++ show e ++ " in module " ++ modName) 231 | 232 | resolveWhere :: ExpWhere -> Resolver Ter 233 | resolveWhere = resolveExp . unWhere 234 | 235 | resolveSystem :: System -> Resolver (C.System Ter) 236 | resolveSystem (System ts) = do 237 | ts' <- sequence [ (,) <$> resolveFace alpha <*> resolveExp u 238 | | Side alpha u <- ts ] 239 | let alphas = map fst ts' 240 | unless (nub alphas == alphas) $ 241 | throwError $ "system contains same face multiple times: " ++ 242 | show ts' 243 | -- Note: the symbols in alpha are in scope in u, but they mean 0 or 1 244 | return (C.mkSystem ts') 245 | 246 | resolveFace :: Face -> Resolver C.Eqn 247 | resolveFace (Face r s) = curry C.eqn <$> resolveII r <*> resolveII s 248 | 249 | resolveDir :: Dir -> Resolver C.Dir 250 | resolveDir Dir0 = return 0 251 | resolveDir Dir1 = return 1 252 | 253 | resolveII :: II -> Resolver C.II 254 | resolveII (Dir d) = C.Dir <$> resolveDir d 255 | resolveII (Atom i) = C.Name <$> resolveName i 256 | 257 | resolveBranch :: Branch -> Resolver CTT.Branch 258 | resolveBranch (OBranch (AIdent (_,lbl)) args e) = do 259 | re <- local (insertAIdents args) $ resolveWhere e 260 | return $ CTT.OBranch lbl (map unAIdent args) re 261 | resolveBranch (PBranch (AIdent (_,lbl)) args is e) = do 262 | re <- local (insertNames is . insertAIdents args) $ resolveWhere e 263 | let names = map (C.N . unAIdent) is 264 | return $ CTT.PBranch lbl (map unAIdent args) names re 265 | 266 | resolveTele :: [(Ident,Exp)] -> Resolver CTT.Tele 267 | resolveTele [] = return [] 268 | resolveTele ((i,d):t) = 269 | ((i,) <$> resolveExp d) <:> local (insertVar i) (resolveTele t) 270 | 271 | resolveLabel :: [(Ident,SymKind)] -> Label -> Resolver CTT.Label 272 | resolveLabel _ (OLabel n vdecl) = 273 | CTT.OLabel (unAIdent n) <$> resolveTele (flattenTele vdecl) 274 | resolveLabel cs (PLabel n vdecl is sys) = do 275 | let tele' = flattenTele vdecl 276 | ts = map fst tele' 277 | names = map (C.N . unAIdent) is 278 | n' = unAIdent n 279 | cs' = delete (n',PConstructor) cs 280 | CTT.PLabel n' <$> resolveTele tele' <*> pure names 281 | <*> local (insertNames is . insertIdents cs' . insertVars ts) 282 | (resolveSystem sys) 283 | 284 | -- Resolve a non-mutual declaration; returns resolver for type and 285 | -- body separately 286 | resolveNonMutualDecl :: Decl -> (Ident,Resolver CTT.Ter 287 | ,Resolver CTT.Ter,[(Ident,SymKind)]) 288 | resolveNonMutualDecl d = case d of 289 | DeclDef (AIdent (_,f)) tele t body -> 290 | let tele' = flattenTele tele 291 | a = binds CTT.Pi tele' (resolveExp t) 292 | d = lams tele' (local (insertVar f) $ resolveWhere body) 293 | in (f,a,d,[(f,Variable)]) 294 | DeclData x tele sums -> resolveDeclData x tele sums null 295 | DeclHData x tele sums -> 296 | resolveDeclData x tele sums (const False) -- always pick HSum 297 | DeclSplit (AIdent (l,f)) tele t brs -> 298 | let tele' = flattenTele tele 299 | vars = map fst tele' 300 | a = binds CTT.Pi tele' (resolveExp t) 301 | d = do 302 | loc <- getLoc l 303 | ty <- local (insertVars vars) $ resolveExp t 304 | brs' <- local (insertVars (f:vars)) (mapM resolveBranch brs) 305 | lams tele' (return $ CTT.Split f loc ty brs') 306 | in (f,a,d,[(f,Variable)]) 307 | DeclUndef (AIdent (l,f)) tele t -> 308 | let tele' = flattenTele tele 309 | a = binds CTT.Pi tele' (resolveExp t) 310 | d = CTT.Undef <$> getLoc l <*> a 311 | in (f,a,d,[(f,Variable)]) 312 | 313 | -- Helper function to resolve data declarations. The predicate p is 314 | -- used to decide if we should use Sum or HSum. 315 | resolveDeclData :: AIdent -> [Tele] -> [Label] -> ([(Ident,SymKind)] -> Bool) -> 316 | (Ident, Resolver Ter, Resolver Ter, [(Ident, SymKind)]) 317 | resolveDeclData (AIdent (l,f)) tele sums p = 318 | let tele' = flattenTele tele 319 | a = binds CTT.Pi tele' (return CTT.U) 320 | cs = [ (unAIdent lbl,Constructor) | OLabel lbl _ <- sums ] 321 | pcs = [ (unAIdent lbl,PConstructor) | PLabel lbl _ _ _ <- sums ] 322 | sum = if p pcs then CTT.Sum else CTT.HSum 323 | d = lams tele' $ local (insertVar f) $ 324 | sum <$> getLoc l <*> pure f 325 | <*> mapM (resolveLabel (cs ++ pcs)) sums 326 | in (f,a,d,(f,Variable):cs ++ pcs) 327 | 328 | resolveRTele :: [Ident] -> [Resolver CTT.Ter] -> Resolver CTT.Tele 329 | resolveRTele [] _ = return [] 330 | resolveRTele (i:is) (t:ts) = do 331 | a <- t 332 | as <- local (insertVar i) (resolveRTele is ts) 333 | return ((i,a):as) 334 | 335 | -- Best effort to find the location of a declaration. This implementation 336 | -- returns the location of the first identifier it contains. 337 | findDeclLoc :: Decl -> Resolver Loc 338 | findDeclLoc d = getLoc loc 339 | where loc = fromMaybe (-1, 0) $ mloc d 340 | mloc d = case d of 341 | DeclDef (AIdent (l, _)) _ _ _ -> Just l 342 | DeclData (AIdent (l, _)) _ _ -> Just l 343 | DeclHData (AIdent (l, _)) _ _ -> Just l 344 | DeclSplit (AIdent (l, _)) _ _ _ -> Just l 345 | DeclUndef (AIdent (l, _)) _ _ -> Just l 346 | DeclMutual ds -> listToMaybe $ mapMaybe mloc ds 347 | DeclOpaque (AIdent (l, _)) -> Just l 348 | DeclTransparent (AIdent (l, _)) -> Just l 349 | DeclTransparentAll -> Nothing 350 | 351 | -- Resolve a declaration 352 | resolveDecl :: Decl -> Resolver (CTT.Decls,[(Ident,SymKind)]) 353 | resolveDecl d = case d of 354 | DeclMutual decls -> do 355 | let (fs,ts,bs,nss) = unzip4 $ map resolveNonMutualDecl decls 356 | ns = concat nss -- TODO: some sanity checks? Duplicates!? 357 | when (nub (map fst ns) /= concatMap (map fst) nss) $ 358 | throwError ("Duplicated constructor or ident: " ++ show nss) 359 | as <- resolveRTele fs ts 360 | -- The bodies know about all the names and constructors in the 361 | -- mutual block 362 | ds <- sequence $ map (local (insertIdents ns)) bs 363 | let ads = zipWith (\ (x,y) z -> (x,(y,z))) as ds 364 | l <- findDeclLoc d 365 | return (CTT.MutualDecls l ads,ns) 366 | DeclOpaque i -> do 367 | resolveVar i 368 | return (CTT.OpaqueDecl (unAIdent i), []) 369 | DeclTransparent i -> do 370 | resolveVar i 371 | return (CTT.TransparentDecl (unAIdent i), []) 372 | DeclTransparentAll -> return (CTT.TransparentAllDecl, []) 373 | _ -> do let (f,typ,body,ns) = resolveNonMutualDecl d 374 | l <- findDeclLoc d 375 | a <- typ 376 | d <- body 377 | return (CTT.MutualDecls l [(f,(a,d))],ns) 378 | 379 | resolveDecls :: [Decl] -> Resolver ([CTT.Decls],[(Ident,SymKind)]) 380 | resolveDecls [] = return ([],[]) 381 | resolveDecls (d:ds) = do 382 | (rtd,names) <- resolveDecl d 383 | (rds,names') <- local (insertIdents names) $ resolveDecls ds 384 | return (rtd : rds, names' ++ names) 385 | 386 | resolveModule :: Module -> Resolver ([CTT.Decls],[(Ident,SymKind)]) 387 | resolveModule (Module (AIdent (_,n)) _ decls) = 388 | local (updateModule n) $ resolveDecls decls 389 | 390 | resolveModules :: [Module] -> Resolver ([CTT.Decls],[(Ident,SymKind)]) 391 | resolveModules [] = return ([],[]) 392 | resolveModules (mod:mods) = do 393 | (rmod, names) <- resolveModule mod 394 | (rmods,names') <- local (insertIdents names) $ resolveModules mods 395 | return (rmod ++ rmods, names' ++ names) 396 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Distribution.Simple.Program 3 | import System.Process (system) 4 | 5 | main :: IO () 6 | main = defaultMainWithHooks $ simpleUserHooks { 7 | hookedPrograms = [bnfc], 8 | preBuild = \args buildFlags -> do 9 | _ <- system "bnfc --haskell -d Exp.cf" 10 | preBuild simpleUserHooks args buildFlags 11 | } 12 | 13 | bnfc :: Program 14 | bnfc = (simpleProgram "bnfc") { 15 | programFindVersion = findProgramVersion "--version" id 16 | } 17 | -------------------------------------------------------------------------------- /TypeChecker.hs: -------------------------------------------------------------------------------- 1 | module TypeChecker where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import Control.Monad.Except 6 | import Control.Monad.Reader 7 | import Control.Monad.Gen 8 | import qualified Data.Map as Map 9 | import qualified Data.Traversable as T 10 | 11 | import Cartesian 12 | import CTT 13 | import Eval 14 | 15 | -- Type checking monad 16 | type Typing a = ReaderT TEnv (ExceptT String (GenT Int IO)) a 17 | 18 | -- Environment for type checker 19 | data TEnv = 20 | TEnv { names :: [String] -- generated names 21 | , indent :: Int 22 | , env :: Env 23 | , verbose :: Bool -- Should it be verbose and print what it typechecks? 24 | } deriving (Eq) 25 | 26 | verboseEnv, silentEnv :: TEnv 27 | verboseEnv = TEnv [] 0 emptyEnv True 28 | silentEnv = TEnv [] 0 emptyEnv False 29 | 30 | -- Trace function that depends on the verbosity flag 31 | trace :: String -> Typing () 32 | trace s = do 33 | b <- asks verbose 34 | when b $ liftIO (putStrLn s) 35 | 36 | -- Helper functions for eval 37 | evalTC :: Env -> Ter -> Typing Val 38 | evalTC rho t = lift $ lift $ eval rho t 39 | 40 | appTC :: Val -> Val -> Typing Val 41 | appTC u v = lift $ lift $ app u v 42 | 43 | convTC :: Convertible a => [String] -> a -> a -> Typing Bool 44 | convTC ns u v = lift $ lift $ conv ns u v 45 | 46 | normalTC :: Normal a => [String] -> a -> Typing a 47 | normalTC ns u = lift $ lift $ normal ns u 48 | 49 | (@@@) :: ToII a => Val -> a -> Typing Val 50 | v @@@ r = lift $ lift $ v @@ toII r 51 | 52 | ------------------------------------------------------------------------------- 53 | -- | Functions for running computations in the type checker monad 54 | 55 | runTyping :: TEnv -> Typing a -> IO (Either String a) 56 | runTyping env t = runGenT $ runExceptT $ runReaderT t env 57 | 58 | runDecls :: TEnv -> Decls -> IO (Either String TEnv) 59 | runDecls tenv d = runTyping tenv $ do 60 | checkDecls d 61 | return $ addDecls d tenv 62 | 63 | runDeclss :: TEnv -> [Decls] -> IO (Maybe String,TEnv) 64 | runDeclss tenv [] = return (Nothing, tenv) 65 | runDeclss tenv (d:ds) = do 66 | x <- runDecls tenv d 67 | case x of 68 | Right tenv' -> runDeclss tenv' ds 69 | Left s -> return (Just s, tenv) 70 | 71 | runInfer :: TEnv -> Ter -> IO (Either String Val) 72 | runInfer lenv e = runTyping lenv (infer e) 73 | 74 | ------------------------------------------------------------------------------- 75 | -- | Modifiers for the environment 76 | 77 | addTypeVal :: (Ident,Val) -> TEnv -> TEnv 78 | addTypeVal (x,a) (TEnv ns ind rho v) = 79 | let w@(VVar n _) = mkVarNice ns x a 80 | in TEnv (n:ns) ind (upd (x,w) rho) v 81 | 82 | addSub :: (Name,II) -> TEnv -> TEnv 83 | addSub iphi (TEnv ns ind rho v) = TEnv ns ind (sub iphi rho) v 84 | 85 | addSubs :: [(Name,II)] -> TEnv -> TEnv 86 | addSubs = flip $ foldr addSub 87 | 88 | addType :: (Ident,Ter) -> TEnv -> Typing TEnv 89 | addType (x,a) tenv@(TEnv _ _ rho _) = do 90 | va <- evalTC rho a 91 | return $ addTypeVal (x,va) tenv 92 | 93 | addBranch :: [(Ident,Val)] -> Env -> TEnv -> TEnv 94 | addBranch nvs env (TEnv ns ind rho v) = 95 | TEnv ([n | (_,VVar n _) <- nvs] ++ ns) ind (upds nvs rho) v 96 | 97 | addDecls :: Decls -> TEnv -> TEnv 98 | addDecls d (TEnv ns ind rho v) = TEnv ns ind (def d rho) v 99 | 100 | addTele :: Tele -> TEnv -> Typing TEnv 101 | addTele xas lenv = foldM (flip addType) lenv xas 102 | 103 | -- Only works for equations in a system (so of shape (Name,II)) 104 | faceEnv :: Eqn -> TEnv -> Typing TEnv 105 | faceEnv ir tenv = do 106 | tenv' <- lift $ lift $ env tenv `face` ir 107 | return $ tenv{env=tenv'} 108 | 109 | ------------------------------------------------------------------------------- 110 | -- | Various useful functions 111 | 112 | -- Extract the type of a label as a closure 113 | getLblType :: LIdent -> Val -> Typing (Tele, Env) 114 | getLblType c (Ter (Sum _ _ cas) r) = case lookupLabel c cas of 115 | Just as -> return (as,r) 116 | Nothing -> throwError ("getLblType: " ++ show c ++ " in " ++ show cas) 117 | getLblType c (Ter (HSum _ _ cas) r) = case lookupLabel c cas of 118 | Just as -> return (as,r) 119 | Nothing -> throwError ("getLblType: " ++ show c ++ " in " ++ show cas) 120 | getLblType c u = throwError ("expected a data type for the constructor " 121 | ++ c ++ " but got " ++ show u) 122 | 123 | -- Monadic version of unless 124 | unlessM :: Monad m => m Bool -> m () -> m () 125 | unlessM mb x = mb >>= flip unless x 126 | 127 | mkVars :: [String] -> Tele -> Env -> Typing [(Ident,Val)] 128 | mkVars _ [] _ = return [] 129 | mkVars ns ((x,a):xas) nu = do 130 | va <- evalTC nu a 131 | let w@(VVar n _) = mkVarNice ns x va 132 | xs <- mkVars (n:ns) xas (upd (x,w) nu) 133 | return $ (x,w) : xs 134 | 135 | -- Test if two values are convertible 136 | (===) :: Convertible a => a -> a -> Typing Bool 137 | u === v = do 138 | ns <- asks names 139 | convTC ns u v 140 | 141 | -- eval in the typing monad 142 | evalTyping :: Ter -> Typing Val 143 | evalTyping t = do 144 | rho <- asks env 145 | evalTC rho t 146 | 147 | ------------------------------------------------------------------------------- 148 | -- | The bidirectional type checker 149 | 150 | -- Check that t has type a 151 | check :: Val -> Ter -> Typing () 152 | check a t = case (a,t) of 153 | (_,Undef{}) -> return () 154 | (_,Hole l) -> do 155 | rho <- asks env 156 | let e = unlines (reverse (contextOfEnv rho)) 157 | ns <- asks names 158 | na <- normalTC ns a 159 | trace $ "\nHole at " ++ show l ++ ":\n\n" ++ 160 | e ++ replicate 80 '-' ++ "\n" ++ show na ++ "\n" 161 | (_,Con c es) -> do 162 | (bs,nu) <- getLblType c a 163 | checks (bs,nu) es 164 | (VU,Pi f) -> checkFam f 165 | (VU,Sigma f) -> checkFam f 166 | (VU,Sum _ _ bs) -> forM_ bs $ \lbl -> case lbl of 167 | OLabel _ tele -> checkTele tele 168 | PLabel _ tele is ts -> 169 | throwError $ "check: no path constructor allowed in " ++ show t 170 | (VU,HSum _ _ bs) -> forM_ bs $ \lbl -> case lbl of 171 | OLabel _ tele -> checkTele tele 172 | PLabel _ tele is ts -> do 173 | checkTele tele 174 | rho <- asks env 175 | unless (all (`elem` is) (eqnSupport ts)) $ 176 | throwError "names in path label system" -- TODO 177 | mapM_ checkFresh is 178 | let iis = zip is (map Name is) 179 | local (addSubs iis) $ localM (addTele tele) $ do 180 | checkSystemWith ts $ \alpha talpha -> 181 | localM (faceEnv alpha) $ 182 | -- NB: the type doesn't depend on is 183 | check (Ter t rho) talpha 184 | rho' <- asks env 185 | ts' <- lift $ lift $ evalSystem rho' ts 186 | checkCompSystem ts' 187 | (VPi va@(Ter (Sum _ _ cas) nu) f,Split _ _ ty ces) -> do 188 | check VU ty 189 | rho <- asks env 190 | ty' <- evalTC rho ty 191 | unlessM (a === ty') $ throwError "check: split annotations" 192 | if map labelName cas == map branchName ces 193 | then sequence_ [ checkBranch (lbl,nu) f brc (Ter t rho) va 194 | | (brc, lbl) <- zip ces cas ] 195 | else throwError "case branches does not match the data type" 196 | (VPi va@(Ter (HSum _ _ cas) nu) f,Split _ _ ty ces) -> do 197 | check VU ty 198 | rho <- asks env 199 | ty' <- evalTC rho ty 200 | unlessM (a === ty') $ throwError "check: split annotations" 201 | if map labelName cas == map branchName ces 202 | then sequence_ [ checkBranch (lbl,nu) f brc (Ter t rho) va 203 | | (brc, lbl) <- zip ces cas ] 204 | else throwError "case branches does not match the data type" 205 | (VPi a f,Lam x a' t) -> do 206 | check VU a' 207 | ns <- asks names 208 | rho <- asks env 209 | a'' <- evalTC rho a' 210 | na <- normalTC ns a 211 | unlessM (a === a'') $ 212 | throwError $ "check: lam types don't match" 213 | ++ "\nlambda type annotation: " ++ show a' 214 | ++ "\ndomain of Pi: " ++ show a 215 | ++ "\nnormal form of type: " ++ show na 216 | let var = mkVarNice ns x a 217 | local (addTypeVal (x,a)) $ do 218 | f' <- appTC f var 219 | check f' t 220 | (VSigma a f, Pair t1 t2) -> do 221 | check a t1 222 | v <- evalTyping t1 223 | f' <- appTC f v 224 | check f' t2 225 | (_,Where e d) -> do 226 | local (\tenv@TEnv{indent=i} -> tenv{indent=i + 2}) $ checkDecls d 227 | local (addDecls d) $ check a e 228 | (VU,PathP a e0 e1) -> do 229 | (a0,a1) <- checkPLam (constPath VU) a 230 | check a0 e0 231 | check a1 e1 232 | (VPathP p a0 a1,PLam _ e) -> do 233 | (u0,u1) <- checkPLam p t 234 | ns <- asks names 235 | (nu0,nu1) <- normalTC ns (u0,u1) 236 | (na0,na1) <- normalTC ns (a0,a1) 237 | unlessM (convTC ns a0 u0) $ 238 | throwError $ "Left endpoints don't match for \n" ++ show e ++ "\ngot\n" ++ 239 | show u0 ++ "\nbut expected\n" ++ show a0 ++ 240 | "\n\nNormal forms:\n" ++ show nu0 ++ "\nand\n" ++ show na0 241 | unlessM (convTC ns a1 u1) $ 242 | throwError $ "Right endpoints don't match for \n" ++ show e ++ "\ngot\n" ++ 243 | show u1 ++ "\nbut expected\n" ++ show a1 ++ 244 | "\n\nNormal forms:\n" ++ show nu1 ++ "\nand\n" ++ show na1 245 | (VU,LineP a) -> do 246 | checkPLam (constPath VU) a 247 | return () 248 | (VLineP a,PLam _ e) -> do 249 | checkPLam a t 250 | return () 251 | (VU,V r a b e) -> do 252 | checkII r 253 | check VU b 254 | localM (faceEnv (eqn (r,0))) $ do 255 | check VU a 256 | va <- evalTyping a 257 | vb <- evalTyping b 258 | checkEquiv va vb e 259 | (VV i a b e,Vin s m n) -> do 260 | checkII s 261 | unless (Name i == s) $ 262 | throwError $ "The names " ++ show i ++ " " ++ show s ++ " do not match in Vin" 263 | check b n 264 | localM (faceEnv (eqn (s,0))) $ do 265 | check a m 266 | vm <- evalTyping m 267 | vn <- evalTyping n 268 | ns <- asks names 269 | evm <- appTC (equivFun e) vm 270 | unlessM (convTC ns evm vn) $ 271 | throwError $ "Vin does not match V type" 272 | -- (VU,Glue a ts) -> do 273 | -- check VU a 274 | -- rho <- asks env 275 | -- checkGlue (eval rho a) ts 276 | -- (VGlue va ts,GlueElem u us) -> do 277 | -- check va u 278 | -- vu <- evalTyping u 279 | -- checkGlueElem vu ts us 280 | -- (VCompU va ves,GlueElem u us) -> do 281 | -- check va u 282 | -- vu <- evalTyping u 283 | -- checkGlueElemU vu ves us 284 | _ -> do 285 | v <- infer t 286 | unlessM (v === a) $ 287 | throwError $ "check conv:\n" ++ show v ++ "\n/=\n" ++ show a 288 | 289 | 290 | -- Check a list of declarations 291 | checkDecls :: Decls -> Typing () 292 | checkDecls (MutualDecls _ []) = return () 293 | checkDecls (MutualDecls l d) = do 294 | a <- asks env 295 | let (idents,tele,ters) = (declIdents d,declTele d,declTers d) 296 | ind <- asks indent 297 | trace (replicate ind ' ' ++ "Checking: " ++ unwords idents) 298 | checkTele tele 299 | local (addDecls (MutualDecls l d)) $ do 300 | rho <- asks env 301 | checks (tele,rho) ters 302 | checkDecls (OpaqueDecl _) = return () 303 | checkDecls (TransparentDecl _) = return () 304 | checkDecls TransparentAllDecl = return () 305 | 306 | localM :: (TEnv -> Typing TEnv) -> Typing a -> Typing a 307 | localM f r = do 308 | e <- ask 309 | a <- f e 310 | local (const a) r 311 | 312 | -- Check a telescope 313 | checkTele :: Tele -> Typing () 314 | checkTele [] = return () 315 | checkTele ((x,a):xas) = do 316 | check VU a 317 | localM (addType (x,a)) $ checkTele xas 318 | 319 | -- Check a family 320 | checkFam :: Ter -> Typing () 321 | checkFam (Lam x a b) = do 322 | check VU a 323 | localM (addType (x,a)) $ check VU b 324 | checkFam x = throwError $ "checkFam: " ++ show x 325 | 326 | -- Check that a system is compatible 327 | checkCompSystem :: System Val -> Typing () 328 | checkCompSystem vus = do 329 | ns <- asks names 330 | b <- lift $ lift $ isCompSystem ns vus 331 | unless b (throwError $ "Incompatible system " ++ show vus) 332 | 333 | -- -- Check the values at corresponding faces with a function, assumes 334 | -- -- systems have the same faces 335 | -- checkSystemsWith :: (Show a, Show b) => System a -> System b -> (Eqn -> a -> b -> Typing c) -> Typing () 336 | -- checkSystemsWith (Sys us) (Sys vs) f = sequence_ $ Map.elems $ Map.intersectionWithKey f us vs 337 | -- checkSystemsWith (Triv u) (Triv v) f = f (eqn (0,0)) u v >> return () -- TODO: Does it make sense to use the trivial equation here? 338 | -- checkSystemsWith x y _= throwError $ "checkSystemsWith: cannot compare " ++ show x ++ " and " ++ show y 339 | 340 | -- Check the faces of a system 341 | checkSystemWith :: System a -> (Eqn -> a -> Typing b) -> Typing () 342 | checkSystemWith (Sys us) f = sequence_ $ Map.elems $ Map.mapWithKey f us 343 | checkSystemWith (Triv u) f = f (eqn (0,0)) u >> return () -- TODO: Does it make sense to use the trivial equation here? 344 | 345 | -- Check a glueElem 346 | -- checkGlueElem :: Val -> System Val -> System Ter -> Typing () 347 | -- checkGlueElem vu ts us = do 348 | -- unless (keys ts == keys us) 349 | -- (throwError ("Keys don't match in " ++ show ts ++ " and " ++ show us)) 350 | -- rho <- asks env 351 | -- checkSystemsWith ts us 352 | -- (\alpha vt u -> local (faceEnv alpha) $ check (equivDom vt) u) 353 | -- let vus = evalSystem rho us 354 | -- checkSystemsWith ts vus (\alpha vt vAlpha -> 355 | -- unlessM (app (equivFun vt) vAlpha === (vu `subst` alpha)) $ 356 | -- throwError $ "Image of glue component " ++ show vAlpha ++ 357 | -- " doesn't match " ++ show vu) 358 | -- checkCompSystem vus 359 | 360 | -- Check a glueElem against VComp _ ves 361 | -- checkGlueElemU :: Val -> System Val -> System Ter -> Typing () 362 | -- checkGlueElemU vu ves us = do 363 | -- unless (keys ves == keys us) 364 | -- (throwError ("Keys don't match in " ++ show ves ++ " and " ++ show us)) 365 | -- rho <- asks env 366 | -- checkSystemsWith ves us 367 | -- (\alpha ve u -> local (faceEnv alpha) $ check (ve @@ One) u) 368 | -- let vus = evalSystem rho us 369 | -- checkSystemsWith ves vus (\alpha ve vAlpha -> 370 | -- unlessM (eqFun ve vAlpha === (vu `subst` alpha)) $ 371 | -- throwError $ "Transport of glueElem (for compU) component " ++ show vAlpha ++ 372 | -- " doesn't match " ++ show vu) 373 | -- checkCompSystem vus 374 | 375 | -- checkGlue :: Val -> System Ter -> Typing () 376 | -- checkGlue va ts = do 377 | -- checkSystemWith ts (\alpha tAlpha -> checkEquiv (va `subst` alpha) tAlpha) 378 | -- rho <- asks env 379 | -- checkCompSystem (evalSystem rho ts) 380 | 381 | -- An iso for a type b is a five-tuple: (a,f,g,s,t) where 382 | -- a : U 383 | -- f : a -> b 384 | -- g : b -> a 385 | -- s : forall (y : b), f (g y) = y 386 | -- t : forall (x : a), g (f x) = x 387 | -- mkIso :: Val -> Val 388 | -- mkIso vb = eval rho $ 389 | -- Sigma $ Lam "a" U $ 390 | -- Sigma $ Lam "f" (Pi (Lam "_" a b)) $ 391 | -- Sigma $ Lam "g" (Pi (Lam "_" b a)) $ 392 | -- Sigma $ Lam "s" (Pi (Lam "y" b $ PathP (PLam (N "_") b) (App f (App g y)) y)) $ 393 | -- Pi (Lam "x" a $ PathP (PLam (N "_") a) (App g (App f x)) x) 394 | -- where [a,b,f,g,x,y] = map Var ["a","b","f","g","x","y"] 395 | -- rho = upd ("b",vb) emptyEnv 396 | 397 | -- An equivalence for a type a is a triple (t,f,p) where 398 | -- t : U 399 | -- f : t -> a 400 | -- p : (x : a) -> isContr ((y:t) * Id a x (f y)) 401 | -- with isContr c = (z : c) * ((z' : C) -> Id c z z') 402 | -- mkEquiv :: Val -> Val 403 | -- mkEquiv va = eval rho $ 404 | -- Sigma $ Lam "t" U $ 405 | -- Sigma $ Lam "f" (Pi (Lam "_" t a)) $ 406 | -- Pi (Lam "x" a $ iscontrfib) 407 | -- where [a,b,f,x,y,s,t,z] = map Var ["a","b","f","x","y","s","t","z"] 408 | -- rho = upd ("a",va) emptyEnv 409 | -- fib = Sigma $ Lam "y" t (PathP (PLam (N "_") a) x (App f y)) 410 | -- iscontrfib = Sigma $ Lam "s" fib $ 411 | -- Pi $ Lam "z" fib $ PathP (PLam (N "_") fib) s z 412 | 413 | -- RedPRL style equiv between A and B: 414 | -- f : A -> B 415 | -- p : (x : B) -> isContr ((y : A) * Path B (f y) x) 416 | -- with isContr C = (s : C) * ((z : C) -> Path C z s) 417 | mkEquiv :: Val -> Val -> Typing Val 418 | mkEquiv va vb = evalTC rho $ 419 | Sigma $ Lam "f" (Pi (Lam "_" a b)) $ 420 | Pi (Lam "x" b iscontrfib) 421 | where [a,b,f,x,y,s,z] = map Var ["a","b","f","x","y","s","z"] 422 | rho = upd ("a",va) (upd ("b",vb) emptyEnv) 423 | fib = Sigma $ Lam "y" a (PathP (PLam (N "_") b) (App f y) x) 424 | iscontrfib = Sigma $ Lam "s" fib $ 425 | Pi $ Lam "z" fib $ PathP (PLam (N "_") fib) z s 426 | 427 | 428 | -- Part 3 style equiv between A and B: 429 | -- f : A -> B 430 | -- p : (x : B) -> isContr ((y : A) * Path B (f y) x) 431 | -- with isContr C = C * ((c c' : C) -> Path C c c') 432 | -- mkEquiv :: Val -> Val -> Typing Val 433 | -- mkEquiv va vb = evalTC rho $ 434 | -- Sigma $ Lam "f" (Pi (Lam "_" a b)) $ 435 | -- Pi (Lam "x" b iscontrfib) 436 | -- where [a,b,f,x,y,s,z] = map Var ["a","b","f","x","y","s","z"] 437 | -- rho = upd ("a",va) (upd ("b",vb) emptyEnv) 438 | -- fib = Sigma $ Lam "y" a (PathP (PLam (N "_") b) (App f y) x) 439 | -- iscontrfib = Sigma $ Lam "_" fib $ 440 | -- Pi $ Lam "s" fib $ Pi $ Lam "z" fib $ PathP (PLam (N "_") fib) s z 441 | 442 | checkEquiv :: Val -> Val -> Ter -> Typing () 443 | checkEquiv va vb equiv = do 444 | e <- mkEquiv va vb 445 | check e equiv 446 | 447 | -- checkIso :: Val -> Ter -> Typing () 448 | -- checkIso vb iso = check (mkIso vb) iso 449 | 450 | checkBranch :: (Label,Env) -> Val -> Branch -> Val -> Val -> Typing () 451 | checkBranch (OLabel _ tele,nu) f (OBranch c ns e) _ _ = do 452 | ns' <- asks names 453 | ns'' <- mkVars ns' tele nu 454 | let us = map snd ns'' 455 | local (addBranch (zip ns us) nu) $ do 456 | f' <- appTC f (VCon c us) 457 | check f' e 458 | checkBranch (PLabel _ tele is ts,nu) f (PBranch c ns js e) g va = do 459 | ns' <- asks names 460 | -- mapM_ checkFresh js 461 | us <- mkVars ns' tele nu 462 | let vus = map snd us 463 | js' = map Name js 464 | vts <- lift $ lift $ evalSystem (subs (zip is js') (upds us nu)) ts 465 | vgts <- lift $ lift $ runSystem $ intersectWith app (border g vts) vts 466 | local (addSubs (zip js js') . addBranch (zip ns vus) nu) $ do 467 | f' <- appTC f (VPCon c va vus js') 468 | check f' e 469 | ve <- evalTyping e -- TODO: combine with next two lines? 470 | let veborder = border ve vts :: System Val 471 | unlessM (veborder === vgts) $ 472 | throwError $ "Faces in branch for " ++ show c ++ " don't match:" 473 | ++ "\ngot\n" ++ show veborder ++ "\nbut expected\n" 474 | -- ++ show vgts 475 | 476 | checkII :: II -> Typing () 477 | checkII phi = do 478 | rho <- asks env 479 | let dom = domainEnv rho 480 | unless (all (`elem` dom) (supportII phi)) $ 481 | throwError $ "checkII: " ++ show phi 482 | 483 | checkFresh :: Name -> Typing () 484 | checkFresh i = do 485 | rho <- asks env 486 | when (i `occurs` rho) 487 | (throwError $ show i ++ " is already declared") 488 | 489 | -- Check that a term is a PLam and output the source and target 490 | checkPLam :: Val -> Ter -> Typing (Val,Val) 491 | checkPLam v (PLam i a) = do 492 | rho <- asks env 493 | -- checkFresh i 494 | local (addSub (i,Name i)) $ do 495 | vi <- v @@@ i 496 | check vi a 497 | (,) <$> evalTC (sub (i,Dir 0) rho) a <*> evalTC (sub (i,Dir 1) rho) a 498 | checkPLam v t = do 499 | vt <- infer t 500 | case vt of 501 | VPathP a a0 a1 -> do 502 | unlessM (a === v) $ throwError ( 503 | "checkPLam\n" ++ show v ++ "\n/=\n" ++ show a) 504 | return (a0,a1) 505 | VLineP a -> do 506 | unlessM (a === v) $ throwError ( 507 | "checkPLam\n" ++ show v ++ "\n/=\n" ++ show a) 508 | -- vt0 <- vt @@@ Dir Zero 509 | -- vt1 <- vt @@@ Dir One 510 | return (VAppII vt 0,VAppII vt 1) 511 | _ -> throwError $ show vt ++ " is not a path" 512 | 513 | checkPLamSystem :: II -> Ter -> Val -> System Ter -> Typing () 514 | checkPLamSystem r u0 va (Sys us) = do 515 | T.sequence $ Map.mapWithKey (\eqn u -> 516 | localM (faceEnv eqn) $ do 517 | rhoeqn <- asks env 518 | va' <- lift $ lift $ va `face` eqn 519 | checkPLam va' u 520 | vu <- evalTC rhoeqn u 521 | vur <- vu @@@ evalII rhoeqn r 522 | vu0 <- evalTC rhoeqn u0 523 | unlessM (vur === vu0) $ 524 | throwError $ "\nThe face " ++ show eqn ++ " of the system\n" ++ 525 | show (Sys us) ++ "\nat " ++ show r ++ " is " ++ show vur ++ 526 | "\nwhich does not match the cap " ++ show vu0) us 527 | -- Check that the system ps is compatible. 528 | rho <- asks env 529 | us' <- lift $ lift $ evalSystem rho (Sys us) 530 | checkCompSystem us' 531 | checkPLamSystem r u0 va (Triv u) = do 532 | rho <- asks env 533 | checkPLam va u 534 | vu <- evalTC rho u 535 | vur <- vu @@@ evalII rho r 536 | vu0 <- evalTC rho u0 537 | unlessM (vur === vu0) $ 538 | throwError ("Trivial system " ++ show vur ++ " at " ++ show r ++ 539 | "\ndoes not match the cap " ++ show vu0) 540 | 541 | checks :: (Tele,Env) -> [Ter] -> Typing () 542 | checks ([],_) [] = return () 543 | checks ((x,a):xas,nu) (e:es) = do 544 | va <- evalTC nu a 545 | check va e 546 | v' <- evalTyping e 547 | checks (xas,upd (x,v') nu) es 548 | checks _ _ = throwError "checks: incorrect number of arguments" 549 | 550 | -- infer the type of e 551 | infer :: Ter -> Typing Val 552 | infer e = case e of 553 | U -> return VU -- U : U 554 | Var n -> do 555 | rho <- asks env 556 | lift $ lift $ lookType n rho 557 | App t u -> do 558 | c <- infer t 559 | case c of 560 | VPi a f -> do 561 | check a u 562 | v <- evalTyping u 563 | appTC f v 564 | _ -> throwError $ show c ++ " is not a product" 565 | Fst t -> do 566 | c <- infer t 567 | case c of 568 | VSigma a f -> return a 569 | _ -> throwError $ show c ++ " is not a sigma-type" 570 | Snd t -> do 571 | c <- infer t 572 | case c of 573 | VSigma a f -> do 574 | v <- evalTyping t 575 | appTC f (fstVal v) 576 | _ -> throwError $ show c ++ " is not a sigma-type" 577 | Where t d -> do 578 | checkDecls d 579 | local (addDecls d) $ infer t 580 | Vproj r o a b e -> do 581 | check VU (V r a b e) 582 | v <- evalTyping (V r a b e) 583 | check v o 584 | evalTyping b 585 | -- UnGlueElem e a ts -> do 586 | -- check VU (Glue a ts) 587 | -- vgl <- evalTyping (Glue a ts) 588 | -- check vgl e 589 | -- va <- evalTyping a 590 | -- return va 591 | AppII e r -> do 592 | checkII r 593 | t <- infer e 594 | case t of 595 | VPathP a _ _ -> a @@@ r 596 | VLineP a -> a @@@ r 597 | _ -> throwError (show e ++ " is not a path") 598 | HCom r s a us u0 -> do 599 | checkII r 600 | checkII s 601 | check VU a 602 | va <- evalTyping a 603 | check va u0 604 | -- check that it's a system 605 | checkPLamSystem r u0 (constPath va) us 606 | return va 607 | Com r s a us u0 -> do 608 | checkII r 609 | checkII s 610 | checkPLam (constPath VU) a 611 | va <- evalTyping a 612 | var <- va @@@ r 613 | check var u0 614 | checkPLamSystem r u0 va us 615 | va @@@ s 616 | Coe r s a u -> do 617 | checkII r 618 | checkII s 619 | checkPLam (constPath VU) a 620 | va <- evalTyping a 621 | var <- va @@@ r 622 | check var u 623 | va @@@ s 624 | PCon c a es phis -> do 625 | check VU a 626 | va <- evalTyping a 627 | (bs,nu) <- getLblType c va 628 | checks (bs,nu) es 629 | mapM_ checkII phis 630 | return va 631 | _ -> throwError ("infer " ++ show e) 632 | 633 | -- Not used since we have U : U 634 | -- 635 | -- (=?=) :: Typing Ter -> Ter -> Typing () 636 | -- m =?= s2 = do 637 | -- s1 <- m 638 | -- unless (s1 == s2) $ throwError (show s1 ++ " =/= " ++ show s2) 639 | -- 640 | -- checkTs :: [(String,Ter)] -> Typing () 641 | -- checkTs [] = return () 642 | -- checkTs ((x,a):xas) = do 643 | -- checkType a 644 | -- local (addType (x,a)) (checkTs xas) 645 | -- 646 | -- checkType :: Ter -> Typing () 647 | -- checkType t = case t of 648 | -- U -> return () 649 | -- Pi a (Lam x b) -> do 650 | -- checkType a 651 | -- local (addType (x,a)) (checkType b) 652 | -- _ -> infer t =?= U 653 | -------------------------------------------------------------------------------- /examples/bool.ytt: -------------------------------------------------------------------------------- 1 | module bool where 2 | 3 | import univalence 4 | import hedberg 5 | 6 | data bool = false | true 7 | 8 | -- Proof that bool is a set using hedberg: 9 | caseBool (A : U) (f t : A) : bool -> A = split 10 | false -> f 11 | true -> t 12 | 13 | falseNeqTrue : not (Path bool false true) = 14 | \(h : Path bool false true) -> subst bool (caseBool U bool N0) false true h false 15 | 16 | trueNeqFalse : not (Path bool true false) = 17 | \(h : Path bool true false) -> subst bool (caseBool U N0 bool) true false h true 18 | 19 | boolDec : (b1 b2 : bool) -> dec (Path bool b1 b2) = split 20 | false -> rem 21 | where 22 | rem : (b : bool) -> dec (Path bool false b) = split 23 | false -> inl ( false) 24 | true -> inr falseNeqTrue 25 | true -> rem 26 | where 27 | rem : (b : bool) -> dec (Path bool true b) = split 28 | false -> inr trueNeqFalse 29 | true -> inl ( true) 30 | 31 | setbool : set bool = hedberg bool boolDec 32 | 33 | -- Boolean negation 34 | negBool : bool -> bool = split 35 | false -> true 36 | true -> false 37 | 38 | -- negBool is involutive: 39 | negBoolK : (b : bool) -> Path bool (negBool (negBool b)) b = split 40 | false -> false 41 | true -> true 42 | 43 | injNegBool : (b b' : bool) -> Path bool (negBool b) (negBool b') -> Path bool b b' = split 44 | false -> split@((b' : bool) -> Path bool true (negBool b') -> Path bool false b') with 45 | false -> \(_ : Path bool true true) -> <_> false 46 | true -> \(p : Path bool true false) -> efq (Path bool false true) (trueNeqFalse p) 47 | true -> split@((b' : bool) -> Path bool false (negBool b') -> Path bool true b') with 48 | false -> \(p : Path bool false true) -> efq (Path bool true false) (falseNeqTrue p) 49 | true -> \(_ : Path bool false false) -> <_> true 50 | 51 | ctr (b : bool) : fiber bool bool negBool b = (negBool b,negBoolK b) 52 | 53 | gengoal (A : U) (hA : set A) (x y : A) (p : Path A y x) : (z : A) (r : Path A y z) (q : Path A z x) -> 54 | PathP ( Path A (r @ i) x) p q = 55 | J A y (\(z : A) (r : Path A y z) -> (q : Path A z x) -> PathP ( Path A (r @ i) x) p q) 56 | (hA y x p) 57 | 58 | contr (b : bool) (x y : fiber bool bool negBool b) : Path (fiber bool bool negBool b) x y = 59 | let x1 : bool = x.1 60 | x2 : Path bool (negBool x1) b = x.2 61 | y1 : bool = y.1 62 | y2 : Path bool (negBool y1) b = y.2 63 | goal1 : Path bool x1 y1 = 64 | injNegBool x1 y1 ( hcom 1->0 bool [(i=0) -> x2, (i=1) -> y2] b) 65 | goal2 : PathP ( Path bool (negBool (goal1 @ i)) b) x2 y2 = undefined 66 | -- gengoal bool setbool b (negBool x1) x2 (negBool y1) ( negBool (goal1 @ i)) y2 67 | in (goal1 @ i,goal2 @ i) 68 | 69 | negBoolEquivInhProp : equivInhProp bool bool = 70 | (negBool,\(b : bool) -> (ctr b,contr b)) 71 | 72 | negBoolEquiv : equiv bool bool = equivInhPropToEquiv bool bool negBoolEquivInhProp 73 | 74 | pathNegbool : Path U bool bool = ua bool bool negBoolEquiv 75 | 76 | test0 : bool = coe 0->1 pathNegbool false 77 | test1 : bool = coe 1->0 pathNegbool true 78 | 79 | prf0 : PathP ( pathNegbool @ i) false true = 80 | coe 0->i pathNegbool false 81 | 82 | prf1 : PathP ( pathNegbool @ i) true false = 83 | coe 1->i pathNegbool false 84 | -------------------------------------------------------------------------------- /examples/circle.ytt: -------------------------------------------------------------------------------- 1 | -- The circle as a HIT. 2 | module circle where 3 | 4 | import bool 5 | import int 6 | 7 | data S1 = base 8 | | loop [ (i=0) -> base 9 | , (i=1) -> base] 10 | 11 | loopS1 : U = Path S1 base base 12 | 13 | loop1 : loopS1 = loop{S1} @ i 14 | 15 | invLoop : loopS1 = sym S1 base base loop1 16 | 17 | moebius : S1 -> U = split 18 | base -> bool 19 | loop @ i -> pathNegbool @ i 20 | 21 | helix : S1 -> U = split 22 | base -> Z 23 | loop @ i -> pathSucZ @ i 24 | 25 | winding (p : loopS1) : Z = trans Z Z rem zeroZ 26 | where 27 | rem : Path U Z Z = helix (p @ i) 28 | 29 | compS1 : loopS1 -> loopS1 -> loopS1 = compPath S1 base base base 30 | 31 | -- Examples: 32 | loopZ1 : Z = winding loop1 33 | loopZ2 : Z = winding (compS1 loop1 loop1) 34 | loopZ3 : Z = winding (compS1 loop1 (compS1 loop1 loop1)) 35 | loopZN1 : Z = winding invLoop 36 | loopZ0 : Z = winding (compS1 loop1 invLoop) 37 | loopZ4 : Z = winding (compS1 (compS1 loop1 loop1) (compS1 loop1 loop1)) 38 | loopZ4' : Z = winding (compS1 loop1 (compS1 loop1 (compS1 loop1 loop1))) 39 | loopZ5 : Z = winding (compS1 loop1 (compS1 loop1 (compS1 loop1 (compS1 loop1 loop1)))) 40 | 41 | -- They compute properly! 42 | test : Path Z loopZ3 (pos (suc (suc (suc zero)))) = <_> loopZ3 43 | test : Path Z loopZN1 (neg zero) = <_> loopZN1 44 | test : Path Z loopZ0 (pos zero) = <_> loopZ0 45 | test : Path Z loopZ5 (pos (suc (suc (suc (suc (suc zero)))))) = <_> loopZ5 46 | 47 | -- mLoop : (x : S1) -> Path S1 x x = split 48 | -- base -> loop1 49 | -- loop @ i -> constSquare S1 base loop1 @ i 50 | 51 | -- mult (x : S1) : S1 -> S1 = split 52 | -- base -> x 53 | -- loop @ i -> mLoop x @ i 54 | 55 | -- square (x : S1) : S1 = mult x x 56 | 57 | -- doubleLoop (l : loopS1) : loopS1 = square (l @ i) 58 | -- tripleLoop (l : loopS1) : loopS1 = mult (l @ i) (square (l @ i)) 59 | 60 | -- loopZ4 : Z = winding (doubleLoop (compS1 loop1 loop1)) 61 | -- loopZ8 : Z = winding (doubleLoop (doubleLoop (compS1 loop1 loop1))) 62 | 63 | -- triv : loopS1 = base 64 | 65 | -- -- A nice example of a homotopy on the circle. The path going halfway 66 | -- -- around the circle and then back is contractible: 67 | -- hmtpy : Path loopS1 ( base) ( loop{S1} @ (i /\ -i)) = 68 | -- loop{S1} @ j /\ i /\ -i 69 | 70 | -- circleelim (X : U) (x : X) (p : Path X x x) : S1 -> X = split 71 | -- base -> x 72 | -- loop @ i -> p @ i 73 | 74 | -- apcircleelim (A B : U) (x : A) (p : Path A x x) (f : A -> B) : 75 | -- (z : S1) -> Path B (f (circleelim A x p z)) 76 | -- (circleelim B (f x) ( f (p @ i)) z) = split 77 | -- base -> <_> f x 78 | -- loop @ i -> <_> f (p @ i) 79 | 80 | 81 | -- -- a special case, Lemmas 6.2.5-6.2.9 in the book 82 | 83 | -- aLoop (A:U) : U = (a:A) * Path A a a 84 | 85 | -- phi (A:U) (al : aLoop A) : S1 -> A = split 86 | -- base -> al.1 87 | -- loop @ i -> (al.2)@ i 88 | 89 | -- psi (A:U) (f:S1 -> A) : aLoop A = (f base,f (loop1@i)) 90 | 91 | -- rem (A:U) (f : S1 -> A) : (u : S1) -> Path A (phi A (psi A f) u) (f u) = split 92 | -- base -> refl A (f base) 93 | -- loop @ i -> f (loop1@i) 94 | 95 | -- lem (A:U) (f : S1 -> A) : Path (S1 -> A) (phi A (psi A f)) f = 96 | -- \ (x:S1) -> (rem A f x) @ i 97 | 98 | -- thm (A:U) : Path U (aLoop A) (S1 -> A) = isoPath T0 T1 f g t s 99 | -- where T0 : U = aLoop A 100 | -- T1 : U = S1 -> A 101 | -- f : T0 -> T1 = phi A 102 | -- g : T1 -> T0 = psi A 103 | -- s (x:T0) : Path T0 (g (f x)) x = refl T0 x 104 | -- t : (y:T1) -> Path T1 (f (g y)) y = lem A 105 | 106 | -------------------------------------------------------------------------------- /examples/hedberg.ytt: -------------------------------------------------------------------------------- 1 | -- Hedberg's lemma: a type with decidable equality is a set 2 | module hedberg where 3 | 4 | import prelude 5 | 6 | hedbergLemma (A: U) (a : A) (f : (x : A) -> Path A a x -> Path A a x) : 7 | (b : A) (p : Path A a b) -> Square A a a a b (<_> a) p (f a (<_> a)) (f b p) = 8 | J A a 9 | (\(b : A) (p : Path A a b) -> Square A a a a b (<_> a) p (f a (<_> a)) (f b p)) 10 | (<_> f a (<_> a)) 11 | 12 | hedbergStable (A : U) (a b : A) (h : (x : A) -> stable (Path A a x)) 13 | (p q : Path A a b) : Path (Path A a b) p q = 14 | hcom 0->1 A [ (j = 0) -> rem2 @ i 15 | , (j = 1) -> rem3 @ i 16 | , (i = 0) -> r 17 | , (i = 1) -> rem4 @ j] a 18 | where 19 | ra : Path A a a = <_> a 20 | rem1 (x : A) : exConst (Path A a x) = stableConst (Path A a x) (h x) 21 | f (x : A) : Path A a x -> Path A a x = (rem1 x).1 22 | fIsConst (x : A) : const (Path A a x) (f x) = (rem1 x).2 23 | rem4 : Square A a a b b ra (refl A b) (f b p) (f b q) = fIsConst b p q 24 | r : Path A a a = f a ra 25 | rem2 : Square A a a a b ra p r (f b p) = hedbergLemma A a f b p 26 | rem3 : Square A a a a b ra q r (f b q) = hedbergLemma A a f b q 27 | 28 | hedbergS (A:U) (h : (a x:A) -> stable (Path A a x)) : set A = 29 | \(a b : A) -> hedbergStable A a b (h a) 30 | 31 | hedberg (A : U) (h : discrete A) : set A = 32 | \(a b : A) -> hedbergStable A a b (\(b : A) -> decStable (Path A a b) (h a b)) 33 | 34 | -------------------------------------------------------------------------------- /examples/int.ytt: -------------------------------------------------------------------------------- 1 | module int where 2 | 3 | import univalence 4 | import hedberg 5 | 6 | data nat = zero | suc (n : nat) 7 | 8 | pred : nat -> nat = split 9 | zero -> zero 10 | suc n -> n 11 | 12 | data Z = pos (n : nat) | neg (n : nat) 13 | 14 | zeroZ : Z = pos zero 15 | 16 | predZ : Z -> Z = split 17 | pos u -> auxpredZ u 18 | where 19 | auxpredZ : nat -> Z = split 20 | zero -> neg zero 21 | suc n -> pos n 22 | neg v -> neg (suc v) 23 | 24 | sucZ : Z -> Z = split 25 | pos u -> pos (suc u) 26 | neg v -> auxsucZ v 27 | where 28 | auxsucZ : nat -> Z = split 29 | zero -> pos zero 30 | suc n -> neg n 31 | 32 | predsucZ : (x : Z) -> Path Z (predZ (sucZ x)) x = split 33 | pos u -> <_> pos u 34 | neg v -> lem v 35 | where 36 | lem : (u : nat) -> Path Z (predZ (sucZ (neg u))) (neg u) = split 37 | zero -> <_> neg zero 38 | suc n -> <_> neg (suc n) 39 | 40 | sucpredZ : (x : Z) -> Path Z (sucZ (predZ x)) x = split 41 | pos u -> lem u 42 | where 43 | lem : (u : nat) -> Path Z (sucZ (predZ (pos u))) (pos u) = split 44 | zero -> <_> pos zero 45 | suc n -> <_> pos (suc n) 46 | neg v -> <_> neg v 47 | 48 | 49 | 50 | caseNat (A : U) (a0 aS : A) : nat -> A = split 51 | zero -> a0 52 | suc n -> aS 53 | 54 | caseDNat (P:nat -> U) (a0 :P zero) (aS : (n:nat) -> P (suc n)) 55 | : (n:nat) -> P n = split 56 | zero -> a0 57 | suc n -> aS n 58 | 59 | znots (n : nat) : not (Path nat zero (suc n)) = 60 | \(h : Path nat zero (suc n)) -> subst nat (caseNat U nat N0) zero (suc n) h zero 61 | 62 | snotz (n : nat) : not (Path nat (suc n) zero) = 63 | \(h : Path nat (suc n) zero) -> znots n (sym nat (suc n) zero h) 64 | 65 | sucInj (n m : nat) (p : Path nat (suc n) (suc m)) : Path nat n m = 66 | pred (p @ i) 67 | 68 | discreteNat : discrete nat = split 69 | zero -> caseDNat (\(m : nat) -> dec (Path nat zero m)) (inl (<_> zero)) (\(m : nat) -> inr (znots m)) 70 | suc n -> caseDNat (\(m : nat) -> dec (Path nat (suc n) m)) (inr (snotz n)) 71 | (\(m : nat) -> decEqCong (Path nat n m) (Path nat (suc n) (suc m)) (\(p : Path nat n m) -> suc (p @ i)) 72 | (sucInj n m) (discreteNat n m)) 73 | 74 | posNotneg (a b : nat) (h : Path Z (pos a) (neg b)) : N0 = subst Z T (pos a) (neg b) h tt 75 | where 76 | T : Z -> U = split 77 | pos _ -> Unit 78 | neg _ -> N0 79 | 80 | negNotpos (a b : nat) (h : Path Z (neg b) (pos a)) : N0 = subst Z T (neg b) (pos a) h tt 81 | where 82 | T : Z -> U = split 83 | pos _ -> N0 84 | neg _ -> Unit 85 | 86 | injPos (a b : nat) (h : Path Z (pos a) (pos b)) : Path nat a b = 87 | subst Z T (pos a) (pos b) h (<_> a) 88 | where 89 | T : Z -> U = split 90 | pos c -> Path nat a c 91 | neg _ -> N0 92 | 93 | injNeg (a b : nat) (h : Path Z (neg a) (neg b)) : Path nat a b = 94 | subst Z T (neg a) (neg b) h (<_> a) 95 | where 96 | T : Z -> U = split 97 | pos _ -> N0 98 | neg c -> Path nat a c 99 | 100 | discreteZ : discrete Z = split 101 | pos a -> split@((z1 : Z) -> dec (Path Z (pos a) z1)) with 102 | pos a1 -> let rem : dec (Path nat a a1) -> dec (Path Z (pos a) (pos a1)) = split 103 | inl p -> inl ( pos (p @ i)) 104 | inr h -> inr (\(p : Path Z (pos a) (pos a1)) -> h (injPos a a1 p)) 105 | in rem (discreteNat a a1) 106 | neg b -> inr (posNotneg a b) 107 | neg b -> split@((z1 : Z) -> dec (Path Z (neg b) z1)) with 108 | pos a -> inr (negNotpos a b) 109 | neg b1 -> let rem : dec (Path nat b b1) -> dec (Path Z (neg b) (neg b1)) = split 110 | inl p -> inl ( neg (p @ i)) 111 | inr h -> inr (\(p : Path Z (neg b) (neg b1)) -> h (injNeg b b1 p)) 112 | in rem (discreteNat b b1) 113 | 114 | ZSet : set Z = hedberg Z discreteZ 115 | 116 | 117 | ctr (y : Z) : fiber Z Z sucZ y = (predZ y, sucpredZ y @ i) 118 | 119 | gengoal (A : U) (hA : set A) (x y : A) (p : Path A y x) : (z : A) (r : Path A y z) (q : Path A z x) -> 120 | PathP ( Path A (r @ i) x) p q = 121 | J A y (\(z : A) (r : Path A y z) -> (q : Path A z x) -> PathP ( Path A (r @ i) x) p q) 122 | (hA y x p) 123 | 124 | contr (y : Z) (y' : fiber Z Z sucZ y) : Path (fiber Z Z sucZ y) y' (ctr y) = undefined 125 | -- let p1 : Path Z y'.1 (predZ y) = 126 | -- hcom 0->1 Z [(i=0) -> predsucZ y'.1,(i=1) -> predZ (y'.2 @ j)] (predZ (sucZ y'.1)) 127 | -- prf1 : Path Z (sucZ y'.1) (sucZ (predZ y)) = sucZ (p1 @ i) 128 | -- prf2 : Path Z (sucZ (predZ y)) y = sucpredZ y 129 | -- p2 : PathP ( Path Z (prf1 @ i) y) y'.2 prf2 = 130 | -- gengoal Z ZSet y (sucZ y'.1) y'.2 (sucZ (predZ y)) prf1 prf2 131 | -- in (p1 @ i,p2 @ i) 132 | 133 | equivSucZ : equiv Z Z = (sucZ,\(y : Z) -> (ctr y,contr y)) 134 | 135 | pathSucZ : Path U Z Z = ua Z Z equivSucZ 136 | 137 | foo : Z = coe 0->1 pathSucZ (pos zero) 138 | bar : Z = coe 1->0 pathSucZ (pos zero) 139 | prf : PathP ( ua Z Z equivSucZ @ i) bar (pos zero) = coe 1->i pathSucZ (pos zero) 140 | nprf : PathP ( ua Z Z equivSucZ @ i) bar (pos zero) = 141 | Vin i (neg zero) (hcom 1->0 Z [ (i = 0) -> <_> pos zero, (i = 1) -> <_> pos zero ] (pos zero)) 142 | 143 | 144 | 145 | -------------------------------------------------------------------------------- /examples/prelude.ytt: -------------------------------------------------------------------------------- 1 | module prelude where 2 | 3 | Path (A : U) (a0 a1 : A) : U = PathP ( A) a0 a1 4 | Line (A : U) : U = LineP ( A) 5 | 6 | -- u 7 | -- a0 -----> a1 8 | -- | | 9 | -- r0 | | r1 10 | -- | | 11 | -- V V 12 | -- b0 -----> b1 13 | -- v 14 | Square (A : U) (a0 a1 b0 b1 : A) 15 | (u : Path A a0 a1) (v : Path A b0 b1) 16 | (r0 : Path A a0 b0) (r1 : Path A a1 b1) : U 17 | = PathP ( (PathP ( A) (u @ i) (v @ i))) r0 r1 18 | 19 | refl (A : U) (a : A) : Path A a a = <_> a 20 | 21 | reflLine (A : U) (a : A) : Line A = <_> a 22 | 23 | testEta (A : U) (a b : A) (p : Path A a b) : Path (Path A a b) p p = 24 | refl (Path A a b) ( p @ i) 25 | 26 | mapOnPath (A B : U) (f : A -> B) (a b : A) 27 | (p : Path A a b) : Path B (f a) (f b) = f (p @ i) 28 | 29 | funExt (A : U) (B : A -> U) (f g : (x : A) -> B x) 30 | (p : (x : A) -> Path (B x) (f x) (g x)) : 31 | Path ((y : A) -> B y) f g = \(a : A) -> (p a) @ i 32 | 33 | trans (A B : U) (p : Path U A B) (a : A) : B = coe 0->1 p a 34 | transNeg (A B : U) (p : Path U A B) (b : B) : A = coe 1->0 p b 35 | 36 | transLine (p : Line U) (a : p @ 0) : p @ 1 = coe 0->1 p a 37 | 38 | transFill (A B : U) (p : Path U A B) (a : A) : 39 | PathP p a (trans A B p a) = coe 0->i p a 40 | 41 | -- This proof is really slick! 42 | -- Compare with: https://github.com/mortberg/cubicaltt/blob/master/examples/prelude.ctt#L25 43 | transK (A B : U) (p : Path U A B) (a : A) : 44 | Path A a (transNeg A B p (trans A B p a)) = 45 | coe i->0 p (coe 0->i p a) 46 | 47 | -- This does not work 48 | -- transNegK (A B : U) (p : Path U A B) (b : B) : 49 | -- Path B b (coe 0->1 p (coe 1->0 p b)) = 50 | -- coe 0->i p (coe i->0 p b) 51 | 52 | transNegK (A B : U) (p : Path U A B) (b : B) : 53 | Path B (coe 0->1 p (coe 1->0 p b)) b = 54 | coe i->1 p (coe 1->i p b) 55 | 56 | -- subst can be defined using trans: 57 | substTrans (A : U) (P : A -> U) (a b : A) (p : Path A a b) (e : P a) : P b = 58 | trans (P a) (P b) ( P (p @ i)) e 59 | 60 | -- Or even better using coe directly: 61 | subst (A : U) (P : A -> U) (a b : A) (p : Path A a b) (e : P a) : P b = 62 | coe 0->1 ( P (p @ i)) e 63 | 64 | substEq (A : U) (P : A -> U) (a : A) (e : P a) : 65 | Path (P a) e (subst A P a a (<_> a) e) = coe 0->i (<_> P a) e 66 | 67 | compPath (A : U) (a b c : A) (p : Path A a b) (q : Path A b c) : Path A a c = 68 | hcom 0->1 A [ (i=0) -> a, (i=1) -> q ] (p @ i) 69 | 70 | sym (A : U) (a b : A) (p : Path A a b) : Path A b a = 71 | hcom 0->1 A [ (i=0) -> p, (i=1) -> <_> a ] a 72 | 73 | symDep (A B : U) (P : Path U A B) (a : A) (b : B) (p : PathP P a b) : 74 | (PathP (sym U A B P) b a) = 75 | com 0->1 ( hcom 0->j U [ (i=0) -> P, (i=1) -> <_> A ] A) 76 | [ (i=0) -> p , (i=1) -> <_> a ] a 77 | 78 | singl (A : U) (a : A) : U = (x : A) * Path A a x 79 | 80 | -- The connection p @ i /\ j. 81 | -- Inspired by: https://github.com/RedPRL/sml-redprl/blob/master/example/connection.prl 82 | connAnd (A : U) (a b : A) (p : Path A a b) : 83 | PathP ( Path A a (p @ i)) (<_> a) p = 84 | hcom 0->1 A [ (i=0) -> connAndWeak @ 0 , (i=1) -> connAndWeak @ j 85 | , (j=0) -> connAndWeak @ 0 , (j=1) -> connAndWeak @ i 86 | -- The diagonal is not strictly necessary, but it is cool! 87 | , (i=j) -> connAndWeak @ i ] a 88 | where connAndWeak : Line (Line A) = 89 | hcom 1->l A [ (k=0) -> <_> a, (k=1) -> p ] (p @ k) 90 | 91 | -- The diagonal of connAnd is really p! 92 | connAndDiag (A : U) (a b : A) (p : Path A a b) : 93 | Path (Path A a b) p ( connAnd A a b p @ i @ i) = <_> p 94 | 95 | connOr (A : U) (a b : A) (p : Path A a b) : 96 | PathP ( Path A (p @ i) b) p (<_> b) = 97 | hcom 1->0 A [ (i=0) -> connOrWeak @ j , (i=1) -> connOrWeak @ 1 98 | , (j=0) -> connOrWeak @ i , (j=1) -> connOrWeak @ 1 99 | , (i=j) -> connOrWeak @ i ] b 100 | where connOrWeak : Line (Line A) = 101 | hcom 0->l A [ (k=0) -> p, (k=1) -> <_> b] (p @ k) 102 | 103 | 104 | contrSingl (A : U) (a b : A) (p : Path A a b) : 105 | Path (singl A a) (a,<_> a) (b,p) = (p @ i, connAnd A a b p @ i) 106 | 107 | J (A : U) (a : A) (C : (x : A) -> Path A a x -> U) 108 | (d : C a (refl A a)) (x : A) (p : Path A a x) : C x p = 109 | subst (singl A a) T (a, refl A a) (x, p) (contrSingl A a x p) d 110 | where T (z : singl A a) : U = C (z.1) (z.2) 111 | 112 | -- The standard proof does not work! 113 | -- JEq (A : U) (a : A) (C : (x : A) -> Path A a x -> U) (d : C a (refl A a)) 114 | -- : Path (C a (refl A a)) d (J A a C d a (refl A a)) = undefined 115 | -- substEq (singl A a) T (a, refl A a) d 116 | -- where T (z : singl A a) : U = C (z.1) (z.2) 117 | 118 | -- Slicker proof of J, using a different weak 'and' connection. 119 | -- Inspired by https://github.com/RedPRL/sml-redprl/blob/master/example/J.prl 120 | J (A : U) (a : A) (C : (x : A) -> Path A a x -> U) (d : C a (<_> a)) 121 | (x : A) (p : Path A a x) : C x p = 122 | coe 0->1 ( C (sq @ i @ 1) ( sq @ i @ j)) d 123 | where sq : Line (Line A) = hcom 0->j A [(i=0) -> <_> a,(i=1) -> p] a 124 | 125 | JEq (A : U) (a : A) (C : (x : A) -> Path A a x -> U) (d : C a (<_> a)) 126 | : Path (C a (<_> a)) (J A a C d a (<_> a)) d = 127 | com 0->1 ( C (cube @ i @ 1 @ k) ( cube @ i @ j @ k)) 128 | [(k=0) -> coe 0->i ( C (sq @ i @ 1) ( sq @ i @ j)) d 129 | ,(k=1) -> <_> d] d 130 | where sq : Line (Line A) = hcom 0->j A [(i=0) -> <_> a,(i=1) -> <_> a] a 131 | cube : Line (Line (Line A)) = 132 | hcom 0->j A [(k=0) -> sq @ i 133 | ,(k=1) -> <_> a 134 | ,(i=0) -> <_> a 135 | ,(i=1) -> <_> a] a 136 | 137 | -- Longform, uncurried version of the above J/JEq proof. 138 | 139 | BP (A : U) (a : A) : U = (b : A) * Path A a b 140 | 141 | bpRefl (A : U) (a : A) : BP A a = (a , <_> a) 142 | 143 | bpContr (A : U) (a : A) (p : BP A a) : Path (BP A a) (bpRefl A a) p = 144 | let sq : Line (Line A) = hcom 0->j A [(i=0) -> <_> a,(i=1) -> p.2] a 145 | in (sq @ i @ 1 , sq @ i @ j) 146 | 147 | bpContrRefl (A : U) (a : A) : 148 | Path (Path (BP A a) (bpRefl A a) (bpRefl A a)) 149 | (bpContr A a (bpRefl A a)) 150 | (<_> bpRefl A a) = 151 | (cube @ i @ 1 @ k , cube @ i @ j @ k) 152 | where cube : Line (Line (Line A)) = 153 | hcom 0->j A [(k=0) -> (bpContr A a (bpRefl A a) @ i).2 154 | ,(k=1) -> <_> a 155 | ,(i=0) -> <_> a 156 | ,(i=1) -> <_> a] a 157 | 158 | J' (A : U) (a : A) (C : BP A a -> U) (c : C (bpRefl A a)) (p : BP A a) : C p = 159 | subst (BP A a) C (bpRefl A a) p (bpContr A a p) c 160 | 161 | JEq' (A : U) (a : A) (C : BP A a -> U) (c : C (bpRefl A a)) 162 | : Path (C (bpRefl A a)) (J' A a C c (bpRefl A a)) c = 163 | com 0->1 ( C (bpContrRefl A a @ k @ i)) 164 | [(k=0) -> coe 0->i ( C (bpContr A a (bpRefl A a) @ i)) c 165 | ,(k=1) -> <_> c] c 166 | 167 | connAndJ (A : U) (a : A) : (b : A) (p : Path A a b) -> 168 | PathP ( Path A a (p @ i)) (<_> a) p = \(b : A) -> \(p : PathP (<_> A) a b) -> 169 | -- J A a (\(b : A) (p : Path A a b) -> PathP ( Path A a (p @ i)) (<_> a) p) (<_ _> a) 170 | -- Normal form 171 | hcom 0->1 A 172 | [ (i = 0) -> hcom k->1 A 173 | [ (j = 0) -> coe l->1 (<_> A) a 174 | , (j = 1) -> coe l->1 (<_> A) a ] 175 | (coe k->1 (<_> A) a) 176 | , (i = 1) -> hcom k->1 A 177 | [ (j = 0) -> coe l->1 (<_> A) a 178 | , (j = 1) -> coe l->1 (<_> A) 179 | (hcom 0->1 A [ (l = 0) -> <_> a 180 | , (l = 1) -> p ] a) ] 181 | (coe k->1 (<_> A) (hcom 0->j A [ (k = 0) -> <_> a 182 | , (k = 1) -> p ] a)) 183 | , (j = 0) -> <_> a 184 | , (j = 1) -> <_> p @ i ] 185 | (hcom 0->1 A 186 | [ (j = 0) -> coe l->1 (<_> A) a 187 | , (j = 1) -> coe l->1 (<_> A) (hcom 0->i A [ (l = 0) -> <_> a 188 | , (l = 1) -> p ] a) ] 189 | (coe 0->1 (<_> A) a)) 190 | 191 | 192 | -- h-levels 193 | 194 | prop (A : U) : U = (a b : A) -> Path A a b 195 | set (A : U) : U = (a b : A) -> prop (Path A a b) 196 | groupoid (A : U) : U = (a b : A) -> set (Path A a b) 197 | twogroupoid (A : U) : U = (a b : A) -> groupoid (Path A a b) 198 | 199 | -- the collection of all sets 200 | SET : U = (X:U) * set X 201 | 202 | propSet (A : U) (h : prop A) : set A = 203 | \(a b : A) (p q : Path A a b) -> 204 | hcom 0->1 A [ (i=0) -> h a a 205 | , (i=1) -> h a b 206 | , (j=0) -> h a (p @ i) 207 | , (j=1) -> h a (q @ i)] a 208 | 209 | setGroupoid (A : U) (h : set A) : groupoid A = 210 | \(a b : A) -> propSet (Path A a b) (h a b) 211 | 212 | groupoidTwoGroupoid (A : U) (h : groupoid A) : twogroupoid A = 213 | \(a b : A) -> setGroupoid (Path A a b) (h a b) 214 | 215 | propIsProp (A : U) : prop (prop A) = 216 | \(f g : prop A) -> \(a b : A) -> 217 | propSet A f a b (f a b) (g a b) @ i 218 | 219 | setIsProp (A : U) : prop (set A) = 220 | \(f g : set A) -> \(a b :A) -> 221 | propIsProp (Path A a b) (f a b) (g a b) @ i 222 | 223 | PathS (A : U) (P : A -> U) (a0 a1 : A) 224 | (p : Path A a0 a1) (u0 : P a0) (u1 : P a1) : U = 225 | PathP ( P (p @ i)) u0 u1 226 | 227 | lemProp (A : U) (h : A -> prop A) : prop A = 228 | \(a : A) -> h a a 229 | 230 | -- Compare with: https://github.com/mortberg/cubicaltt/blob/master/examples/prelude.ctt#L205 231 | lemPropF (A : U) (P : A -> U) (pP : (x : A) -> prop (P x)) (a0 a1 :A) 232 | (p : Path A a0 a1) (b0 : P a0) (b1 : P a1) : 233 | PathP (P (p@i)) b0 b1 = 234 | pP (p @ i) (coe 0->i ( P (p @ j)) b0) (coe 1->i ( P (p @ j)) b1) @ i 235 | 236 | Sigma (A : U) (B : A -> U) : U = (x : A) * B x 237 | 238 | lemSig (A : U) (B : A -> U) (pB : (x : A) -> prop (B x)) 239 | (u v : (x:A) * B x) (p : Path A u.1 v.1) : 240 | Path ((x:A) * B x) u v = 241 | (p@i,(lemPropF A B pB u.1 v.1 p u.2 v.2)@i) 242 | 243 | propSig (A : U) (B : A -> U) (pA : prop A) 244 | (pB : (x : A) -> prop (B x)) (t u : (x:A) * B x) : 245 | Path ((x:A) * B x) t u = 246 | lemSig A B pB t u (pA t.1 u.1) 247 | 248 | propPi (A : U) (B : A -> U) (h : (x : A) -> prop (B x)) 249 | (f0 f1 : (x : A) -> B x) : Path ((x : A) -> B x) f0 f1 250 | = \(x : A) -> h x (f0 x) (f1 x) @ i 251 | 252 | -- Equivalent definition of isContr 253 | isInhProp (A : U) : U = (_ : A) * ((x y : A) -> Path A x y) 254 | 255 | -- isContr RedPRL style 256 | isContr (A : U) : U = (x : A) * ((y : A) -> Path A y x) 257 | 258 | isInhPropToIsContr (A : U) (h : isInhProp A) : isContr A = 259 | (h.1,\(y : A) -> h.2 y h.1) 260 | 261 | isContrToIsInhProp (A : U) (h : isContr A) : isInhProp A = 262 | (h.1,\(x y : A) -> hcom 1->0 A [(i=0) -> h.2 x, (i=1) -> h.2 y] h.1) 263 | 264 | fiber (A B : U) (f : A -> B) (b : B) : U = 265 | (a : A) * Path B (f a) b 266 | 267 | isInhPropProp (A : U) (h : isInhProp A) : prop A = h.2 268 | 269 | isContrProp (A : U) (h : isContr A) : prop A = 270 | \(a b : A) -> hcom 1->0 A [ (i = 0) -> h.2 a, (i = 1) -> h.2 b ] h.1 271 | 272 | -- See below for a proof without connections 273 | -- propIsContrConn (A : U) (z0 z1 : isContr A) : Path (isContr A) z0 z1 = 274 | -- (p0 a1 @ j 275 | -- ,\(x : A) -> hcom 0->1 A 276 | -- [ (i=0) -> p0 a1 @ j 277 | -- , (i=1) -> connOr A a0 x (p0 x) @ j @ k 278 | -- , (j=0) -> connAnd A a0 x (p0 x) @ i @ k 279 | -- , (j=1) -> p1 x @ i ] 280 | -- (lem1 x@i@j)) 281 | -- where 282 | -- a0 : A = z0.1 283 | -- p0 : (x : A) -> Path A a0 x = z0.2 284 | -- a1 : A = z1.1 285 | -- p1 : (x : A) -> Path A a1 x = z1.2 286 | -- lem1 (x : A) : PathP ( Path A a0 (p1 x @ i)) (p0 a1) (p0 x) = 287 | -- p0 (p1 x @ i) @ j 288 | 289 | propIsContr (A : U) : prop (isContr A) = lemProp (isContr A) rem 290 | where 291 | rem (t : isContr A) : prop (isContr A) = propSig A T pA pB 292 | where 293 | T (x : A) : U = (y : A) -> Path A y x 294 | pA (x y : A) : Path A x y = 295 | hcom 1->0 A [(i=0) -> <_> x, (i=1) -> t.2 y] (t.2 x @ i) 296 | pB (x : A) : prop (T x) = 297 | propPi A (\(y : A) -> Path A y x) (\(y : A) -> propSet A pA y x) 298 | 299 | fiber (A B : U) (f : A -> B) (b : B) : U = 300 | (a : A) * Path B (f a) b 301 | 302 | isEquiv (A B : U) (f : A -> B) : U = (b : B) -> isContr (fiber A B f b) 303 | 304 | equiv (A B : U) : U = (f : A -> B) * isEquiv A B f 305 | 306 | idfun (A : U) (a : A) : A = a 307 | 308 | idEquiv (A : U) : equiv A A = 309 | (idfun A, 310 | \(a : A) -> ((a,<_> a), 311 | \(f : fiber A A (idfun A) a) -> (hcom 1->0 A [(i=0) -> f.2, (i=1) -> <_> a] a 312 | , hcom 1->j A [(i=0) -> f.2,(i=1) -> <_> a] a))) 313 | 314 | isEquivInhProp (A B : U) (f : A -> B) : U = (b : B) -> isInhProp (fiber A B f b) 315 | 316 | equivInhProp (A B : U) : U = (f : A -> B) * isEquivInhProp A B f 317 | 318 | equivToEquivInhProp (A B : U) (f : equiv A B) : equivInhProp A B = 319 | (f.1,\(b : B) -> isContrToIsInhProp (fiber A B f.1 b) (f.2 b)) 320 | 321 | equivInhPropToEquiv (A B : U) (f : equivInhProp A B) : equiv A B = 322 | (f.1,\(b : B) -> isInhPropToIsContr (fiber A B f.1 b) (f.2 b)) 323 | 324 | idEquivInhProp (A : U) : equivInhProp A A = equivToEquivInhProp A A (idEquiv A) 325 | 326 | -- propIsEquiv without connections. normal form is big, but typechecks 327 | propIsEquiv (A B : U) (f : A -> B) : prop (isEquiv A B f) = 328 | \(u0 u1 : isEquiv A B f) -> 329 | \(y : B) -> propIsContr (fiber A B f y) (u0 y) (u1 y) @ i 330 | 331 | -- We should adapt this proof! 332 | connAndNoDiag (A : U) (a b : A) (p : Path A a b) : 333 | PathP ( Path A a (p @ i)) (<_> a) p = 334 | hcom 0->1 A [ (i=0) -> hcom 1->0 A [ (k=0) -> <_> a, (k=1) -> p ] (p @ k) 335 | , (i=1) -> hcom 1->j A [ (k=0) -> <_> a, (k=1) -> p ] (p @ k) 336 | , (j=0) -> hcom 1->0 A [ (k=0) -> <_> a, (k=1) -> p ] (p @ k) 337 | , (j=1) -> hcom 1->i A [ (k=0) -> <_> a, (k=1) -> p ] (p @ k) ] a 338 | 339 | propIsEquivDirect (A B : U) (f : A -> B) : prop (isEquiv A B f) = 340 | \(p q : isEquiv A B f) -> 341 | \(y : B) -> 342 | let p0 : A = (p y).1.1 343 | p1 : Path B (f p0) y = (p y).1.2 344 | p2 : (w1 : fiber A B f y) -> Path (fiber A B f y) w1 (p0,p1) = (p y).2 345 | q0 : A = (q y).1.1 346 | q1 : Path B (f q0) y = (q y).1.2 347 | q2 : (w1 : fiber A B f y) -> Path (fiber A B f y) w1 (q0,q1) = (q y).2 348 | in (q2 (p0,p1) @ i, 349 | \(w : fiber A B f y) -> 350 | let sq : PathP ( Path (fiber A B f y) w (q2 (p0,p1) @ j)) (p2 w) (q2 w) = 351 | hcom 0->1 (fiber A B f y) 352 | [ (i = 0) -> connAndNoDiag (fiber A B f y) w (p0,p1) (p2 w) @ k @ j 353 | , (i = 1) -> <_> q2 w @ j 354 | , (j = 0) -> <_> w 355 | , (j = 1) -> q2 (p2 w @ k) @ i ] 356 | (connAndNoDiag (fiber A B f y) w (q0,q1) (q2 w) @ i @ j) 357 | in sq @ i) 358 | 359 | 360 | -- propIsEquiv with connections 361 | -- propIsEquivConn (A B : U) (f : A -> B) : prop (isEquiv A B f) = 362 | -- \(u0 u1 : isEquiv A B f) -> 363 | -- \(y : B) -> propIsContrConn (fiber A B f y) (u0 y) (u1 y) @ i 364 | 365 | -- The normal form of propIsEquiv: 366 | -- npropIsEquiv (A B : U) (f : A -> B) : prop (isEquiv A B f) = 367 | -- \(u0 u1 : isEquiv A B f) -> undefined 368 | 369 | -- -- The normal form of propIsEquivConn: 370 | -- npropIsEquivConn (A B : U) (f : A -> B) : prop (isEquiv A B f) = 371 | -- \(u0 u1 : isEquiv A B f) -> undefined 372 | 373 | 374 | iso (A B : U) : U = (f : A -> B) * (g : B -> A) 375 | * (_ : (b : B) -> Path B (f (g b)) b) 376 | * ((a : A) -> Path A (g (f a)) a) 377 | 378 | lemIso (A B : U) (i : iso A B) (b : B) (f0 f1 : fiber A B i.1 b) : 379 | Path (fiber A B i.1 b) f0 f1 = 380 | let f : A -> B = i.1 381 | g : B -> A = i.2.1 382 | fg : (b : B) -> Path B (f (g b)) b = i.2.2.1 383 | gf : (a : A) -> Path A (g (f a)) a = i.2.2.2 384 | x0 : A = f0.1 385 | p0 : Path B (f x0) b = f0.2 386 | x1 : A = f1.1 387 | p1 : Path B (f x1) b = f1.2 388 | 389 | l0 : Path A x0 (g b) = 390 | hcom 0->1 A [(i=0) -> gf x0, (i=1) -> <_> g b] (g (p0 @ i)) 391 | sq0 : PathP ( Path A (g (p0 @ i)) (l0 @ i)) (gf x0) (<_> g b) = 392 | hcom 0->j A [(i=0) -> gf x0, (i=1) -> <_> g b] (g (p0 @ i)) 393 | 394 | l1 : Path A x1 (g b) = 395 | hcom 0->1 A [(i=0) -> gf x1, (i=1) -> <_> g b] (g (p1 @ i)) 396 | sq1 : PathP ( Path A (g (p1 @ i)) (l1 @ i)) (gf x1) (<_> g b) = 397 | hcom 0->j A [(i=0) -> gf x1, (i=1) -> <_> g b] (g (p1 @ i)) 398 | 399 | l2 : Path A x0 x1 = hcom 1->0 A [(i=0) -> l0, (i=1) -> l1] (g b) 400 | sq2 : PathP ( Path A (l2 @ i) (g b)) l0 l1 = 401 | hcom 1->j A [(i=0) -> l0, (i=1) -> l1] (g b) 402 | in (l2 @ i 403 | , hcom 0->1 B [(i=0) -> fg (p0 @ j) 404 | ,(i=1) -> fg (p1 @ j) 405 | ,(j=0) -> fg (f (l2 @ i)) 406 | ,(j=1) -> fg b] 407 | (f (hcom 1->0 A [(i=0) -> sq0 @ j 408 | ,(i=1) -> sq1 @ j 409 | ,(j=0) -> gf (l2 @ i) 410 | ,(j=1) -> <_> g b] 411 | (sq2 @ i @ j)))) 412 | 413 | -- Version of lemIso with heavy use of line types: 414 | lemIso (A B : U) (i : iso A B) (b : B) (f0 f1 : fiber A B i.1 b) : 415 | Path (fiber A B i.1 b) f0 f1 = 416 | let f : A -> B = i.1 417 | g : B -> A = i.2.1 418 | fg : (b : B) -> Path B (f (g b)) b = i.2.2.1 419 | gf : (a : A) -> Path A (g (f a)) a = i.2.2.2 420 | x0 : A = f0.1 421 | p0 : Path B (f x0) b = f0.2 422 | x1 : A = f1.1 423 | p1 : Path B (f x1) b = f1.2 424 | 425 | sq0 : Line (Line A) = 426 | hcom 0->j A [(i=0) -> gf x0, (i=1) -> <_> g b] (g (p0 @ i)) 427 | 428 | sq1 : Line (Line A) = 429 | hcom 0->j A [(i=0) -> gf x1, (i=1) -> <_> g b] (g (p1 @ i)) 430 | 431 | sq2 : Line (Line A) = 432 | hcom 1->j A [(i=0) -> sq0 @ k @ 1 433 | ,(i=1) -> sq1 @ k @ 1] (g b) 434 | in (sq2 @ i @ 0 435 | , hcom 0->1 B [(i=0) -> fg (p0 @ j) 436 | ,(i=1) -> fg (p1 @ j) 437 | ,(j=0) -> fg (f (sq2 @ i @ 0)) 438 | ,(j=1) -> fg b] 439 | (f (hcom 1->0 A [(i=0) -> sq0 @ j 440 | ,(i=1) -> sq1 @ j 441 | ,(j=0) -> gf (sq2 @ i @ 0) 442 | ,(j=1) -> <_> g b] 443 | (sq2 @ i @ j)))) 444 | 445 | isoToEquiv (A B : U) (i : iso A B) : equiv A B = 446 | (i.1,\(b : B) -> ((i.2.1 b,i.2.2.1 b),\(fib : fiber A B i.1 b) -> 447 | lemIso A B i b fib (i.2.1 b,i.2.2.1 b))) 448 | 449 | 450 | --- 451 | 452 | data N0 = 453 | 454 | efq (A : U) : N0 -> A = split {} 455 | not (A : U) : U = A -> N0 456 | 457 | data Unit = tt 458 | 459 | propUnit : prop Unit = split 460 | tt -> split@((x:Unit) -> Path Unit tt x) with 461 | tt -> tt 462 | 463 | setUnit : set Unit = propSet Unit propUnit 464 | 465 | data or (A B : U) = inl (a : A) 466 | | inr (b : B) 467 | 468 | propOr (A B : U) (hA : prop A) (hB : prop B) (h : A -> not B) : prop (or A B) = split 469 | inl a' -> split@((b : or A B) -> Path (or A B) (inl a') b) with 470 | inl b' -> inl (hA a' b' @ i) 471 | inr b' -> efq (Path (or A B) (inl a') (inr b')) (h a' b') 472 | inr a' -> split@((b : or A B) -> Path (or A B) (inr a') b) with 473 | inl b' -> efq (Path (or A B) (inr a') (inl b')) (h b' a') 474 | inr b' -> inr (hB a' b' @ i) 475 | 476 | stable (A:U) : U = not (not A) -> A 477 | 478 | const (A : U) (f : A -> A) : U = (x y : A) -> Path A (f x) (f y) 479 | 480 | exConst (A : U) : U = (f:A -> A) * const A f 481 | 482 | propN0 : prop N0 = \ (x y:N0) -> efq (Path N0 x y) x 483 | 484 | propNot (A:U) : prop (not A) = \ (f g:not A) -> \(x:A) -> (propN0 (f x) (g x))@i 485 | 486 | dNot (A:U) (a:A) : not (not A) = \ (h : not A) -> h a 487 | 488 | dec (A : U) : U = or A (not A) 489 | 490 | propDec (A : U) (h : prop A) : prop (dec A) = 491 | propOr A (not A) h (propNot A) (\(x : A) (h : not A) -> h x) 492 | 493 | decEqCong (A B : U) (f : A -> B) (g : B -> A) : dec A -> dec B = split 494 | inl a -> inl (f a) 495 | inr h -> inr (\ (b:B) -> h (g b)) 496 | 497 | decStable (A:U) : dec A -> stable A = split 498 | inl a -> \ (h :not (not A)) -> a 499 | inr b -> \ (h :not (not A)) -> efq A (h b) 500 | 501 | decConst (A : U) : dec A -> exConst A = split 502 | inl a -> (\ (x:A) -> a, \ (x y:A) -> refl A a) 503 | inr h -> (\ (x:A) -> x, \ (x y:A) -> efq (Path A x y) (h x)) 504 | 505 | stableConst (A : U) (sA: stable A) : exConst A = 506 | (\ (x:A) -> sA (dNot A x),\ (x y:A) -> sA (propNot (not A) (dNot A x) (dNot A y) @ i)) 507 | 508 | discrete (A : U) : U = (a b : A) -> dec (Path A a b) 509 | 510 | injective (A B : U) (f : A -> B) : U = 511 | (a0 a1 : A) -> Path B (f a0) (f a1) -> Path A a0 a1 512 | -------------------------------------------------------------------------------- /examples/univalence.ytt: -------------------------------------------------------------------------------- 1 | module univalence where 2 | 3 | import prelude 4 | 5 | ua (A B : U) (e : equiv A B) : Path U A B = V i A B e 6 | 7 | uabeta (A B : U) (e : equiv A B) (a : A) : 8 | Path B (coe 0->1 (ua A B e) a) (e.1 a) = 9 | coe i->1 (<_> B) (e.1 a) 10 | 11 | retract (A B : U) (f : A -> B) (g : B -> A) : U = (a : A) -> Path A (g (f a)) a 12 | 13 | pathToEquiv (A B : U) (p : Path U A B) : equiv A B = 14 | coe 0->1 ( equiv A (p @ i)) (idEquiv A) 15 | -- Normal form (typechecks): 16 | -- (coe 0->1 ( A -> (p @ i1240)) (\(a : A) -> a),coe 0->1 ( (b : p @ i1240) -> Sigma (Sigma A (\(a : A) -> PathP ( p @ i1240) (coe 0->i1240 ( p @ i1240) (coe i1240->0 ( A) a)) b)) (\(x : Sigma A (\(a : A) -> PathP ( p @ i1240) (coe 0->i1240 ( p @ i1240) (coe i1240->0 ( A) a)) b)) -> (y : Sigma A (\(a : A) -> PathP ( p @ i1240) (coe 0->i1240 ( p @ i1240) (coe i1240->0 ( A) a)) b)) -> PathP ( Sigma A (\(a : A) -> PathP ( p @ i1240) (coe 0->i1240 ( p @ i1240) (coe i1240->0 ( A) a)) b)) y x)) (\(a : A) -> ((a, a),\(f : Sigma A (\(a0 : A) -> PathP ( A) a0 a)) -> (hcom 1->0 A [ (i1248 = 0) -> f.2 @ i1252, (i1248 = 1) -> a ] a, hcom 1->i1249 A [ (i1248 = 0) -> f.2 @ i1250, (i1248 = 1) -> a ] a)))) 17 | 18 | -- normal form works 19 | equivLemma (A B : U) : (v w : equiv A B) -> Path (A -> B) v.1 w.1 -> Path (equiv A B) v w = 20 | lemSig (A -> B) (isEquiv A B) (propIsEquivDirect A B) 21 | 22 | uaret (A B : U) : retract (equiv A B) (Path U A B) (ua A B) (pathToEquiv A B) = 23 | \(e : equiv A B) -> 24 | equivLemma A B (pathToEquiv A B (ua A B e)) e ( \(a : A) -> uabeta A B e (coe 1->i (<_> A) a) @ i) 25 | 26 | isContrPath (A : U) : isContr ((B : U) * Path U A B) = 27 | ((A,<_> A),\(bp : (B : U) * Path U A B) -> (hcom 0->1 U [(i=0) -> bp.2,(i=1) -> <_> A ] A 28 | , hcom 0->j U [(i=0) -> bp.2,(i=1) -> <_> A ] A)) 29 | 30 | retIsContr (A B : U) (f : A -> B) (g : B -> A) 31 | (h : (x : A) -> Path A (g (f x)) x) (v : isContr B) : isContr A = (g b,p) 32 | where 33 | b : B = v.1 34 | q : (y:B) -> Path B y b = v.2 35 | p (x: A ) : Path A x (g b) = 36 | hcom 0->1 A [(i=1) -> <_> g b, (i=0) -> h x] (g (q (f x) @ i)) 37 | 38 | f1 (A : U) (p : (B : U) * equiv A B) : ((B : U) * Path U A B) = (p.1,ua A p.1 p.2) 39 | f2 (A : U) (p : (B : U) * Path U A B) : ((B : U) * equiv A B) = (p.1,pathToEquiv A p.1 p.2) 40 | 41 | opaque uaret 42 | 43 | uaretsig (A : U) : retract ((B : U) * equiv A B) ((B : U) * Path U A B) (f1 A) (f2 A) = 44 | \(p : (B : U) * equiv A B) -> (p.1,uaret A p.1 p.2 @ i) 45 | 46 | -- transparent uaret 47 | 48 | -- normal form works with uaret opaque 49 | univalence (A : U) : isContr ((B : U) * equiv A B) = 50 | retIsContr ((B : U) * equiv A B) ((B : U) * Path U A B) 51 | (f1 A) (f2 A) (uaretsig A) (isContrPath A) 52 | 53 | 54 | -- Alternative proof of univalence. We prove that Vproj is an 55 | -- equivalence and from this we directly get univalence. This is very 56 | -- similar to the proof of univalence using that unglue is an 57 | -- equivalence in CCHM (Corollary 10). 58 | -- Compare with: https://github.com/mortberg/cubicaltt/blob/master/examples/univalence.ctt#L83 59 | 60 | -- First define identity equivalence using or connection 61 | -- TODO: can we do the proof below with the other definition of the id equivalence? 62 | idEquivConnOr (B : U) : equiv B B = 63 | (idfun B 64 | ,\(b : B) -> ((b,<_> b) 65 | ,\(v : fiber B B (idfun B) b) -> 66 | (v.2 @ i, connOr B v.1 b v.2 @ i @ j))) 67 | 68 | univalenceAlt (B : U) : isContr ((A : U) * equiv A B) = 69 | ((B,idEquivConnOr B) 70 | ,\(w : (A : U) * equiv A B) -> 71 | let goal : Path ((A : U) * equiv A B) w (B,idEquivConnOr B) = 72 | let VB : U = V i w.1 B w.2 73 | projB (g : VB) : B = Vproj i g w.1 B w.2 74 | projBisEquiv : isEquiv VB B projB = 75 | \(b : B) -> let ctrB : Line B = 76 | hcom 1->j B [(i=0) -> (w.2.2 b).1.2, (i=1) -> <_> b] b 77 | ctr : fiber VB B projB b = 78 | (Vin i (w.2.2 b).1.1 (ctrB @ 0), ctrB @ j) 79 | contr (v : fiber VB B projB b) : Path (fiber VB B projB b) v ctr = 80 | let filler : Line B = 81 | hcom 1->l B [(i=0) -> ((w.2.2 b).2 v @ j).2 82 | ,(i=1) -> connOr B v.1 b v.2 @ j @ k 83 | ,(j=0) -> v.2 84 | ,(j=1) -> ctrB] b 85 | in (Vin i ((w.2.2 b).2 v @ j).1 (filler @ 0), filler @ l) 86 | in (ctr,contr) 87 | in (VB,projB,projBisEquiv) 88 | in goal) 89 | 90 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.5 2 | 3 | packages: 4 | - . 5 | extra-deps: 6 | - BNFC-2.8.1 7 | - monad-gen-0.3.0.1 8 | 9 | flags: {} 10 | 11 | extra-package-dbs: [] 12 | -------------------------------------------------------------------------------- /yacctt.cabal: -------------------------------------------------------------------------------- 1 | name: yacctt 2 | version: 0.1.0.0 3 | description: Experimental implementation of Cartesian cubical type theory. 4 | homepage: https://github.com/mortberg/yacctt 5 | author: Anders Mörtberg and Carlo Angiuli 6 | maintainer: andersmortberg@gmail.com 7 | copyright: 2018 Anders Mörtberg and Carlo Angiuli 8 | license: MIT 9 | build-type: Custom 10 | cabal-version: >= 1.10 11 | 12 | executable yacctt 13 | main-is: Main.hs 14 | other-modules: 15 | CTT, 16 | Cartesian, 17 | Eval, 18 | Resolver, 19 | TypeChecker, 20 | Exp.Abs, 21 | Exp.Lex, 22 | Exp.ErrM, 23 | Exp.Layout, 24 | Exp.Print, 25 | Exp.Par 26 | hs-source-dirs: 27 | . 28 | ghc-options: -O2 -rtsopts -v0 29 | build-depends: 30 | base >=4.7 && <5, 31 | containers, 32 | pretty, 33 | mtl, 34 | BNFC, 35 | array, 36 | haskeline, 37 | time, 38 | filepath, 39 | directory, 40 | monad-gen 41 | build-tools: alex, happy, bnfc 42 | default-language: Haskell2010 43 | -------------------------------------------------------------------------------- /yacctt.el: -------------------------------------------------------------------------------- 1 | ;;; yacctt.el --- Mode for cartesian cubical type theory -*- lexical-binding: t -*- 2 | ;; URL: https://github.com/mortberg/yacctt 3 | ;; Package-version: 1.0 4 | ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) 5 | ;; Keywords: languages 6 | 7 | ;; This file is not part of GNU Emacs. 8 | 9 | ;; Copyright (c) 2018 Anders Mörtberg and Carlo Angiuli 10 | 11 | ;; Permission is hereby granted, free of charge, to any person obtaining 12 | ;; a copy of this software and associated documentation files (the 13 | ;; "Software"), to deal in the Software without restriction, including 14 | ;; without limitation the rights to use, copy, modify, merge, publish, 15 | ;; distribute, sublicense, and/or sell copies of the Software, and to 16 | ;; permit persons to whom the Software is furnished to do so, subject to 17 | ;; the following conditions: 18 | 19 | ;; The above copyright notice and this permission notice shall be included 20 | ;; in all copies or substantial portions of the Software. 21 | 22 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 23 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 24 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 25 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 26 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 27 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 28 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 29 | 30 | ;;; Commentary: 31 | ;; This package provides a major mode for editing proofs or programs 32 | ;; in yacctt, an experimental implementation of cartesian cubical type 33 | ;; theory. 34 | 35 | 36 | ;;; Code: 37 | 38 | (require 'comint) 39 | (require 'cl-lib) 40 | 41 | ;;;; Customization options 42 | 43 | (defgroup yacctt nil "Options for yacctt-mode for cartesian cubical type theory" 44 | :group 'languages 45 | :prefix 'yacctt- 46 | :tag "Cartesian cubical type theory") 47 | 48 | (defcustom yacctt-command "yacctt" 49 | "The command to be run for yacctt." 50 | :group 'yacctt 51 | :type 'string 52 | :tag "Command for yacctt" 53 | :options '("yacctt" "cabal exec yacctt")) 54 | 55 | ;;;; Syntax 56 | 57 | (defvar yacctt-keywords 58 | '("hdata" "data" "import" "mutual" "let" "in" "split" 59 | "with" "module" "where" "U" "opaque" "transparent" "transparent_all") 60 | "Keywords for yacctt.") 61 | 62 | (defvar yacctt-special 63 | '("undefined" "primitive") 64 | "Special operators for yacctt.") 65 | 66 | (defvar yacctt-keywords-regexp 67 | (regexp-opt yacctt-keywords 'words) 68 | "Regexp that recognizes keywords for yacctt.") 69 | 70 | (defvar yacctt-operators-regexp 71 | (regexp-opt '(":" "->" "=" "|" "\\" "*" "_" "<" ">" "\\/" "/\\" "-" "@") t) 72 | "Regexp that recognizes operators for yacctt.") 73 | 74 | (defvar yacctt-special-regexp 75 | (regexp-opt yacctt-special 'words) 76 | "Regexp that recognizes special operators for yacctt.") 77 | 78 | (defvar yacctt-def-regexp "^[[:word:]']+" 79 | "Regexp that recognizes the beginning of a yacctt definition.") 80 | 81 | (defvar yacctt-font-lock-keywords 82 | `((,yacctt-keywords-regexp . font-lock-type-face) 83 | (,yacctt-operators-regexp . font-lock-variable-name-face) 84 | (,yacctt-special-regexp . font-lock-warning-face) 85 | (,yacctt-def-regexp . font-lock-function-name-face)) 86 | "Font-lock information, assigning each class of keyword a face.") 87 | 88 | (defvar yacctt-syntax-table 89 | (let ((st (make-syntax-table))) 90 | (modify-syntax-entry ?\{ "(}1nb" st) 91 | (modify-syntax-entry ?\} "){4nb" st) 92 | (modify-syntax-entry ?- "_ 123" st) 93 | (modify-syntax-entry ?\n ">" st) 94 | (modify-syntax-entry ?\\ "." st) 95 | st) 96 | "The syntax table for yacctt, with Haskell-style comments.") 97 | 98 | 99 | ;;;; The interactive toplevel 100 | 101 | (defvar yacctt-cubical-process nil 102 | "The subprocess buffer for yacctt.") 103 | 104 | (defvar yacctt-loaded-buffer nil 105 | "The currently-loaded buffer for yacctt. 106 | 107 | If no buffer is loaded, then this variable is nil.") 108 | 109 | (defun yacctt-ensure-process () 110 | "Ensure that a process is running for yacctt and return the process buffer." 111 | (if (and yacctt-cubical-process (get-buffer-process yacctt-cubical-process)) 112 | yacctt-cubical-process 113 | (let ((process (make-comint "yacctt" yacctt-command))) 114 | (setq yacctt-cubical-process process) 115 | process))) 116 | 117 | (defun yacctt-load () 118 | "Start yacctt if it is not running, and get the current buffer loaded." 119 | (interactive) 120 | (let ((file (buffer-file-name))) 121 | (unless file 122 | (error "The current buffer is not associated with a file")) 123 | (let ((yacctt-proc (yacctt-ensure-process)) 124 | (dir (file-name-directory file)) 125 | (f (file-name-nondirectory file))) 126 | (save-buffer) 127 | ;; Get in the right working directory. No space-escaping is 128 | ;; necessary for yacctt, which in fact expects filenames to be 129 | ;; written without quotes or space-escaping. 130 | (comint-send-string yacctt-proc (concat ":cd " dir "\n")) 131 | ;; Load the file 132 | (comint-send-string yacctt-proc (concat ":l " f "\n")) 133 | ;; Show the buffer 134 | (pop-to-buffer yacctt-proc '(display-buffer-use-some-window (inhibit-same-window . t)))))) 135 | 136 | ;;;; Completion support 137 | 138 | (defvar yacctt--completion-regexp 139 | "^\\(?1:[[:word:]']+\\) [:(]\\|^data \\(?1:[[:word:]']+\\)\\|=\\s-*\\(?1:[[:word:]']\\)\\||\\s-*\\(?1:[[:word:]']\\)" 140 | "Regexp for finding names to complete. 141 | 142 | This regexp matches the following kinds of strings: 143 | 144 | : 145 | ( 146 | data 147 | = 148 | | 149 | 150 | It is overly liberal, but it is better to have too many 151 | suggestions for completion rather than too few.") 152 | 153 | (defun yacctt-defined-names () 154 | "Find all names defined in this buffer." 155 | (save-excursion 156 | (let (names) 157 | (goto-char (point-min)) 158 | (while (re-search-forward yacctt--completion-regexp nil t) 159 | ;; Do not save if inside comment 160 | (unless (nth 4 (syntax-ppss)) 161 | (push (match-string-no-properties 1) names))) 162 | names))) 163 | 164 | (defun yacctt-completion-at-point () 165 | "Attempt to perform completion for yacctt's keywords and the definitions in this file." 166 | (when (looking-back "\\w+" nil t) 167 | (let* ((match (match-string-no-properties 0)) 168 | (start-pos (match-beginning 0)) 169 | (end-pos (match-end 0)) 170 | (candidates (cl-remove-if-not 171 | (apply-partially #'string-prefix-p match) 172 | (append yacctt-keywords 173 | yacctt-special 174 | (yacctt-defined-names))))) 175 | (if (null candidates) 176 | nil 177 | (list start-pos end-pos candidates))))) 178 | 179 | ;;;; The mode itself 180 | 181 | ;;;###autoload 182 | (define-derived-mode yacctt-mode prog-mode 183 | "ytt" 184 | "Major mode for editing yacctt type theory files." 185 | 186 | :syntax-table yacctt-syntax-table 187 | 188 | ;; Make comment-dwim do the right thing for Yacctt 189 | (set (make-local-variable 'comment-start) "--") 190 | (set (make-local-variable 'comment-end) "") 191 | 192 | ;; Code for syntax highlighting 193 | (setq font-lock-defaults '(yacctt-font-lock-keywords)) 194 | 195 | ;; Bind mode-specific commands to keys 196 | (define-key yacctt-mode-map (kbd "C-c C-l") 'yacctt-load) 197 | 198 | ;; Install the completion handler 199 | (set (make-local-variable 'completion-at-point-functions) 200 | '(yacctt-completion-at-point)) 201 | 202 | ;; Setup imenu, to allow tools such as imenu and Helm to jump 203 | ;; directly to names in the current buffer. 204 | (set (make-local-variable 'imenu-generic-expression) 205 | '(("Definitions" "^\\(?1:[[:word:]']+\\) *[:(]" 1) 206 | ("Datatypes" "^\\s-*data\\s-+\\(?1:[[:word:]']+\\)" 1))) 207 | 208 | ;; Clear memory 209 | (setq yacctt-keywords-regexp nil) 210 | (setq yacctt-operators-regexp nil) 211 | (setq yacctt-special-regexp nil)) 212 | 213 | ;;;###autoload 214 | (add-to-list 'auto-mode-alist '("\\.ytt\\'" . yacctt-mode)) 215 | 216 | (provide 'yacctt) 217 | ;;; yacctt.el ends here 218 | --------------------------------------------------------------------------------