├── .gitignore ├── Makefile ├── README.md ├── dune-project ├── library ├── alg.dtt ├── bool.dtt ├── category.dtt ├── classical.dtt ├── dec.dtt ├── dep_encode.dtt ├── exp.dtt ├── fin.dtt ├── fn.dtt ├── hott.dtt ├── id.dtt ├── int.dtt ├── iso.dtt ├── lang.dtt ├── lc.dtt ├── list.dtt ├── map.dtt ├── maybe.dtt ├── nat.dtt ├── ptype.dtt ├── queue.dtt ├── sg.dtt ├── sum.dtt ├── test.dtt ├── tree.dtt ├── typeclass.dtt ├── unit.dtt ├── vec.dtt ├── void.dtt ├── void2.dtt └── wrap.dtt └── src ├── concrete_syntax.ml ├── ctx.ml ├── ctx.mli ├── domain.ml ├── dune ├── elab.ml ├── level.ml ├── lexer.mll ├── mark.ml ├── nbe.ml ├── parser.mly ├── repl.ml └── syntax.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | dtt 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | dtt: 2 | dune build 3 | install _build/default/src/repl.exe $@ 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # datatt 2 | 3 | datatt is an implementation of a dependent type theory with user defined datatypes. 4 | Check out the library directory for some fun stuff. In `hott.dtt` I've translated an Agda proof of Hedberg's Theorem, that any type `A` with decidable equality is a Set, meaning that all proofs of equality between elements of `A` are themselves equal. 5 | 6 | I took a lot of inspiration for this project from trying (and sometimes succeeding) to read the source code of [redtt](https://github.com/RedPRL/redtt). 7 | 8 | ## Building 9 | 10 | You can build datatt by installing `dune` and then running `Make` in the datatt directory. 11 | 12 | ## Features 13 | 14 | * Dependent functions. 15 | ``` 16 | def f : (x : A) -> B x => \x => e 17 | def f (x : A) : B x => e 18 | * Dependent pairs. 19 | ``` 20 | def p : (x : A) * B x => (fst , snd) 21 | def p_fst : A => p.1 22 | def p_snd : B p.1 => p.2 23 | 24 | * Identity types, with the J eliminator. 25 | ``` 26 | -- Nice identity type syntax : x = y 27 | def reflexivity (A : Type) (x : A) : x = x => refl 28 | 29 | -- Uglier syntax, but provides a type to check against: Id A x y 30 | def reflexivity' (A : Type) (x : A) : Id A x x => refl 31 | 32 | def symmetry (A : Type) (x y : A) (p : x = y) : y = x => 33 | match p with 34 | | refl i => refl 35 | * User defined, parametric datatypes. Constructors can be overloaded, but their types cannot be synthesized, only checked. When declaring a datatype, recursive references to the type being defined are left unapplied to their parameters, as can be seen in the definition of `List`. 36 | ``` 37 | data Nat => 38 | | zero 39 | | suc (n : Nat) 40 | 41 | data (A : Type) List => 42 | | nil 43 | | cons (x : A) (xs : List) 44 | 45 | -- Elaboration error! 46 | def z => zero 47 | 48 | -- All good 49 | def z : Nat => zero 50 | 51 | def xs : List Nat => cons zero (cons (suc zero) nil) 52 | 53 | * Dependent elimination for datatypes. 54 | ``` 55 | -- Eliminate a variable in the context 56 | def + (n m : Nat) : Nat => elim n with 57 | | zero => m 58 | | suc (m' / ih) => suc ih 59 | 60 | -- Elimination lambda 61 | def +-zero : (n : Nat) -> + n zero = n => \elim 62 | | zero => refl 63 | | suc (n' / ih) => match ih with refl i => refl 64 | * First class dependent records. 65 | ``` 66 | def Iso (A B : Type) : Type => sig 67 | | f : A -> B 68 | | g : B -> A 69 | | gf : (x : A) -> g (f x) = x 70 | | fg : (y : B) -> f (g y) = y 71 | 72 | def iso-refl (A : Type) : Iso A A => struct 73 | | f x => x 74 | | g x => x 75 | | gf _ => refl 76 | | fg _ => refl 77 | 78 | def iso-refl-f : Nat -> Nat => 79 | let r = iso-refl Nat in 80 | r.f 81 | * Record Extension (if there are duplicate fields, we simply keep the first one). 82 | ``` 83 | def Functor (F : Type -> Type) : Type => sig 84 | | map : (A B : Type) -> F A -> F B 85 | 86 | def Applicative (F : Type -> Type) : Type => sig extends Functor f 87 | | pure : (A : Type) -> A -> F A 88 | | <*> : (A B : Type) -> F (A -> B) -> F A -> F B 89 | 90 | def Functor-Maybe : Functor Maybe => struct 91 | | map A B f => (\elim none => none | some x => some (f x)) 92 | 93 | def Applicative-Maybe : Applicative Maybe => struct extends Functor-Maybe 94 | | pure x => some x 95 | | <*> A B => \elim 96 | | none => \ _ => none 97 | | some f => \elim 98 | | none => none 99 | | some x => some (f x) 100 | 101 | * A countable, cumulative hierachy of strict Russel-style universes. 102 | ```` 103 | def a : Type^1 => Type 104 | def b : Type^2 => Type 105 | def c : Type^2 => Type^1 106 | 107 | * Basic level polymorphism via McBride's "crude but effective stratification", where top-level definitions may be lifted to a higher universe. 108 | ``` 109 | def xs : List^1 Type => cons Nat nil 110 | def f (x : Type) : Type => x 111 | def g : Type^2 -> Type^2 => f^2 112 | * A (very basic) "module" system, allowing definitions to be imported from other files. There are no actual modules, and an import simply brings all definitions from the imported file into scope, unqualified. 113 | ``` 114 | import nat 115 | import bool 116 | 117 | def p : Nat * Bool => (zero,tt) 118 | * Holes. Terms containing holes will be defined even if you don't fill them, they just won't compute to anything. 119 | ``` 120 | def trans (A : Type) (x y z : A) (p : x = y) : y = z -> x = z => ? 121 | 122 | > ./datatt file.dtt 123 | > Hole ?0 at 1.66-1.67: 124 | A : Type 125 | p : x = y 126 | x : A 127 | y : A 128 | z : A 129 | 130 | ⊢ y = z → x = z 131 | 132 | 133 | 134 | 135 | ## Known Parsing Annoyance 136 | Because of how parsing is implemented, function application with parentheses will not parse properly. The parser thinks it's looking at a depedent function type with multiple arguments and gets confused when it can't find a `:`. To remedy this, just parenthesize the first argument: `(f x).proj ==> (f (x)).proj`. Having to do this is very silly, and I'd like to fix it. My next language will probably use a recursive descent parser. 137 | 138 | 139 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (using menhir 2.1) 3 | -------------------------------------------------------------------------------- /library/alg.dtt: -------------------------------------------------------------------------------- 1 | 2 | def Comm (A : Type) (op : A -> A -> A) : Type => (x y : A) -> op x y = op y x 3 | 4 | def Assoc (A : Type) (op : A -> A -> A) : Type => (x y z : A) -> op (op x y) z = op x (op y z) 5 | 6 | def Id-L (A : Type) (op : A -> A -> A) (z : A) : Type => (x : A) -> x = op z x 7 | 8 | def Id-R (A : Type) (op : A -> A -> A) (z : A) : Type => (x : A) -> x = op x z 9 | 10 | 11 | def Magma (C : Type) : Type => sig 12 | | op : C -> C -> C 13 | 14 | def Semigroup (C : Type) : Type => sig extends Magma C 15 | | assoc : Assoc C op 16 | 17 | def Monoid (M : Type) : Type => sig extends Semigroup M 18 | | z : M 19 | | id-l : Id-L M op z 20 | | id-r : Id-R M op z 21 | -------------------------------------------------------------------------------- /library/bool.dtt: -------------------------------------------------------------------------------- 1 | import id 2 | import unit 3 | import void 4 | 5 | data Bool => 6 | | tt 7 | | ff 8 | 9 | 10 | {- The traditional proof that tt != ff -} 11 | def no-confusion-Bool : Not (Id Bool tt ff) => \ p => 12 | subst Bool tt ff p (\elim tt => Unit | ff => Void) <> 13 | 14 | {- Some syntactic sugar, which we know is consistent because the above proof is possible -} 15 | def no-confusion-Bool : Not (Id Bool tt ff) => \ () 16 | 17 | 18 | def Bool-Ind (P : Bool -> Type) (t : P tt) (f : P ff) : (b : Bool) -> P b => \elim 19 | | tt => t 20 | | ff => f 21 | 22 | def not : Bool -> Bool => \elim 23 | | tt => ff 24 | | ff => tt 25 | 26 | 27 | def and (a b : Bool) : Bool => elim a with 28 | | tt => b 29 | | ff => ff 30 | 31 | def or (a b : Bool) : Bool => elim a with 32 | | tt => tt 33 | | ff => b 34 | 35 | 36 | def not-not : (b : Bool) -> b = not (not b) => \elim 37 | | tt => refl 38 | | ff => refl 39 | 40 | def demorgan1 (a b : Bool) : not (and a b) = or (not a) (not b) => elim a with 41 | | tt => refl 42 | | ff => refl 43 | 44 | def demorgan2 (a b : Bool) : not (or a b) = and (not a) (not b) => elim a with 45 | | tt => refl 46 | | ff => refl 47 | 48 | def lift : Bool -> Type => \elim 49 | | tt => Unit 50 | | ff => Void 51 | 52 | def split (A B : Type) : Bool -> Type => \elim 53 | | tt => A 54 | | ff => B 55 | 56 | -------------------------------------------------------------------------------- /library/category.dtt: -------------------------------------------------------------------------------- 1 | import id 2 | 3 | def Category : Type^1 => sig 4 | | Obj : Type 5 | | Mor : Obj -> Obj -> Type 6 | | id : (A : Obj) -> Mor A A 7 | | comp : (A B C : Obj) -> Mor A B -> Mor B C -> Mor A C 8 | | assoc : (A B C D : Obj) (f : Mor A B) (g : Mor B C) (h : Mor C D) -> comp A B D f (comp B C D g h) = comp A C D (comp A B C f g) h 9 | | id-l : (A B : Obj) (f : Mor A B) -> f = comp A A B (id A) f 10 | | id-r : (A B : Obj) (f : Mor A B) -> f = comp A B B f (id B) 11 | 12 | -- Bundled Morphism 13 | def BMor (C : Category) : Type => sig 14 | | o1 : C.Obj | o2 : C.Obj 15 | | m : C.Mor o1 o2 16 | 17 | def Type-Cat : Category^1 => struct 18 | | Obj => Type 19 | | Mor A B => A -> B 20 | | id A x => x 21 | | comp A B C f g x => g (f x) 22 | | assoc A B C D f g h => refl 23 | | id-l A B f => refl 24 | | id-r A B f => refl 25 | 26 | def Type->Type-Cat : Category^1 => struct 27 | | Obj => Type -> Type 28 | | Mor F G => (A : Type) -> F A -> G A 29 | | id F A x => x 30 | | comp F G H f g A fa => g A (f A fa) 31 | | assoc F G H I f g h => refl 32 | | id-l F G f => refl 33 | | id-r F G f => refl 34 | 35 | 36 | def Functor (C D : Category) : Type => sig 37 | | F1 : C.Obj -> D.Obj 38 | | F2 : (A B : C.Obj) -> C.Mor A B -> D.Mor (F1 A) (F1 B) 39 | | id : (A : C.Obj) -> F2 A A (C.id A) = D.id (F1 A) 40 | | comp : (X Y Z : C.Obj) (f : C.Mor X Y) (g : C.Mor Y Z) -> F2 X Z (C.comp X Y Z f g) = D.comp (F1 X) (F1 Y) (F1 Z) (F2 X Y f) (F2 Y Z g) 41 | 42 | def Nat-Trans (C D : Category) (F G : Functor C D) : Type => sig 43 | | eta : (X : C.Obj) -> D.Mor (F.F1 X) (G.F1 X) 44 | | comp : (X Y : C.Obj) (f : C.Mor X Y) -> 45 | D.comp (F.F1 X) (F.F1 Y) (G.F1 Y) (F.F2 X Y f) (eta Y) = D.comp (F.F1 X) (G.F1 X) (G.F1 Y) (eta X) (G.F2 X Y f) 46 | 47 | def Functor-Category (C D : Category) : Category => struct 48 | | Obj => Functor C D 49 | | Mor => Nat-Trans C D 50 | | id F => (struct 51 | | eta X => D.id (F.F1 X) 52 | | comp X Y f => match D.id-l (F.F1 X) (F.F1 Y) (F.F2 X Y f) with 53 | | refl i => match D.id-r (F.F1 X) (F.F1 Y) i with 54 | | refl j => refl 55 | ) 56 | | comp F G H n1 n2 => (struct 57 | | eta X => D.comp (F.F1 X) (G.F1 X) (H.F1 X) (n1.eta X) (n2.eta X) 58 | | comp X Y f => ? 59 | ) 60 | | assoc => ? 61 | | id-l => ? 62 | | id-r => ? 63 | 64 | def Endofunctor (C : Category) : Type => Functor C C 65 | 66 | def Type->Type-Cat => Functor-Category^1 Type-Cat Type-Cat 67 | -------------------------------------------------------------------------------- /library/classical.dtt: -------------------------------------------------------------------------------- 1 | import dec 2 | 3 | def EM : Type^1 => (A : Type) -> Dec A 4 | def DNE : Type^1 => (A : Type) -> Not (Not A) -> A 5 | 6 | def EM->DNE : EM -> DNE => \ em A => 7 | elim em A with 8 | | yes a => \ _ => a 9 | | no ~a => \ ~~a => elim ~~a ~a with 10 | 11 | def Stable (A : Type) : Type => Not (Not A) -> A 12 | 13 | def Not-Stable (A : Type) : Stable (Not A) => \ ~~~a a => 14 | ~~~a (\ ~a => ~a a) 15 | 16 | def *-Stable (A B : Type) (sa : Stable A) (sb : Stable B) : Stable (A * B) => \ ~~a*b => 17 | (sa (\ ~a => ~~a*b (\ p => ~a p.1)), sb (\ ~b => ~~a*b (\ p => ~b p.2))) 18 | 19 | def Dec->Stable (A : Type) : Dec A -> Stable A => \elim 20 | | yes a => \ _ => a 21 | | no ~a => \ ~~a => elim ~~a ~a with 22 | -------------------------------------------------------------------------------- /library/dec.dtt: -------------------------------------------------------------------------------- 1 | import bool 2 | import nat 3 | import sum 4 | 5 | data (A : Type) Dec => 6 | | yes (x : A) 7 | | no (x : Not A) 8 | 9 | def lower (A : Type) : Dec A -> Bool => \elim 10 | | yes _ => tt 11 | | no _ => ff 12 | 13 | def Dec-Id (A : Type) : Type => (x y : A) -> Dec (x = y) 14 | 15 | 16 | def dec-Unit : Dec-Id Unit => \ _ _ => yes refl 17 | 18 | 19 | def dec-Bool : Dec-Id Bool => \elim 20 | | tt => (\elim tt => yes refl | ff => no (\ ())) 21 | | ff => (\elim tt => no (\ ()) | ff => yes refl) 22 | 23 | def eq-Bool (x y : Bool) : Bool => lower (Id Bool x y) (dec-Bool x y) 24 | 25 | def dec-Nat : Dec-Id Nat => \elim 26 | | zero => (\elim zero => yes refl | suc n => no (\ ())) 27 | | suc (n / ih) => 28 | \elim 29 | | zero => no (\ ()) 30 | | suc m => elim ih m with 31 | | yes p => (match p with refl j => yes refl) 32 | | no ~p => no (\ p => ~p (cong Nat Nat pred (suc n) (suc m) p)) 33 | 34 | 35 | def eq-Nat (x y : Nat) : Bool => lower (x = y) (dec-Nat x y) 36 | 37 | 38 | def dec-* (A B : Type) : Dec A -> Dec B -> Dec (A * B) => \elim 39 | | yes a => (\elim 40 | | yes b => yes (a,b) 41 | | no ~b => no (\ p => ~b p.2) 42 | ) 43 | | no ~a => (\elim 44 | | yes b => no (\ p => ~a p.1) 45 | | no ~b => no (\ p => ~a p.1) 46 | ) 47 | 48 | def dec-id-* (A B : Type) (da : Dec-Id A) (db : Dec-Id B) : Dec-Id (A * B) => \ p q => 49 | elim da p.1 q.1 with 50 | | yes a => (elim db p.2 q.2 with 51 | | yes b => yes (pair-ext A B p q a b) 52 | | no ~b => no (\ i => ~b (pair-id-r A B p q i)) 53 | ) 54 | | no ~a => (elim db p.2 q.2 with 55 | | yes b => no (\ i => ~a (pair-id-l A B p q i)) 56 | | no ~b => no (\ i => ~a (pair-id-l A B p q i)) 57 | ) 58 | 59 | def eq-* (A B : Type) (da : Dec-Id A) (db : Dec-Id B) (x y : A * B): Bool => lower (x = y) (dec-id-* A B da db x y) 60 | 61 | def dec-Sum (A B : Type) : Dec A -> Dec B -> Dec (Sum A B) => \elim 62 | | yes a => \ _ => yes (inl a) 63 | | no ~a => \elim 64 | | yes b => yes (inr b) 65 | | no ~b => no (\elim inl a => ~a a | inr b => ~b b) 66 | 67 | def dec-id-Sum (A B : Type) (da : Dec-Id A) (db : Dec-Id B) : Dec-Id (Sum A B) => \elim 68 | | inl a => (\elim 69 | | inl a' => (elim da a a' with 70 | | yes p => match p with refl x => yes refl 71 | | no ~p => no (\ q => ~p (inl-inj A B a a' q)) 72 | ) 73 | | inr b => no (\ ()) 74 | ) 75 | | inr b => (\elim 76 | | inr b' => (elim db b b' with 77 | | yes p => match p with refl x => yes refl 78 | | no ~p => no (\ q => ~p (inr-inj A B b b' q)) 79 | ) 80 | | inl a => no (\ ()) 81 | ) 82 | 83 | def eq-Sum (A B : Type) (da : Dec-Id A) (db : Dec-Id B) (s1 s2 : Sum A B) : Bool => lower (s1 = s2) (dec-id-Sum A B da db s1 s2) -------------------------------------------------------------------------------- /library/dep_encode.dtt: -------------------------------------------------------------------------------- 1 | import fn 2 | import bool 3 | 4 | def ProdP (A B : Type) : Type => (b : Bool) -> split A B b 5 | def pairP (A B : Type) (x : A) (y : B) : ProdP A B => \elim 6 | | tt => x 7 | | ff => y 8 | 9 | def fstP (A B : Type) (p : ProdP A B) : A => p tt 10 | def sndP (A B : Type) (p : ProdP A B) : B => p ff 11 | 12 | def ProdP-Eta (A B : Type) (p : ProdP A B) : Id (ProdP A B) p (pairP A B (fstP A B p) (sndP A B p)) => 13 | funextd Bool (split A B) p (pairP A B (fstP A B p) (sndP A B p)) ( 14 | \elim tt => refl | ff => refl 15 | ) 16 | 17 | def SumS (A B : Type) : Type => (b : Bool) * split A B b 18 | def inlS (A B : Type) (x : A) : SumS A B => (tt,x) 19 | def inrS (A B : Type) (x : B) : SumS A B => (ff,x) 20 | -------------------------------------------------------------------------------- /library/exp.dtt: -------------------------------------------------------------------------------- 1 | 2 | import nat 3 | 4 | data Exp => 5 | | num (n : Nat) 6 | | add (m n : Exp) 7 | 8 | def eval : Exp -> Nat => \elim 9 | | num n => n 10 | | add (_ / ih1) (_ / ih2) => + ih1 ih2 11 | 12 | def eval-tail' : Exp -> Nat -> Nat => \elim 13 | | num n => \ acc => + n acc 14 | | add (n / ih1) (m / ih2) => \ acc => ih1 (ih2 acc) 15 | 16 | def eval-tail : Exp -> Nat => \ e => eval-tail' e zero -------------------------------------------------------------------------------- /library/fin.dtt: -------------------------------------------------------------------------------- 1 | import nat 2 | import sum 3 | import unit 4 | import void 5 | 6 | def Fin : Nat -> Type => \elim 7 | | zero => Void 8 | | suc (_ / ih) => Sum Unit ih 9 | 10 | def fzero (n : Nat) : Fin (suc n) => inl <> 11 | def fsuc (n : Nat) (f : Fin n) : Fin (suc n) => inr f 12 | 13 | 14 | def Fin-Ind (P : (n : Nat) -> Fin n -> Type) (z : (n : Nat) -> P (suc n) (fzero n)) 15 | (s : (n : Nat) (f : Fin n) -> P n f -> P (suc n) (fsuc n f)) : (n : Nat) (f : Fin n) -> P n f => \elim 16 | | zero => (\elim) 17 | | suc (n / ih) => \elim 18 | | inl x => z n 19 | | inr m => s n m (ih m) 20 | 21 | {- 22 | def f+ : (n m : Nat) (x : Fin n) (y : Fin m) -> Fin (+ n m) => \elim 23 | | zero => \ _ => (\elim) 24 | | suc n => \elim 25 | | zero => \ _ => (\elim) 26 | | suc m => \elim 27 | | inl x => (\elim inl x => inl <> | inr x => ?) 28 | | inr x => ? 29 | -} -------------------------------------------------------------------------------- /library/fn.dtt: -------------------------------------------------------------------------------- 1 | 2 | def id (A : Type) (x : A) : A => x 3 | 4 | def const (A B : Type) (x : A) : B -> A => \ _ => x 5 | 6 | def curry (A B C : Type) (f : A * B -> C) : A -> B -> C => \ x y => f (x,y) 7 | def curryd (A : Type) (B : A -> Type) (C : (x : A) -> B x -> Type) (f : (p : (x : A) * B x) -> C p.1 p.2) : (x : A) (y : B x) -> C x y => \ x y => f (x,y) 8 | 9 | def uncurry (A B C : Type) (f : A -> B -> C) : A * B -> C => \ p => f p.1 p.2 10 | def uncurryd (A : Type) (B : A -> Type) (C : ((x : A) * B x) -> Type) (f : (x : A) (y : B x) -> C (x,y)) : (p : (x : A) * B x) -> C p => \ p => f p.1 p.2 11 | 12 | axiom funextd : (A : Type) (B : A -> Type) (f g : (x : A) -> B x) -> ((x : A) -> Id (B x) (f x) (g x)) -> Id ((x : A) -> B x) f g -------------------------------------------------------------------------------- /library/hott.dtt: -------------------------------------------------------------------------------- 1 | 2 | import id 3 | import unit 4 | import void 5 | import dec 6 | import nat 7 | 8 | def Contr (A : Type) : Type => (x : A) * (y : A) -> x = y 9 | 10 | def Prop (A : Type) : Type => (x y : A) -> x = y 11 | 12 | def Set (A : Type) : Type => (x y : A) -> Prop (x = y) 13 | 14 | def Contr->Prop (A : Type) (p : Contr A) : Prop A => 15 | \ x y => trans A x p.1 y (sym A p.1 x (p.2 x)) (p.2 y) 16 | 17 | def Singl (A : Type) (x : A) : Type => (y : A) * (x = y) 18 | 19 | def Contr-Singl (A : Type) (x : A) : Contr (Singl A x) => 20 | ((x,refl),\ p => match p.2 with refl w => refl) 21 | 22 | 23 | -- Contractibility of singletons gets us an uncurried version of alternative J 24 | def H (A : Type) (x : A) (P : ((y : A) * (x = y)) -> Type) (p : (y : A) * (x = y)) : P (x,refl) -> P p => 25 | match (Contr-Singl (A) x).2 p with 26 | | refl i => \ x => x 27 | 28 | -- Alternative version of J where x is treated as a parameter instead of an index 29 | def J' (A : Type) (x : A) (P : (y : A) -> x = y -> Type) (d : P x refl) (y : A) (p : x = y) : P y p => 30 | H A x (\ p => P p.1 p.2) (y,p) d 31 | 32 | 33 | def Constant (A B : Type) (f : A -> B) : Type => (x y : A) -> f x = f y 34 | 35 | def Collapsible (A : Type) : Type => (f : A -> A) * Constant A A f 36 | 37 | def Id-Collapsible (A : Type) : Type => (x y : A) -> Collapsible (x = y) 38 | 39 | def Set->Id-Collapsible (A : Type) (s : Set A) : Id-Collapsible A => \ x y => 40 | (\ x => x,s x y) 41 | 42 | -- Black Magic I stole from https://www.cs.bham.ac.uk/~mhe/GeneralizedHedberg/html/GeneralizedHedberg.html 43 | 44 | def Id-Collapsible->Set (A : Type) (c : Id-Collapsible A) : Set A => \ x y p q => 45 | let f (x y : A) : x = y -> x = y => (c (x) y).1 in 46 | let g (x y : A) : (p q : x = y) -> f x y p = f x y q => (c (x) y).2 in 47 | let claim0 (x y : A) (r : x = y) : r = trans A x x y (sym A x x (f x x refl)) (f x y r) => 48 | match r with 49 | | refl x => sym-inverse A x x (f x x refl) 50 | in 51 | let claim1 : trans A x x y (sym A x x (f x x refl)) (f x y p) = trans A x x y (sym A x x (f x x refl)) (f x y q) => 52 | cong (x = y) (x = y) (\ h => trans A x x y (sym A x x (f x x refl)) h) (f x y p) (f x y q) (g x y p q) 53 | in 54 | let w => trans (x = y) p (trans A x x y (sym A x x (f x x refl)) (f x y p)) (trans A x x y (sym A x x (f x x refl)) (f x y q)) (claim0 x y p) claim1 in 55 | trans (x = y) p (trans A x x y (sym A x x (f x x refl)) (f x y q)) q w (sym (x = y) q (trans A x x y (sym A x x (f x x refl)) (f x y q)) (claim0 x y q)) 56 | 57 | 58 | def Prop->Id-Collapsible (A : Type) (h : Prop A) : Id-Collapsible A => \ x y => 59 | (\ _ => h x y,\ _ _ => refl) 60 | 61 | def Prop->Set (A : Type) (h : Prop A) : Set A => Id-Collapsible->Set A (Prop->Id-Collapsible A h) 62 | 63 | def Void-Collapsible : Collapsible Void => 64 | (\ x => x, \elim) 65 | 66 | def Inhabited->Collapsible (A : Type) (pt : A) : Collapsible A => 67 | (\ _ => pt, \ _ _ => refl) 68 | 69 | def Empty->Collapsible (A : Type) (e : A -> Void) : Collapsible A => 70 | (\ x => x,\ x => elim e x with) 71 | 72 | 73 | def Dec->Collapsible (A : Type) : Dec A -> Collapsible A => \elim 74 | | yes pt => Inhabited->Collapsible A pt 75 | | no ~pt => Empty->Collapsible A ~pt 76 | 77 | def Dec-Id->Id-Collapsible (A : Type) (d : Dec-Id A) : Id-Collapsible A => \ x y => Dec->Collapsible (x = y) (d x y) 78 | 79 | 80 | -- Hedberg's Theorem 81 | def Dec-Id->Set (A : Type) (d : Dec-Id A) : Set A => Id-Collapsible->Set A (Dec-Id->Id-Collapsible A d) 82 | def Hedberg => Dec-Id->Set 83 | 84 | def Contr-Unit : Contr Unit => (<>,Unit-Eta) 85 | 86 | def Prop-Unit : Prop Unit => \_ _ => refl 87 | 88 | -- Direct proof that Unit is a Set 89 | def Set-Unit' : Set Unit => \_ _ p q => 90 | match p with 91 | | refl i => match q with 92 | | refl j => refl 93 | 94 | def Set-Unit : Set Unit => Prop->Set Unit Prop-Unit 95 | 96 | def Prop-Void : Prop Void => \elim 97 | 98 | def Set-Void : Set Void => \elim 99 | 100 | 101 | def HLevel : Nat -> Type -> Type => \elim 102 | | zero => Contr 103 | | suc n => elim n with 104 | | zero => Prop 105 | | suc (_ / ih) => \ A => (x y : A) -> ih (x = y) 106 | 107 | 108 | def HLevel-suc : (n : Nat) (A : Type) -> HLevel n A -> HLevel (suc n) A => \elim 109 | | zero => Contr->Prop 110 | | suc n => elim n with 111 | | zero => Prop->Set 112 | | suc (n' / ih) => \ A h a b => ih (a = b) (h a b) 113 | -------------------------------------------------------------------------------- /library/id.dtt: -------------------------------------------------------------------------------- 1 | 2 | def J (A : Type) (P : (x y : A) -> x = y -> Type) (f : (x : A) -> P x x refl) (x y : A) (p : x = y) : P x y p => 3 | match p with 4 | | refl i => f i 5 | 6 | axiom K : (A : Type) (x : A) (P : x = x -> Type) (r : P refl) (p : x = x) -> P p 7 | 8 | 9 | -- K implies UIP 10 | def UIP (A : Type) (x y : A) : (p q : x = y) -> p = q => \p => 11 | match p with 12 | | refl i => K A i (\q => refl = q) refl 13 | 14 | def sym (A : Type) (x y : A) (p : x = y) : y = x => 15 | match p with 16 | | refl x => refl 17 | 18 | def trans (A : Type) (x y z : A) (p : x = y) : y = z -> x = z => 19 | match p with 20 | | refl _ => \ x => x 21 | 22 | def cong (A B : Type) (f : A -> B) (x y : A) (p : x = y) : f x = f y => 23 | match p with 24 | | refl _ => refl 25 | 26 | def subst (A : Type) (x y : A) (p : x = y) (P : A -> Type) : P x -> P y => 27 | match p with 28 | | refl _ => \ z => z 29 | 30 | def coe (A B : Type) (p : A = B) : A -> B => 31 | match p with 32 | | refl _ => λ x => x 33 | 34 | def trans-refl (A : Type) (x y : A) (p : x = y) : trans A x y y p refl = p => 35 | match p with 36 | | refl _ => refl 37 | 38 | def refl-trans (A : Type) (x y : A) (p : x = y) : trans A x x y refl p = p => 39 | refl 40 | 41 | def sym-sym (A : Type) (x y : A) (p : x = y) : sym A y x (sym A x y p) = p => 42 | match p with 43 | | refl i => refl 44 | 45 | def sym-inverse (A : Type) (x y : A) (p : x = y) : refl = trans A y x y (sym A x y p) p => 46 | match p with 47 | | refl i => refl 48 | 49 | def sym-refl (A : Type) (x : A) : sym A x x refl = refl => 50 | refl 51 | 52 | def trans-assoc (A : Type) (a b c d : A) (p : a = b) : (q : b = c) (h : c = d) -> trans A a c d (trans A a b c p q) h = trans A a b d p (trans A b c d q h) => 53 | match p with 54 | | refl i => \ q => match q with 55 | | refl j => \ h => refl 56 | 57 | def coe-refl (A : Type) (x : A) : coe A A refl x = x => refl 58 | 59 | def coe-trans (A B C : Type) (p : A = B) : (q : B = C) (x : A) -> coe B C q (coe A B p x) = coe A C (trans^1 Type A B C p q) x => 60 | match p with 61 | | refl I => \ _ _ => refl 62 | 63 | def pair-ext (A B : Type) (x y : A * B) (p : x.1 = y.1) (q : x.2 = y.2) : x = y => 64 | match p with 65 | | refl w => match q with 66 | | refl h => refl 67 | 68 | def fam-coe (A : Type) (B : A -> Type) (a b : A) (p : a = b) (y : B b) : B a => 69 | coe (B b) (B a) (cong^1 A Type B b a (sym A a b p)) y 70 | 71 | def pair-extd-uncurried (A : Type) (B : A -> Type) (x1 y1 : A) (p : x1 = y1) : 72 | (x2 : B x1) (y2 : B y1) (q : x2 = fam-coe A B x1 y1 p y2) -> Id ((a : A) * B a) (x1,x2) (y1,y2) => 73 | match p with 74 | | refl i => \x2 y2 q => match q with refl j => refl 75 | 76 | def pair-extd (A : Type) (B : A -> Type) (x y : (a : A) * B a) (p : x.1 = y.1) (q : x.2 = fam-coe A B x.1 y.1 p y.2) : x = y => 77 | pair-extd-uncurried A B x.1 y.1 p x.2 y.2 q 78 | 79 | 80 | def pair-id-l (A B : Type) (x y : A * B) (p : x = y) : x.1 = y.1 => 81 | cong (A * B) A (\ x => x.1) x y p 82 | 83 | def pair-id-r (A B : Type) (x y : A * B) (p : x = y) : x.2 = y.2 => 84 | cong (A * B) B (\ x => x.2) x y p 85 | -------------------------------------------------------------------------------- /library/int.dtt: -------------------------------------------------------------------------------- 1 | import nat 2 | 3 | data Int => 4 | | zero 5 | | psuc (n : Int) 6 | | nsuc (n : Int) 7 | 8 | def normalize : Int -> Int => \elim 9 | | zero => zero 10 | | nsuc (n / ih) => (elim ih with 11 | | psuc n => n 12 | | zero => nsuc zero 13 | | nsuc n => nsuc (nsuc n) 14 | ) 15 | | psuc (n / ih) => (elim ih with 16 | | nsuc n => n 17 | | zero => psuc zero 18 | | psuc n => psuc (psuc n) 19 | ) 20 | 21 | def psuc (i : Int) : Int => normalize (psuc i) 22 | def nsuc (i : Int) : Int => normalize (nsuc i) 23 | 24 | 25 | def ipred (n : Int) : Int => normalize (nsuc n) 26 | 27 | def i+ (n m : Int) : Int => normalize (elim n with 28 | | nsuc (n / ih) => nsuc ih 29 | | zero => m 30 | | psuc (n / ih) => psuc ih) 31 | 32 | 33 | -------------------------------------------------------------------------------- /library/iso.dtt: -------------------------------------------------------------------------------- 1 | 2 | import unit 3 | import void 4 | import nat 5 | import sum 6 | import fin 7 | import list 8 | import sg 9 | import dep_encode 10 | import fn 11 | import hott 12 | import int 13 | 14 | 15 | def Iso (A B : Type) : Type => sig 16 | | f : A -> B 17 | | g : B -> A 18 | | gf : (x : A) -> x = g (f x) 19 | | fg : (y : B) -> y = f (g y) 20 | 21 | def iso-refl (A : Type) : Iso A A => struct 22 | | f => \ x => x 23 | | g => \ x => x 24 | | gf => \ _ => refl 25 | | fg => \ _ => refl 26 | 27 | 28 | def iso-comm (A B : Type) : Iso (Iso A B) (Iso B A) => struct 29 | | f => \ i => (struct f => i.g | g => i.f | gf => i.fg | fg => i.gf) 30 | | g => \ i => (struct f => i.g | g => i.f | gf => i.fg | fg => i.gf) 31 | | gf => \ i => refl 32 | | fg => \ i => refl 33 | 34 | def iso/*-comm (A B : Type) : Iso (A * B) (B * A) => struct 35 | | f => \p => (p.2,p.1) 36 | | g => \p => (p.2,p.1) 37 | | gf => \ p => refl 38 | | fg => \ p => refl 39 | 40 | def iso/Sum-comm (A B : Type) : Iso (Sum A B) (Sum B A) => struct 41 | | f => (\elim inl x => inr x | inr y => inl y) 42 | | g => (\elim inl x => inr x | inr y => inl y) 43 | | gf => (\elim inl _ => refl | inr _ => refl) 44 | | fg => (\elim inl _ => refl | inr _ => refl) 45 | 46 | 47 | def iso/*-ident-r (A : Type) : Iso A (A * Unit) => struct 48 | | f => \ x => (x , <>) 49 | | g => \ p => p.1 50 | | gf => \ _ => refl 51 | | fg => \ p => refl 52 | 53 | 54 | def iso/Sum-ident-r (A : Type) : Iso A (Sum A Void) => struct 55 | | f => \ a => inl a 56 | | g => (\elim inl a => a | inr v => elim v with) 57 | | gf => \ _ => refl 58 | | fg => (\elim inl a => refl | inr v => elim v with) 59 | 60 | 61 | def iso/*-destroy-r (A : Type) : Iso (A * Void) Void => struct 62 | | f => \ p => p.2 63 | | g => (\elim) 64 | | gf => \ p => (elim p.2 with) 65 | | fg => (\elim) 66 | 67 | 68 | def iso/Bool/Unit+Unit : Iso Bool (Sum Unit Unit) => struct 69 | | f => (\elim tt => inl <> | ff => inr <>) 70 | | g => (\elim inl _ => tt | inr _ => ff) 71 | | gf => (\elim tt => refl | ff => refl) 72 | | fg => (\elim inl x => refl | inr x => refl) 73 | 74 | 75 | def iso/curryD (A : Type) (B : A -> Type) (C : (x : A) -> B x -> Type) : Iso ((x : A) (y : B x) -> C x y) ((p : (x : A) * B x) -> C p.1 p.2) => struct 76 | | f h p => h p.1 p.2 77 | | g h x y => h (x,y) 78 | | gf _ => refl 79 | | fg _ => refl 80 | 81 | 82 | 83 | 0 0 84 | 1 1 85 | 2 -1 86 | 3 2 87 | 4 -2 88 | 5 3 89 | 90 | def iso/Nat/Int : Iso Nat Int => struct 91 | | f => (\elim 92 | | zero => z 93 | | suc n => ? 94 | ) 95 | | g => ? 96 | | gf => ? 97 | | fg => ? 98 | 99 | {- 100 | def iso/*/Sg (A : Type) (B : A -> Type) : Iso ((x : A) * B x) (Sg A B) => 101 | ( \ p => pair p.1 p.2 102 | , \elim pair x y => (x,y) 103 | , \ _ => refl 104 | , \elim pair x y => refl 105 | ) 106 | 107 | 108 | def iso/*/ProdP (A B : Type) : Iso (A * B) (ProdP A B) => 109 | ( \ p => pairP A B p.1 p.2 110 | , \ p => (fstP (A) B p, sndP A B p) 111 | , \ _ => refl 112 | , ProdP-Eta A B 113 | ) 114 | 115 | 116 | def iso/SumS/Sum (A B : Type) : Iso (SumS A B) (Sum A B) => 117 | let f => uncurryd Bool (split A B) (\ _ => Sum A B) (\elim tt => \ x => inl x | ff => \ x => inr x) in 118 | let g : Sum A B -> SumS A B => \elim inl x => (tt,x) | inr x => (ff,x) in 119 | let fg : (s : Sum A B) -> s = f (g s) => \elim inl x => refl | inr x => refl in 120 | let gf => uncurryd Bool (split A B) (\ p => p = g (f p)) 121 | (\elim tt => \ n => refl | ff => \ n => refl) in 122 | ( f 123 | , g 124 | , gf 125 | , fg 126 | ) 127 | 128 | 129 | def iso/Nat/ListUnit : Iso Nat (List Unit) => 130 | ( \elim zero => nil | suc (_ / ih) => cons <> ih 131 | , \elim nil => zero | cons _ (_ / ih) => suc ih 132 | , \elim zero => refl | suc (n / ih) => match ih with refl j => refl 133 | , \elim nil => refl | cons x (xs / ih) => match ih with refl j => elim x with <> => refl 134 | ) 135 | 136 | 137 | def iso/Nat/Nat+1 : Iso Nat (Sum Unit Nat) => 138 | ( \elim zero => inl <> | suc (n / ih) => inr n 139 | , \elim inl x => zero | inr n => suc n 140 | , \elim zero => refl | suc (n / ih) => refl 141 | , \elim inl x => (elim x with <> => refl) | inr n => refl 142 | ) 143 | 144 | 145 | def iso/Bool/Fin2 : Iso Bool (Fin two) => 146 | ( \elim tt => inl <> | ff => inr (inl <>) 147 | , \elim inl _ => tt | inr x => elim x with inl _ => ff | inr v => elim v with 148 | , \elim tt => refl | ff => refl 149 | , \elim inl x => (elim x with <> => refl) | inr x => elim x with inl x => (elim x with <> => refl) | inr v => elim v with 150 | ) 151 | 152 | def iso/Contr/Unit (A : Type) (c : Contr A) : Iso A Unit => 153 | ( \ _ => <> 154 | , \ _ => c.1 155 | , \ x => sym A c.1 x (c.2 x) 156 | , \elim <> => refl 157 | ) 158 | 159 | def iso/curry (A B C : Type) : Iso (A -> B -> C) (A * B -> C) => 160 | ( uncurry (A) B C 161 | , curry (A) B C 162 | , \ f => refl 163 | , \ f => refl 164 | ) 165 | -} -------------------------------------------------------------------------------- /library/lang.dtt: -------------------------------------------------------------------------------- 1 | 2 | import nat 3 | import bool 4 | import dec 5 | import list 6 | import maybe 7 | import typeclass 8 | 9 | 10 | 11 | data Ty => 12 | | ar (a b : Ty) 13 | | bool 14 | | nat 15 | 16 | def dec-Ty : Dec-Id Ty => \elim 17 | | ar (a / iha) (b / ihb) => (\elim 18 | | ar a' b' => (elim iha a' with 19 | | yes pa => (elim ihb b' with 20 | | yes pb => match pa with refl i => match pb with refl j => yes refl 21 | | no ~pb => no (\ p => ~pb (cong Ty Ty (\elim ar _ b => b | bool => bool | nat => nat) (ar a b) (ar a' b') p)) 22 | ) 23 | | no ~pa => no (\ p => ~pa (cong Ty Ty (\elim ar a _ => a | bool => bool | nat => nat) (ar a b) (ar a' b') p)) 24 | ) 25 | | bool => no (\ ()) 26 | | nat => no (\ ()) 27 | ) 28 | | bool => (\elim 29 | | bool => yes refl 30 | | ar a b => no (\ ()) 31 | | nat => no (\ ()) 32 | ) 33 | | nat => (\elim 34 | | nat => yes refl 35 | | ar _ _ => no (\ ()) 36 | | bool => no (\ ()) 37 | ) 38 | 39 | def eq-Ty (t1 t2 : Ty) : Bool => lower (Id Ty t1 t2) (dec-Ty t1 t2) 40 | 41 | data Tm => 42 | | var (n : Nat) 43 | | tt 44 | | ff 45 | | if (b e1 e2 : Tm) 46 | | zero 47 | | suc (n : Tm) 48 | | rec (e z s : Tm) 49 | | lam (t : Ty) (e : Tm) 50 | | ap (f e : Tm) 51 | 52 | def synth : Tm -> List Ty -> Maybe Ty => let bind => bind Maybe Monad-Maybe Ty Ty in \elim 53 | | var n => \ ctx => get Ty ctx n 54 | | tt => \ _ => some bool 55 | | ff => \ _ => some bool 56 | | if (b / bty) (e1 / e1ty) (e2 / e2ty) => \ ctx => bind (bty ctx) (\elim 57 | | ar _ _ => none 58 | | nat => none 59 | | bool => bind (e1ty ctx) (\ t1 => bind (e2ty ctx) (\ t2 => 60 | elim eq-Ty t1 t2 with 61 | | tt => some t1 62 | | ff => none 63 | )) 64 | ) 65 | | lam t1 (e / ih) => \ ctx => 66 | bind (ih (cons t1 ctx)) (\ t2 => 67 | some (ar t1 t2) 68 | ) 69 | | ap (f / fty) (e / ety) => \ ctx => bind (fty ctx) (\elim 70 | | bool => none 71 | | nat => none 72 | | ar a b => bind (ety ctx) (\ t => 73 | elim eq-Ty a t with 74 | | tt => some b 75 | | ff => none 76 | ) 77 | ) 78 | | zero => \ _ => some nat 79 | | suc (n / nty) => \ ctx => bind (nty ctx) (\elim 80 | | nat => some nat 81 | | bool => none 82 | | ar _ _ => none 83 | ) 84 | | rec (n / nty) (z / zty) (s / sty) => \ ctx => bind (nty ctx) (\elim 85 | | bool => none 86 | | ar _ _ => none 87 | | nat => 88 | bind (zty ctx) (\ t => 89 | bind (sty (cons t ctx)) (\ t' => 90 | elim eq-Ty t t' with 91 | | tt => some t 92 | | ff => none 93 | ) 94 | ) 95 | ) 96 | 97 | 98 | def tm1 : Tm => lam bool (lam bool (var zero)) 99 | def tm2 : Tm => lam nat (lam nat (rec (var one) (var zero) (suc (var zero)))) 100 | -------------------------------------------------------------------------------- /library/lc.dtt: -------------------------------------------------------------------------------- 1 | import nat 2 | import bool 3 | import dec 4 | 5 | data Tm => 6 | | var (n : Nat) 7 | | lam (e : Tm) 8 | | ap (f e : Tm) 9 | 10 | def well-scoped : Tm -> Nat -> Bool => \elim 11 | | var x => \ n => lt-b x n 12 | | lam (e / ih) => \ n => ih (suc n) 13 | | ap (f / ihf) (e / ihe) => \ n => and (ihf n) (ihe n) 14 | 15 | 16 | def subst : Tm -> Tm -> Nat -> Tm => \elim 17 | | var y => \ q x => (elim eq-Nat x y with tt => q | ff => var y) 18 | | lam (e / ih) => \ q x => lam (ih q (suc x)) 19 | | ap (f / ihf) (e / ihe) => \ q x => ap (ihf q x) (ihe q x) 20 | 21 | def reduce : Tm -> Tm => \elim 22 | | var x => var x 23 | | lam e => lam e 24 | | ap (f / f') e => elim f' with 25 | | lam e' => subst e' e zero 26 | | var x => ap f' e 27 | | ap _ _ => ap f' e 28 | 29 | def id : Tm => lam (var zero) 30 | def const : Tm => lam (lam (var one)) 31 | def z : Tm => lam (lam (var zero)) 32 | def s : Tm => lam (lam (lam (ap (var one) (ap (ap (var two) (var one)) (var zero))))) 33 | def plus : Tm => lam (lam (lam (lam (ap (ap (var three) (var one)) (ap (ap (var two) (var one)) (var zero)))))) 34 | -------------------------------------------------------------------------------- /library/list.dtt: -------------------------------------------------------------------------------- 1 | import maybe 2 | import alg 3 | import nat 4 | 5 | data (A : Type) List => 6 | | nil 7 | | cons (x : A) (xs : List) 8 | 9 | def List-Ind (A : Type) (P : List A -> Type) (n : P nil) (c : (x : A) (xs : List A) -> P xs -> P (cons x xs)) : (xs : List A) -> P xs => \elim 10 | | nil => n 11 | | cons x (xs / ih) => c x xs ih 12 | 13 | def ++ (A : Type) (xs ys : List A) : List A => elim xs with 14 | | nil => ys 15 | | cons x (_ / ih) => cons x ih 16 | 17 | def hd (A : Type) : List A -> Maybe A => \elim 18 | | nil => none 19 | | cons x _ => some x 20 | 21 | def tl (A : Type) : List A -> List A => \elim 22 | | nil => nil 23 | | cons _ xs => xs 24 | 25 | def ++-assoc (A : Type) : Assoc (List A) (++ A) => \ xs ys zs => elim xs with 26 | | nil => refl 27 | | cons x (xs / ih) => match ih with 28 | | refl _ => refl 29 | 30 | def ++-nil (A : Type) : Id-R (List A) (++ A) nil => \elim 31 | | nil => refl 32 | | cons x (xs / ih) => match ih with 33 | | refl _ => refl 34 | 35 | def map (A B : Type) (f : A -> B) : List A -> List B => \elim 36 | | nil => nil 37 | | cons x (xs / ih) => cons (f x) ih 38 | 39 | def map-comm-comp (A B C : Type) (f : A -> B) (g : B -> C) : (xs : List A) -> Id (List C) (map B C g (map A B f xs)) (map A C (\ x => g (f x)) xs) => \elim 40 | | nil => refl 41 | | cons x (xs / ih) => match ih with 42 | | refl i => refl 43 | 44 | def rev (A : Type) : List A -> List A => \elim 45 | | nil => nil 46 | | cons x (xs / rev-xs) => ++ A rev-xs (cons x nil) 47 | 48 | def rev-tail (A : Type) : List A -> List A -> List A => \elim 49 | | nil => \ acc => acc 50 | | cons x (xs / ih) => \ acc => ih (cons x acc) 51 | 52 | 53 | def get (A : Type) : List A -> Nat -> Maybe A => \elim 54 | | nil => \ _ => none 55 | | cons x (xs / ih) => \elim 56 | | zero => some x 57 | | suc n => ih n 58 | 59 | def Monoid-List-++ (A : Type) : Monoid (List A) => struct 60 | | op => ++ A 61 | | assoc => ++-assoc A 62 | | z => nil 63 | | id-l => \ _ => refl 64 | | id-r => ++-nil A 65 | -------------------------------------------------------------------------------- /library/map.dtt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmcqd/datatt/073e850096b522282e33ab4081744f961a43bb05/library/map.dtt -------------------------------------------------------------------------------- /library/maybe.dtt: -------------------------------------------------------------------------------- 1 | data (A : Type) Maybe => 2 | | none 3 | | some (x : A) 4 | 5 | def Maybe-Ind (A : Type) (P : Maybe A -> Type) (n : P none) (s : (x : A) -> P (some x)) : (x : Maybe A) -> P x => \elim 6 | | none => n 7 | | some x => s x 8 | 9 | def Maybe-Rec (A B : Type) (n : B) (s : A -> B) : Maybe A -> B => \elim 10 | | none => n 11 | | some x => s x 12 | 13 | -------------------------------------------------------------------------------- /library/nat.dtt: -------------------------------------------------------------------------------- 1 | import fn 2 | import unit 3 | import void 4 | import bool 5 | import alg 6 | 7 | data Nat => 8 | | zero 9 | | suc (n : Nat) 10 | 11 | def one : Nat => suc zero 12 | def two : Nat => suc one 13 | def three : Nat => suc two 14 | def four : Nat => suc three 15 | 16 | def Nat-Ind (P : Nat -> Type) (z : P zero) (s : (m : Nat) -> P m -> P (suc m)) : (n : Nat) -> P n => \elim 17 | | zero => z 18 | | suc (n / ih) => s n ih 19 | 20 | def no-confusion-Nat (n : Nat) : Not (Id Nat zero (suc n)) => \ () 21 | 22 | def pred : Nat -> Nat => \elim 23 | | zero => zero 24 | | suc n => n 25 | 26 | def + (n m : Nat) : Nat => elim n with 27 | | zero => m 28 | | suc (_ / ih) => suc ih 29 | 30 | def mult (n m : Nat) : Nat => elim n with 31 | | zero => zero 32 | | suc (_ / ih) => + m ih 33 | 34 | def exp (n m : Nat) : Nat => elim m with 35 | | zero => one 36 | | suc (_ / ih) => mult n ih 37 | 38 | def /2 : Nat -> Nat => \elim 39 | | zero => zero 40 | | suc n => elim n with 41 | | zero => zero 42 | | suc (n / ih) => suc ih 43 | 44 | 45 | def +-assoc : Assoc Nat + => \ n m p => elim n with 46 | | zero => refl 47 | | suc (_ / ih) => match ih with 48 | | refl _ => refl 49 | 50 | def +-zero : Id-R Nat + zero => \elim 51 | | zero => refl 52 | | suc (_ / ih) => match ih with 53 | | refl _ => refl 54 | 55 | def +-suc (n m : Nat) : suc (+ n m) = + n (suc m) => elim n with 56 | | zero => refl 57 | | suc (n' / ih) => 58 | match ih with 59 | | refl z => refl 60 | 61 | def +-comm : Comm Nat + => \ n m => elim n with 62 | | zero => +-zero m 63 | | suc (n / ih) => trans Nat (suc (+ n m)) (suc (+ m n)) (+ m (suc n)) 64 | (cong Nat Nat (\ x => suc x) (+ n m) (+ m n) ih) 65 | (+-suc m n) 66 | 67 | def leq-b : Nat -> Nat -> Bool => \elim 68 | | zero => \ _ => tt 69 | | suc (_ / ih) => \elim 70 | | zero => ff 71 | | suc n => ih n 72 | 73 | def leq (n m : Nat) : Type => lift (leq-b n m) 74 | 75 | def leq-zero (n : Nat) : leq zero n => <> 76 | def leq-suc (m n : Nat) (p : leq m n) : leq (suc m) (suc n) => p 77 | 78 | 79 | def lt-b (m n : Nat) : Bool => leq-b (suc m) n 80 | 81 | def lt (m n : Nat) : Type => lift (lt-b m n) 82 | 83 | def even-b : Nat -> Bool => \elim 84 | | zero => tt 85 | | suc (n / ih) => not ih 86 | 87 | def even (n : Nat) : Type => lift (even-b n) 88 | 89 | 90 | def id-elim : Nat -> Nat => \elim 91 | | zero => zero 92 | | suc n => suc n 93 | 94 | def id-elim-id : (n : Nat) -> id Nat n = id-elim n => \elim 95 | | zero => refl 96 | | suc _ => refl 97 | 98 | def suc-Inj (n m : Nat) : Id Nat (suc n) (suc m) -> Id Nat n m => 99 | cong Nat Nat pred (suc n) (suc m) 100 | 101 | def Monoid-Nat-+ : Monoid Nat => struct 102 | | op => + 103 | | assoc => +-assoc 104 | | z => zero 105 | | id-l _ => refl 106 | | id-r => +-zero -------------------------------------------------------------------------------- /library/ptype.dtt: -------------------------------------------------------------------------------- 1 | import id 2 | import unit 3 | import nat 4 | import bool 5 | 6 | def PType : Type^1 => sig 7 | | t : Type 8 | | pt : t 9 | 10 | def UnitP : PType => struct t => Unit | pt => <> 11 | def BoolP : PType => struct t => Bool | pt => tt 12 | def NatP : PType => struct t => Nat | pt => zero 13 | def TypeP : PType^1 => struct t => Type | pt => Unit 14 | def TypePN : PType^2 => struct t => Type^1 | pt => Type 15 | 16 | 17 | def *-P (A B : PType) : PType => struct 18 | | t => A.t * B.t 19 | | pt => (A.pt,B.pt) 20 | 21 | def Loop (P : PType) : PType => struct 22 | | t => P.pt = P.pt 23 | | pt => refl 24 | 25 | def LoopN (n : Nat) (P : PType) : PType => elim n with 26 | | zero => P 27 | | suc (_ / ih) => Loop ih 28 | 29 | def PType-not-Void (P : PType) : Not^1 (P.t = Void) => \ p => 30 | coe P.t Void p P.pt 31 | 32 | def PPi (A : PType) (B : A.t -> PType) : Type => sig 33 | | map : (x : A.t) -> (B (x)).t 34 | | pt : map A.pt = (B (A.pt)).pt 35 | 36 | def PMap (A B : PType) : Type => PPi A (\_ => B) 37 | def PFun => PMap 38 | 39 | 40 | def Pid (A : PType) : PMap A A => struct 41 | | map x => x 42 | | pt => refl 43 | 44 | def Pcomp (A B C : PType) (f : PMap A B) (g : PMap B C) : PMap A C => struct 45 | | map x => g.map (f.map x) 46 | | pt => let p => cong B.t C.t g.map (f.map A.pt) B.pt f.pt in 47 | trans C.t (g.map (f.map A.pt)) (g.map B.pt) C.pt p g.pt 48 | 49 | def Pconst (A B : PType) : PMap A B => struct 50 | | map _ => B.pt 51 | | pt => refl -------------------------------------------------------------------------------- /library/queue.dtt: -------------------------------------------------------------------------------- 1 | import nat 2 | import list 3 | import maybe 4 | import sum 5 | 6 | def QUEUE : Type^1 => sig 7 | | t : Type -> Type 8 | | emp : (A : Type) -> t A 9 | | enq : (A : Type) -> A -> t A -> t A 10 | | deq : (A : Type) -> t A -> Maybe (A * t A) 11 | 12 | def Queue1 : QUEUE => struct 13 | | t => List 14 | | emp A => nil 15 | | enq A x q => cons x q 16 | | deq A q => elim rev A q with 17 | | nil => none 18 | | cons x q => some (x,q) 19 | 20 | def Queue2 : QUEUE => struct 21 | | t A => (sig In : List A | Out : List A) 22 | | emp A => (struct In => nil | Out => nil) 23 | | enq A x q => (struct In => cons x q.In | Out => q.Out) 24 | | deq A q => elim q.Out with 25 | | cons x xs => some (x,struct In => q.In | Out => xs) 26 | | nil => let Out => rev A q.In in 27 | elim Out with 28 | | cons x xs => some (x,struct In => nil | Out => xs) 29 | | nil => none 30 | 31 | 32 | def q : Queue2.t Nat => Queue2.enq Nat zero (Queue2.enq Nat one (Queue2.enq Nat two (Queue2.emp Nat))) 33 | 34 | def Bisimilar (Q1 Q2 : QUEUE) (A : Type) : Type^1 => sig 35 | | R : Q1.t A -> Q2.t A -> Type 36 | | emp : R (Q1.emp A) (Q2.emp A) 37 | | enq : (q1 : Q1.t A) (q2 : Q2.t A) -> R q1 q2 -> (x : A) -> R (Q1.enq A x q1) (Q2.enq A x q2) 38 | | deq : (q1 : Q1.t A) (q2 : Q2.t A) -> R q1 q2 -> 39 | Sum ((Q1.deq A q1 = none) * (Q2.deq A q2 = none)) ((x : A) (q1' : Q1.t A) (q2' : Q2.t A) * (Q1.deq A q1 = some (x,q1')) * (Q2.deq A q2 = some (x,q2'))) 40 | 41 | def Bisimilar-Queues (A : Type) : Bisimilar Queue1 Queue2 A => struct 42 | | R q1 q2 => q1 = ++ A q2.In (rev A q2.Out) 43 | | emp => refl 44 | | enq q1 q2 Rq1q2 x => match Rq1q2 with refl i => refl 45 | | deq => \elim 46 | | nil => \q2 => (elim q2.In with 47 | | nil => (elim q2.Out with 48 | | nil => \r => inl (refl,refl) 49 | | cons x (xs / ih) => \r => ? 50 | ) 51 | | cons x xs => ? 52 | ) 53 | | cons x xs => \q2 => ? -------------------------------------------------------------------------------- /library/sg.dtt: -------------------------------------------------------------------------------- 1 | 2 | data (A : Type) (B : A -> Type) Sg => 3 | | pair (x : A) (y : B x) 4 | 5 | def fst (A : Type) (B : A -> Type) : Sg A B -> A => \elim 6 | | pair x y => x 7 | 8 | def snd (A : Type) (B : A -> Type) : (p : Sg A B) -> B (fst A B p) => \elim 9 | | pair x y => y 10 | 11 | def Sg-Eta (A : Type) (B : A -> Type) : (p : Sg A B) -> Id (Sg A B) p (pair (fst A B p) (snd A B p)) => \elim 12 | | pair x y => refl 13 | -------------------------------------------------------------------------------- /library/sum.dtt: -------------------------------------------------------------------------------- 1 | import id 2 | 3 | data (A B : Type) Sum => 4 | | inl (x : A) 5 | | inr (y : B) 6 | 7 | def Sum-Ind (A B : Type) (P : Sum A B -> Type) (l : (x : A) -> P (inl x)) (r : (x : B) -> P (inr x)) : (x : Sum A B) -> P x => \elim 8 | | inl x => l x 9 | | inr y => r y 10 | 11 | def inl-inj (A B : Type) (x y : A) : Id (Sum A B) (inl x) (inl y) -> Id A x y => 12 | cong (Sum A B) A (\elim inl x => x | inr _ => x) (inl x) (inl y) 13 | 14 | def inr-inj (A B : Type) (x y : B) : Id (Sum A B) (inr x) (inr y) -> Id B x y => 15 | cong (Sum A B) B (\elim inr x => x | inl _ => x) (inr x) (inr y) -------------------------------------------------------------------------------- /library/test.dtt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmcqd/datatt/073e850096b522282e33ab4081744f961a43bb05/library/test.dtt -------------------------------------------------------------------------------- /library/tree.dtt: -------------------------------------------------------------------------------- 1 | data (A : Type) Tree => 2 | | empty 3 | | node (l : Tree) (x : A) (r : Tree) 4 | 5 | def Tree-Ind (A : Type) (P : Tree A -> Type) (e : P empty) (n : (x : A) (l r : Tree A) -> P l -> P r -> P (node l x r)) : (t : Tree A) -> P t => \elim 6 | | empty => e 7 | | node (l / ihl) x (r / ihr) => n x l r ihl ihr 8 | 9 | def Tree-rev (A : Type) : Tree A -> Tree A => \elim 10 | | empty => empty 11 | | node (l / ihl) x (r / ihr) => node ihr x ihl -------------------------------------------------------------------------------- /library/typeclass.dtt: -------------------------------------------------------------------------------- 1 | import maybe 2 | import fn 3 | import list 4 | 5 | 6 | def Functor (F : Type -> Type) : Type^1 => sig 7 | | map : (A B : Type) -> (A -> B) -> F A -> F B 8 | 9 | def Functor-Laws (F : Type -> Type) : Type^1 => sig extends Functor F 10 | | map-id : (A : Type) (x : F A) -> map A A (id A) x = x 11 | | map-comp : (A B C : Type) (f : A -> B) (g : B -> C) (x : F A) -> map B C g (map A B f x) = map A C (\x => g (f x)) x 12 | 13 | def Applicative (F : Type -> Type) : Type^1 => sig extends Functor F 14 | | pure : (A : Type) -> A -> F A 15 | | <*> : (A B : Type) -> F (A -> B) -> F A -> F B 16 | 17 | {- 18 | def Applicative-Laws (F : Type -> Type) : Type^1 => sig extends Functor-Laws F, Applicative F 19 | | pure-id : (A : Type) (x : F A) -> <*> A A (pure (A -> A) (id A)) x = x 20 | | hom : (A B : Type) (f : A -> B) (x : A) -> <*> A B (pure (A -> B) f) (pure A x) = pure B (f x) 21 | | swap : (A B : Type) (f : F (A -> B)) (x : A) -> <*> A B f (pure A x) = <*> (A -> B) B (pure ((A -> B) -> B) (\f => f x)) f 22 | | comp : (A B C : Type) -> <*> (\x => f (g x)) 23 | -} 24 | 25 | def Monad (F : Type -> Type) : Type^1 => sig extends Applicative F 26 | | join : (A : Type) -> F (F A) -> F A 27 | 28 | def bind (F : Type -> Type) (M : Monad F) (A B : Type) (m : F A) (f : A -> F B) : F B => 29 | M.join B (M.map A (F B) f m) 30 | 31 | def Functor-id : Functor (\A => A) => struct 32 | | map A B f => f 33 | 34 | def Applicative-id : Applicative (\A => A) => struct extends Functor-id 35 | | pure A x => x 36 | | <*> A B f x => f x 37 | 38 | def Monad-id : Monad (\A => A) => struct extends Applicative-id 39 | | join A x => x 40 | 41 | 42 | def Functor-Maybe : Functor Maybe => struct 43 | | map A B f => (\elim none => none | some x => some (f x)) 44 | 45 | def Applicative-Maybe : Applicative Maybe => struct extends Functor-Maybe 46 | | pure A x => some x 47 | | <*> A B f x => (elim f with 48 | | none => none 49 | | some f => elim x with 50 | | none => none 51 | | some x => some (f x) 52 | ) 53 | 54 | def Monad-Maybe : Monad Maybe => struct extends Applicative-Maybe 55 | | join A => \elim 56 | | none => none 57 | | some x => x 58 | 59 | def Functor-List : Functor List => struct 60 | | map A B f => \elim 61 | | nil => nil 62 | | cons x (xs / ih) => cons (f x) ih 63 | 64 | def Applicative-List : Applicative List => struct extends Functor-List 65 | | pure A x => cons x nil 66 | | <*> A B fs xs => elim fs with 67 | | nil => nil 68 | | cons f (fs / ih) => ++ B (map A B f xs) ih 69 | 70 | def Monad-List : Monad List => struct extends Applicative-List 71 | | join A => \elim 72 | | nil => nil 73 | | cons x (_ / ih) => ++ A x ih 74 | 75 | 76 | def NotNot (A : Type) : Type => Not (Not A) 77 | 78 | def Functor-NotNot : Functor NotNot => struct 79 | | map A B f ~~a ~b => ~~a (\ a => ~b (f a)) 80 | 81 | def Applicative-NotNot : Applicative NotNot => struct extends Functor-NotNot 82 | | pure A a ~a => ~a a 83 | | <*> A B ~~A->B ~~a ~b => ~~A->B (\ f => ~~a (\ a => ~b (f a))) 84 | 85 | 86 | def Monad-NotNot : Monad NotNot => struct extends Applicative-NotNot 87 | | join A ~~~~a ~a => ~~~~a (\ ~~a => ~~a ~a) 88 | -------------------------------------------------------------------------------- /library/unit.dtt: -------------------------------------------------------------------------------- 1 | def Unit : Type => sig 2 | 3 | def <> : Unit => struct 4 | 5 | def Unit-Ind (P : Unit -> Type) (p : P <>) (x : Unit) : P x => p 6 | 7 | def Unit-Eta (x : Unit) : Id Unit <> x => refl -------------------------------------------------------------------------------- /library/vec.dtt: -------------------------------------------------------------------------------- 1 | import nat 2 | import unit 3 | import fin 4 | 5 | def Vec (A : Type) : Nat -> Type => \elim 6 | | zero => Unit 7 | | suc (_ / ih) => A * ih 8 | 9 | def vnil (A : Type) : Vec A zero => <> 10 | def vcons (A : Type) (x : A) (n : Nat) (xs : Vec A n) : Vec A (suc n) => (x,xs) 11 | 12 | def vhd (A : Type) (n : Nat) (v : Vec A (suc n)) : A => v.1 13 | def vtl (A : Type) (n : Nat) (v : Vec A (suc n)) : Vec A n => v.2 14 | 15 | def Vec-Ind (A : Type) (P : (n : Nat) -> Vec A n -> Type) (b : P zero <>) 16 | (c : (m : Nat) (v : Vec A m) (x : A) -> P m v -> P (suc m) (x,v)) : (n : Nat) (v : Vec A n) -> P n v => \elim 17 | | zero => (\elim <> => b) 18 | | suc (n / ih) => \ v => c n v.2 v.1 (ih v.2) 19 | 20 | def vrec (A B : Type) (b : B) (c : A -> B -> B) : (n : Nat) -> Vec A n -> B => \elim 21 | | zero => \ _ => b 22 | | suc (n / ih) => \ v => c v.1 (ih v.2) 23 | 24 | 25 | def vzip (A B : Type) : (n : Nat) -> Vec A n -> Vec B n -> Vec (A * B) n => \elim 26 | | zero => \ _ _ => <> 27 | | suc (_ / ih) => \ v1 v2 => ((v1.1,v2.1),ih v1.2 v2.2) 28 | 29 | def !! (A : Type) : (n : Nat) -> Vec A n -> Fin n -> A => \elim 30 | | zero => \ _ => (\elim) 31 | | suc (n / ih) => \v => \elim 32 | | inl x => v.1 33 | | inr m => ih v.2 m 34 | -------------------------------------------------------------------------------- /library/void.dtt: -------------------------------------------------------------------------------- 1 | 2 | data Void 3 | 4 | def Void-Ind (P : Void -> Type) : (x : Void) -> P x => 5 | \elim 6 | 7 | def Void-Rec (A : Type) : Void -> A => \elim 8 | 9 | def Not (A : Type) : Type => A -> Void 10 | -------------------------------------------------------------------------------- /library/void2.dtt: -------------------------------------------------------------------------------- 1 | import void 2 | import iso 3 | 4 | data Void2 => 5 | | V (x : Void2) 6 | 7 | def Void2-Rec (A : Type) : Void2 -> A => \elim 8 | | V (_ / ih) => ih 9 | 10 | def iso/Void/Void2 : Iso Void Void2 => struct 11 | | f => (\elim) 12 | | g => (\elim V (_ / ih) => ih) 13 | | gf => (\elim) 14 | | fg => \y => Void2-Rec (y = f (g y)) y 15 | 16 | 17 | -------------------------------------------------------------------------------- /library/wrap.dtt: -------------------------------------------------------------------------------- 1 | import iso 2 | 3 | data (A : Type) Wrap => wrap (x : A) 4 | 5 | def iso/A/WrapA (A : Type) : Iso A (Wrap A) => 6 | ( \ x => wrap x 7 | , \elim wrap x => x 8 | , \ _ => refl 9 | , \elim wrap x => refl 10 | ) 11 | -------------------------------------------------------------------------------- /src/concrete_syntax.ml: -------------------------------------------------------------------------------- 1 | type 'a spine = 2 | | Nil 3 | | Snoc of 'a spine * 'a 4 | [@@deriving show { with_path = false }] 5 | 6 | let rec spine_to_list_ acc = function 7 | | Nil -> acc 8 | | Snoc (xs,x) -> spine_to_list_ (x::acc) xs 9 | 10 | let spine_to_list s = spine_to_list_ [] s 11 | 12 | let rec list_to_spine_ acc = function 13 | | [] -> acc 14 | | x::xs -> list_to_spine_ (Snoc (acc,x)) xs 15 | 16 | let list_to_spine xs = list_to_spine_ Nil xs 17 | 18 | type 'a bnd = (string * 'a) 19 | [@@deriving show] 20 | 21 | type t_ = 22 | | Hole of string 23 | | Var of string 24 | | Lift of {name : string ; lvl : int} 25 | | U of Level.t 26 | | Pi of t bnd list * t 27 | | Lam of string list * t 28 | | Spine of t * t spine 29 | | Sg of t bnd list * t 30 | | Tuple of t list 31 | | Fst of t 32 | | Snd of t 33 | | Elim of {mot : t bnd option ; scrut : t ; arms : ([`Rec of string * string | `Arg of string] list * t) bnd list} 34 | | ElimFun of ([`Rec of string * string | `Arg of string] list * t) bnd list 35 | | RecordTy of {extends : t list ; fields : (string * t) list} 36 | | Record of {extends : t list ; fields : (string * t) list} 37 | | Proj of string * t 38 | | Eq of t * t 39 | | Id of t * t * t 40 | | Refl 41 | | J of {mot : (string * string * string * t) option ; scrut : t ; body : string * t} 42 | | Ascribe of {tm : t ; tp : t} 43 | | Let of t bnd * t 44 | | Absurd 45 | [@@deriving show {with_path = false} ] 46 | 47 | and t = t_ Mark.t 48 | 49 | let show (cs,_) = show_t_ cs 50 | 51 | type cmd = 52 | | Eval of t 53 | | Def of string * t 54 | | Axiom of string * t 55 | | Data of {name : string ; cons : (t bnd list) bnd list ; params : t bnd list ; lvl : Level.t} 56 | | Import of string -------------------------------------------------------------------------------- /src/ctx.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Dom = Domain 3 | module Syn = Syntax 4 | 5 | 6 | type entry = 7 | | Def of {tm : Dom.t ; tp : Dom.t} 8 | | Let of {tm : Dom.t ; tp : Dom.t} 9 | | Var of Dom.t 10 | | Data of Dom.desc 11 | 12 | type t = entry String.Map.t 13 | 14 | let empty = String.Map.empty 15 | 16 | 17 | let to_env : t -> Dom.Env.t = String.Map.mapi ~f:(fun ~key ~data -> 18 | match data with 19 | | Var tp -> Dom.Tm (Dom.Neutral {ne = Var key ; tp}) 20 | | Def {tm ; tp} -> Def {tm ; tp} 21 | | Let {tm ; _} -> Tm tm 22 | | Data desc -> Desc desc) 23 | 24 | let to_names = String.Map.key_set 25 | 26 | let to_string c = 27 | let used = to_names c in 28 | String.Map.fold c ~init:"" ~f:(fun ~key ~data s -> 29 | match data with 30 | | Var tp | Let {tp ; _}-> sprintf "%s\n %s : %s" s key (Syntax.show (Nbe.read_back used tp (U Omega))) 31 | | _ -> s 32 | ) 33 | 34 | 35 | let find_tp ctx x = 36 | match String.Map.find ctx x with 37 | | None -> None 38 | | Some ((Var tp) | Def {tp ; _} | Let {tp ; _}) -> Some tp 39 | | Some (Data d) -> Some (Nbe.eval (to_env ctx) d.tp) 40 | 41 | let find_def_tp ctx x = 42 | match String.Map.find ctx x with 43 | | Some (Def {tp ; _}) -> Some tp 44 | | Some (Data d) -> Some (Nbe.eval (to_env ctx) d.tp) 45 | | _ -> None 46 | 47 | let find_data ctx d = 48 | match String.Map.find ctx d with 49 | | Some (Data d) -> Some d 50 | | _ -> None 51 | 52 | let find_data_exn ctx d = 53 | match String.Map.find ctx d with 54 | | Some (Data d) -> d 55 | | _ -> failwith "find_data_exn" 56 | 57 | let is_data ctx d = 58 | match String.Map.find ctx d with 59 | | Some (Data _) -> true 60 | | _ -> false 61 | 62 | 63 | let add ctx ~var ~tp = String.Map.set ctx ~key:var ~data:(Var tp) 64 | let add_syn ctx ~var ~tp = String.Map.set ctx ~key:var ~data:(Var (Nbe.eval (to_env ctx) tp)) 65 | let add_def ctx ~var ~def ~tp = String.Map.set ctx ~key:var ~data:(Def {tm = def ; tp}) 66 | let add_let ctx ~var ~def ~tp = String.Map.set ctx ~key:var ~data:(Let {tm = def ; tp}) 67 | 68 | let add_data ctx (d : Domain.desc) = String.Map.set ctx ~key:d.name ~data:(Data d) -------------------------------------------------------------------------------- /src/ctx.mli: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | type t 5 | 6 | 7 | val empty : t 8 | val to_env : t -> Domain.env 9 | val to_names : t -> String.Set.t 10 | val to_string : t -> string 11 | val find_tp : t -> string -> Domain.t option 12 | val find_def_tp : t -> string -> Domain.t option 13 | val find_data : t -> string -> Domain.desc option 14 | val find_data_exn : t -> string -> Domain.desc 15 | val is_data : t -> string -> bool 16 | val add : t -> var:string -> tp:Domain.t -> t 17 | val add_syn : t -> var:string -> tp:Syntax.t -> t 18 | val add_def : t -> var:string -> def:Domain.t -> tp:Domain.t -> t 19 | val add_let : t -> var:string -> def:Domain.t -> tp:Domain.t -> t 20 | val add_data : t -> Domain.desc -> t -------------------------------------------------------------------------------- /src/domain.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Map = 4 | struct 5 | include String.Map 6 | let pp _ _ _ = () 7 | let show _ = "env" 8 | end 9 | 10 | type 'a bnd = string * 'a 11 | [@@deriving show] 12 | 13 | (* Disabling warning 30 so I can have records with duplicate field names *) 14 | [@@@ocaml.warning "-30"] 15 | type t = 16 | | U of Level.t 17 | | Lam of clos 18 | | Pi of t * clos 19 | | Sg of t * clos 20 | | Pair of t * t 21 | | Data of {desc : desc ; params : t list} 22 | | Intro of {name : string ; args : t list} 23 | | RecordTy of Syntax.t bnd list * env 24 | | Record of t bnd list 25 | | Id of t * t * t 26 | | Refl of t 27 | | Neutral of {tp : t ; ne : ne} 28 | [@@deriving show {with_path = false}] 29 | 30 | and dom = t 31 | 32 | and ne = 33 | | Var of string 34 | | Ap of ne * nf 35 | | Fst of ne 36 | | Snd of ne 37 | | Proj of string * ne 38 | | Elim of {mot : clos ; arms : arm_clos bnd list ; scrut : ne ; desc : desc ; params : t list} 39 | | J of {mot : clos3 ; body : clos ; scrut : ne ; tp : t} 40 | | Hole of {name : string ; tp : t} 41 | [@@deriving show {with_path = false}] 42 | 43 | and nf = {tm : t ; tp : t} 44 | [@@deriving show {with_path = false}] 45 | 46 | and clos = {name : string ; tm : Syntax.t ; env : env} 47 | [@@deriving show {with_path = false}] 48 | 49 | and clos3 = {names : string * string * string ; tm : Syntax.t ; env : env } 50 | [@@deriving show {with_path = false}] 51 | 52 | and arm_clos = {names : [`Rec of string * string | `Arg of string] list ; arm : Syntax.t ; env : env} 53 | [@@deriving show {with_path = false}] 54 | 55 | and env_entry = 56 | | Desc of desc 57 | | Def of {tm : t ; tp : t} 58 | | Tm of t 59 | 60 | and env = env_entry Map.t 61 | 62 | and spec = 63 | | Rec 64 | | Tp of Syntax.t 65 | 66 | 67 | and desc = {name : string ; cons : spec bnd list bnd list ; params : Syntax.t bnd list ; env : env ; lvl : Level.t ; tm : Syntax.t ; tp : Syntax.t} 68 | 69 | [@@@ocaml.warning "+30"] 70 | 71 | 72 | module Env = 73 | struct 74 | type t = env 75 | 76 | let set env ~key ~data = String.Map.set env ~key ~data:(Tm data) 77 | 78 | 79 | let find_exn (env : env) (s : string) : dom = 80 | match String.Map.find_exn env s with 81 | | Tm tm 82 | | Def {tm;_} -> tm 83 | | Desc _ -> failwith "find_exn" 84 | 85 | let find_def_exn (env : env) (s : string) : nf = 86 | match String.Map.find_exn env s with 87 | | Def {tm ; tp} -> {tm ; tp} 88 | | _ -> failwith "find_def_exn" 89 | 90 | let find_data_exn (env : env) (s : string) : desc = 91 | match String.Map.find_exn env s with 92 | | Tm _ | Def _ -> failwith "find_data_exn - env" 93 | | Desc desc -> desc 94 | 95 | let key_set = String.Map.key_set 96 | end 97 | (* 98 | 99 | let rec lift i = function 100 | | Lam clos -> Lam (lift_clos i clos) 101 | | Pi (d,clos) -> Pi (lift i d, lift_clos i clos) 102 | | Sg (d,clos) -> Sg (lift i d, lift_clos i clos) 103 | | Pair (x,y) -> Pair (lift i x,lift i y) 104 | | U Omega -> U Omega 105 | | U (Const j) -> U (Const (j + i)) 106 | | Id (a,x,y) -> Id (lift i a,lift i x, lift i y) 107 | | Refl x -> Refl (lift i x) 108 | | Data {desc ; params} -> Data {desc ; params = List.map ~f:(lift i) params} 109 | | Intro {name ; args} -> Intro {name ; args = List.map ~f:(lift i) args} 110 | | RecordTy (fs,env) -> RecordTy (List.map ~f:(fun (f,tp) -> (f,Syntax.lift i tp)) fs,env) 111 | | Record fs -> Record (List.map ~f:(fun (f,tm) -> (f,lift i tm)) fs) 112 | | Neutral {tp ; ne} -> Neutral {tp = lift i tp ; ne = lift_ne i ne} 113 | 114 | 115 | (* Wrong because the closure might contain toplevel vars that should be expanded *) 116 | and lift_clos i clos = 117 | {clos with tm = Syntax.lift i clos.tm} 118 | 119 | and lift_clos3 i (clos : clos3) = 120 | {clos with tm = Syntax.lift i clos.tm} 121 | 122 | and lift_arm_clos i clos = 123 | {clos with arm = Syntax.lift i clos.arm} 124 | 125 | 126 | and lift_ne i = function 127 | | Var x -> Var x 128 | | Ap (ne, {tp ; tm}) -> Ap (lift_ne i ne, {tp = lift i tp; tm = lift i tm}) 129 | | J {mot ; body ; scrut ; tp} -> J {mot = lift_clos3 i mot ; body = lift_clos i body ; scrut = lift_ne i scrut ; tp = lift i tp} 130 | | Elim {mot ; arms ; scrut ; desc ; params} -> 131 | Elim { mot = lift_clos i mot ; arms = List.map ~f:(fun (con,clos) -> (con,lift_arm_clos i clos)) arms ; scrut = lift_ne i scrut ; desc ; params = List.map ~f:(lift i) params} 132 | | Fst p -> Fst (lift_ne i p) 133 | | Snd p -> Snd (lift_ne i p) 134 | | Proj (f,ne) -> Proj (f,lift_ne i ne) 135 | | Hole {name ; tp} -> Hole {name ; tp = lift i tp} *) -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name repl) 3 | (libraries core) 4 | (preprocess (pps ppx_deriving.std ppx_jane))) 5 | 6 | (ocamllex 7 | (modules lexer)) 8 | 9 | (menhir 10 | (modules parser)) -------------------------------------------------------------------------------- /src/elab.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module CSyn = Concrete_syntax 4 | open CSyn 5 | module Syn = Syntax 6 | module Dom = Domain 7 | 8 | exception TypeError of string 9 | exception Hole of {goal : string ; ctx : string ; pos : string} 10 | 11 | let error s = raise (TypeError s) 12 | 13 | let r = ref 0 14 | let fresh () = r := !r + 1 ; "\\"^Int.to_string !r 15 | 16 | let normalize ~tm ~tp ~ctx = 17 | Nbe.read_back (Ctx.to_names ctx) (Nbe.eval (Ctx.to_env ctx) tm) tp 18 | 19 | 20 | let rec remove_dup_fields_ seen = function 21 | | [] -> [] 22 | | (f,e)::fs -> if String.Set.mem seen f then remove_dup_fields_ seen fs else (f,e)::remove_dup_fields_ (String.Set.add seen f) fs 23 | 24 | let remove_dup_fields = remove_dup_fields_ String.Set.empty 25 | 26 | let sort_cons = List.sort ~compare: (fun (c1,_) (c2,_) -> String.compare c1 c2) 27 | 28 | let rec check (ctx : Ctx.t) (cs : CSyn.t) (tp : Dom.t) : Syn.t = 29 | (* printf "CHECK %s AT %s\n" (CSyn.show cs) (Syn.show @@ Nbe.read_back (Ctx.to_names ctx) tp (U Omega)); *) 30 | match Mark.data cs,tp with 31 | | Hole name,tp -> 32 | let goal = Nbe.read_back (Ctx.to_names ctx) tp (U Omega) in 33 | printf "Hole %s at %s:%s\n\n⊢ %s\n\n" name (Mark.show cs) (Ctx.to_string ctx) (Syn.show goal); 34 | Hole {name ; tp = goal} 35 | 36 | | U Omega,U Omega -> U Omega (* VERY SUS but technically ok because user can't create terms of type U Omega *) 37 | | U i,U j when Level.(<) i j -> U i 38 | | U i, U j -> error (sprintf "%s - %s too large to be contained in %s" (Mark.show cs) (Syn.show (U i)) (Syn.show (U j))) 39 | | Pi ([],r), U i -> check ctx r (U i) 40 | | Pi ((x,d)::tele,r), U i -> 41 | let d = check ctx d (U i) in 42 | let pi = check (Ctx.add_syn ctx ~var:x ~tp:d) (Mark.naked @@ Pi (tele,r)) (U i) in 43 | Pi ((x,d),pi) 44 | | Sg ([],r), U i -> check ctx r (U i) 45 | | Sg ((x,d)::tele,r), U i -> 46 | let d = check ctx d (U i) in 47 | let sg = check (Ctx.add_syn ctx ~var:x ~tp:d) (Mark.naked @@ Sg (tele,r)) (U i) in 48 | Sg ((x,d),sg) 49 | | RecordTy {extends ; fields} ,U i -> 50 | begin 51 | match extends with 52 | | [] -> RecordTy (check_record_ty ctx i fields) 53 | | exts -> 54 | let exts = List.concat_map exts ~f:(fun ext -> 55 | let ext = check ctx ext (U i) in 56 | match normalize ~ctx ~tm:ext ~tp:(U i) with 57 | | RecordTy ext_fs -> List.map ext_fs ~f:(fun (f,e) -> (f,Syntax.to_concrete e)) 58 | | _ -> error (sprintf "%s is not a record type, it cannot be extended" (Syn.show ext))) 59 | in let exts = remove_dup_fields exts in 60 | RecordTy (check_record_ty ctx i (exts @ fields)) 61 | end 62 | | Record {extends ; fields}, RecordTy (ftps,env) -> 63 | begin 64 | match extends with 65 | | [] -> Record (check_record (Mark.show cs) ctx fields ftps env) 66 | | exts -> 67 | let exts = List.concat_map exts ~f:(fun ext -> 68 | let ext_tp,ext = synth ctx ext in 69 | match normalize ~ctx ~tm:ext ~tp:ext_tp with 70 | | Record ext_fs -> List.map ~f:(fun (f,e) -> (f,Syntax.to_concrete e)) ext_fs 71 | | _ -> error (sprintf "%s is not a records, it cannot be extended" (Syn.show ext))) 72 | in let exts = remove_dup_fields exts in 73 | Record (check_record (Mark.show cs) ctx (exts @ fields) ftps env) 74 | end 75 | | Let ((x,e1),e2),tp -> 76 | let e1_tp,e1' = synth ctx e1 in 77 | let e2' = check (Ctx.add_let ctx ~var:x ~def:(Nbe.eval (Ctx.to_env ctx) e1') ~tp:e1_tp) e2 tp in 78 | Let ((x,e1'),e2') 79 | | Lam ([],e),tp -> check ctx e tp 80 | | Lam (x::xs,e),Pi (d,clos) -> 81 | Lam (x,check (Ctx.add ctx ~var:x ~tp:d) (Mark.naked @@ Lam (xs,e)) (Nbe.do_clos clos (Nbe.var x d))) 82 | | Tuple [x],tp -> check ctx x tp 83 | | Tuple (x::xs),Sg (f,clos) -> 84 | let x' = check ctx x f in 85 | Pair (x',check ctx (Mark.naked @@ Tuple xs) (Nbe.do_clos clos (Nbe.eval (Ctx.to_env ctx) x'))) 86 | | Var con,Data {desc ; params} when List.Assoc.mem ~equal:String.equal desc.cons con -> 87 | let dtele = List.Assoc.find_exn ~equal:String.equal desc.cons con in 88 | Intro {name = con ; args = check_intro_args ctx [] dtele (Nbe.apply_params desc desc.params params,params)} 89 | 90 | | Spine (f,args),Data {desc ; params} -> 91 | begin 92 | match Mark.data f with 93 | | Var con when List.Assoc.mem ~equal:String.equal desc.cons con -> 94 | begin 95 | let dtele = List.Assoc.find_exn ~equal:String.equal desc.cons con in 96 | try Intro {name = con ; args = check_intro_args ctx (CSyn.spine_to_list args) dtele (Nbe.apply_params desc desc.params params,params)} with 97 | | TypeError s -> error (sprintf "%s - %s" (Mark.show cs) s) 98 | end 99 | | _ -> mode_switch ctx cs tp 100 | end 101 | | Eq (x,y), U i -> 102 | begin 103 | try 104 | let a,x = synth ctx x in 105 | let y = check ctx y a in 106 | Id (Nbe.read_back (Ctx.to_names ctx) a (U i),x,y) 107 | with TypeError _ -> 108 | let a,y = synth ctx y in 109 | let x = check ctx x a in 110 | Id (Nbe.read_back (Ctx.to_names ctx) a (U i),x,y) 111 | end 112 | 113 | | Id (a,x,y), U i -> 114 | let a = check ctx a (U i) in 115 | let a' = Nbe.eval (Ctx.to_env ctx) a in 116 | Id (a,check ctx x a',check ctx y a') 117 | | Refl, Id (a,x,y) -> 118 | begin 119 | try Refl (Nbe.equate (Ctx.to_names ctx) x y a) with 120 | | Nbe.EquateError _ -> 121 | let used = Ctx.to_names ctx in 122 | error (sprintf "%s - %s !<= %s" (Mark.show cs) (Syn.show @@ Nbe.read_back used x a) (Syn.show @@ Nbe.read_back used y a)) 123 | end 124 | | ElimFun arms, Pi (Data {desc;params},clos) -> 125 | let arms = sort_cons arms in 126 | if not (List.equal String.equal (List.map ~f:fst desc.cons) (List.map ~f:fst arms)) then error (sprintf "%s - Elim arms don't match constructors" (Mark.show cs))else 127 | let x = match clos.name with "_" -> fresh () | x -> x in 128 | Lam (x,Elim { mot = (x,Nbe.read_back (Ctx.to_names ctx) (Nbe.do_clos clos (Nbe.var x (Data {desc;params}))) (U Omega)) 129 | ; scrut = Var x 130 | ; arms = List.map2_exn arms desc.cons ~f:(fun (con,(args,arm)) (_,dtele) -> 131 | let dom_args,ctx = collect_elim_args (Mark.show cs) clos args dtele (Nbe.apply_params desc desc.params params,params) ctx in 132 | (con,(args,check ctx arm (Nbe.do_clos clos (Intro {name = con ; args = dom_args}))))) 133 | }) 134 | | Elim {mot = None ; scrut ; arms}, tp -> 135 | let arms = sort_cons arms in 136 | begin 137 | match synth ctx scrut with 138 | | Data {desc;params},scrut -> 139 | if not (List.equal String.equal (List.map ~f:fst desc.cons) (List.map ~f:fst arms)) then error (sprintf "%s - Elim arms don't match constructors" (Mark.show cs)) else 140 | let used = Ctx.to_names ctx in 141 | let tp_syn = Nbe.read_back used tp (U Omega) in 142 | let x = fresh () in 143 | let mot_body = Syn.subst (Var x) scrut tp_syn in 144 | (* print_endline (sprintf "GUSSED MOT: %s => %s" x (Syn.show mot_body)); *) 145 | let ctx' = ctx |> Ctx.add ~var:x ~tp:(Data {desc;params}) in 146 | (try const () @@ check ctx' (Syn.to_concrete mot_body) (U Omega) with TypeError s -> error (sprintf "%s - In guessed motive: %s" (Mark.show cs) s)); 147 | let mot_clos = Dom.{name = x ; tm = mot_body ; env = Ctx.to_env ctx} in 148 | Elim { mot = (x,mot_body) 149 | ; scrut 150 | ; arms = List.map2_exn arms desc.cons ~f:(fun (con,(args,arm)) (_,dtele) -> 151 | let dom_args,ctx = collect_elim_args (Mark.show cs) mot_clos args dtele (Nbe.apply_params desc desc.params params,params) ctx in 152 | let arm_tp = Nbe.do_clos mot_clos (Intro {name = con ; args = dom_args}) in 153 | (* print_endline ("ARM_TYPE: "^Dom.show arm_tp); 154 | print_endline ("ARM: "^CSyn.show arm); *) 155 | (con,(args,check ctx arm arm_tp)))} 156 | | _,scrut' -> error (sprintf "%s - %s is not a datatype, it cannot be eliminated" (Mark.show scrut) (Syn.show scrut')) 157 | end 158 | | J {mot = None ; body = (z,e) ; scrut}, tp -> 159 | begin 160 | match synth ctx scrut with 161 | | Id (a,e1,e2),scrut -> 162 | let used = Ctx.to_names ctx in 163 | let tp_syn = Nbe.read_back used tp (U Omega) in 164 | let p,y,x = fresh (), fresh (), fresh () in 165 | let e1',e2' = Nbe.read_back used e1 a,Nbe.read_back used e2 a in 166 | (* mot_body needs to be typechecked in case we guessed a type-incorrect motive *) 167 | let mot_body = tp_syn 168 | |> Syn.subst (Var x) e1' 169 | (* e2' might contain e1', so we have to perform the same substitution inside of e2'. This seems sus *) 170 | |> Syn.subst (Var y) (Syn.subst (Var x) e1' e2') 171 | |> Syn.subst (Var p) scrut in 172 | (* print_endline (sprintf "GUSSED MOT: %s" (Syn.show mot_body)); *) 173 | let ctx' = ctx |> Ctx.add ~var:x ~tp:a |> Ctx.add ~var:y ~tp:a |> Ctx.add ~var:p ~tp:(Id (a,Nbe.var x a,Nbe.var y a)) in 174 | (try const () @@ check ctx' (Syn.to_concrete mot_body) (U Omega) with TypeError s -> error (sprintf "%s - In guessed motive %s: %s" (Mark.show cs) (Syn.show mot_body) s)); 175 | let body_tp = Nbe.do_clos3 Dom.{names = (x,y,p) ; tm = mot_body ; env = Ctx.to_env ctx} (Nbe.var z a) (Nbe.var z a) (Refl (Nbe.var z a)) in 176 | let body = (z,check (Ctx.add ctx ~var:z ~tp:a) e body_tp ) in 177 | J {mot = (x,y,p,mot_body) ; body ; scrut} 178 | 179 | | _,scrut -> error (sprintf "%s - %s is not an equality proof, it cannot be matched on" (Mark.show cs) (Syn.show scrut)) 180 | end 181 | | Absurd, Pi (Id (Data _,Intro i1, Intro i2) as id,r) -> 182 | let used = Ctx.to_names ctx in 183 | if String.equal i1.name i2.name then error (sprintf "%s - fn () can only derive absurdity from non-equal outermost constructors, %s is not an absurd equality" (Mark.show cs) (Syn.show (Nbe.read_back used id (U Omega)))) 184 | else Lam (r.name,Var r.name) 185 | | _ -> mode_switch ctx cs tp 186 | 187 | and check_intro_args ctx args dtele (desc,params) = 188 | match args,dtele with 189 | | [],[] -> [] 190 | | arg::args,(x,tp)::dtele -> 191 | let arg = check ctx arg (Nbe.resolve_arg_tp (desc,params) tp) in 192 | arg::check_intro_args ctx args dtele ({desc with env = Dom.Env.set desc.env ~key:x ~data:(Nbe.eval (Ctx.to_env ctx) arg)},params) 193 | | _ -> error "Incorrect number of args provided to constructor" 194 | 195 | and check_record_ty ctx i = function 196 | | [] -> [] 197 | | (f,tp)::fs -> 198 | let tp = check ctx tp (U i) in 199 | (f,tp)::check_record_ty (Ctx.add ctx ~var:f ~tp:(Nbe.eval (Ctx.to_env ctx) tp)) i fs 200 | 201 | and check_record pos ctx r rtp env = 202 | match r,rtp with 203 | | [],[] -> [] 204 | | (f,tm)::r,(f',tp)::rtp -> if not (String.equal f f') then error (sprintf "%s - Expected field %s but found field %s" pos f' f) else 205 | let tp = Nbe.eval env tp in 206 | let tm = check ctx tm tp in 207 | let tm' = Nbe.eval (Ctx.to_env ctx) tm in 208 | (f,tm)::check_record pos (Ctx.add_let ctx ~var:f ~def:tm' ~tp) r rtp (Dom.Env.set env ~key:f ~data:tm') 209 | | [],(f,tp)::_ -> error (sprintf "%s - Expected field %s : %s" pos f (Syn.show tp)) 210 | | (f,_)::_,[] -> error (sprintf "%s - Unexpected field %s" pos f) 211 | 212 | and mode_switch ctx cs tp = 213 | let used = Ctx.to_names ctx in 214 | let tp',s = synth ctx cs in 215 | (try Nbe.convertible used tp' tp (U Omega) with 216 | | Nbe.EquateError _ -> error (sprintf "%s - %s !<= %s" (Mark.show cs) (Syn.show @@ Nbe.read_back used tp' (U Omega)) (Syn.show @@ Nbe.read_back used tp (U Omega)))); 217 | s 218 | 219 | 220 | and synth (ctx : Ctx.t) (cs : CSyn.t) : Dom.t * Syn.t = 221 | (* printf "SYNTH %s\n" (CSyn.show cs); *) 222 | match Mark.data cs with 223 | | Var x -> 224 | begin 225 | match Ctx.find_tp ctx x with 226 | | Some tp -> tp, Var x 227 | | None -> error (sprintf "%s - Unbound var `%s`" (Mark.show cs) x) 228 | end 229 | | Lift {name ; lvl} -> 230 | begin 231 | match Ctx.find_def_tp ctx name with 232 | | None -> error (sprintf "%s - Cannot lift non-toplevel definition `%s`" (Mark.show cs) name) 233 | | Some tp -> Nbe.eval (Ctx.to_env ctx) (Syn.lift lvl (Nbe.read_back (Ctx.to_names ctx) tp (U Omega))), Lift {name ; lvl} 234 | end 235 | | Spine (e,Nil) -> synth ctx e 236 | | Spine (e,Snoc (spine,arg)) -> 237 | begin 238 | match synth ctx (Mark.naked @@ Spine (e,spine)) with 239 | | Pi (d,clos),spine -> 240 | let arg = check ctx arg d in 241 | Nbe.do_clos clos (Nbe.eval (Ctx.to_env ctx) arg), Ap (spine,arg) 242 | | _,spine-> error (sprintf "%s - %s is not a function, it cannot be applied" (Mark.show cs) (Syn.show spine)) 243 | end 244 | | Ascribe {tm ; tp} -> 245 | let tp = Nbe.eval (Ctx.to_env ctx) (check ctx tp (U Omega)) in 246 | tp, check ctx tm tp 247 | | Let ((x,e1),e2) -> 248 | let e1_tp,e1' = synth ctx e1 in 249 | let e2_tp,e2' = synth (Ctx.add_let ctx ~var:x ~def:(Nbe.eval (Ctx.to_env ctx) e1') ~tp:e1_tp) e2 in 250 | e2_tp,Let ((x,e1'),e2') 251 | | Fst p -> 252 | begin 253 | match synth ctx p with 254 | | Sg (f,_),p -> f,Fst p 255 | | _,p -> error (sprintf "%s - %s is not a pair, it cannot be projected from" (Mark.show cs) (Syn.show p)) 256 | end 257 | | Snd p -> 258 | begin 259 | match synth ctx p with 260 | | Sg (_,clos),p -> Nbe.do_clos clos (Nbe.do_fst (Nbe.eval (Ctx.to_env ctx) p)),Snd p 261 | | _,p -> error (sprintf "%s - %s is not a pair, it cannot be projected from" (Mark.show cs) (Syn.show p)) 262 | end 263 | | Proj (f,e) -> 264 | begin 265 | match synth ctx e with 266 | | RecordTy (fs,env) as rtp,r -> 267 | if not (List.Assoc.mem ~equal:String.equal fs f) 268 | then error (sprintf "%s - %s is not a field of %s" (Mark.show cs) f (Syn.show (Nbe.read_back (Ctx.to_names ctx) rtp (U Omega)))) 269 | else synth_proj_tp (Nbe.eval (Ctx.to_env ctx) r) f fs env, Proj (f,r) 270 | | _,r -> error (sprintf "%s - %s is not a record, it cannot be projected from" (Mark.show cs) (Syn.show r)) 271 | end 272 | | Elim {mot = Some (x,mot) ; scrut ; arms} -> 273 | let arms = sort_cons arms in 274 | begin 275 | match synth ctx scrut with 276 | | Data {desc;params},scrut -> 277 | if not (List.equal String.equal (List.map ~f:fst desc.cons) (List.map ~f:fst arms)) then error (sprintf "%s - Elim arms don't match constructors" (Mark.show cs)) else 278 | let env = Ctx.to_env ctx in 279 | let mot_body = check (Ctx.add ctx ~var:x ~tp:(Data {desc;params})) mot (U Omega) in 280 | let mot_clos = Dom.{name = x ; tm = mot_body ; env} in 281 | Nbe.do_clos mot_clos (Nbe.eval env scrut), 282 | Elim { mot = (x,mot_body) 283 | ; scrut 284 | ; arms = List.map2_exn arms desc.cons ~f:(fun (con,(args,arm)) (_,dtele) -> 285 | let dom_args,ctx = collect_elim_args (Mark.show cs) mot_clos args dtele (Nbe.apply_params desc desc.params params,params) ctx in 286 | (con,(args,check ctx arm (Nbe.do_clos mot_clos (Intro {name = con ; args = dom_args})))))} 287 | | _,scrut' -> error (sprintf "%s - %s is not a datatype, it cannot be eliminated" (Mark.show scrut) (Syn.show scrut')) 288 | end 289 | | J {mot = Some (x,y,p,m) ; body = (z,e) ; scrut} -> 290 | begin 291 | match synth ctx scrut with 292 | | Id (a,e1,e2),scrut -> 293 | let env = Ctx.to_env ctx in 294 | let mot_body = check (ctx |> Ctx.add ~var:x ~tp:a |> Ctx.add ~var:y ~tp:a |> Ctx.add ~var:p ~tp:(Id (a,Nbe.var x a,Nbe.var y a))) m (U Omega) in 295 | let body_tp = Nbe.do_clos3 Dom.{names = (x,y,p) ; tm = mot_body ; env} (Nbe.var z a) (Nbe.var z a) (Refl (Nbe.var z a)) in 296 | let body = (z,check (Ctx.add ctx ~var:z ~tp:a) e body_tp) in 297 | Nbe.do_clos3 Dom.{names = (x,y,p) ; tm = mot_body ; env} e1 e2 (Nbe.eval env scrut), J {mot = (x,y,p,mot_body) ; body ; scrut} 298 | | _,scrut' -> error (sprintf "%s - %s is not a datatype, it cannot be eliminated" (Mark.show scrut) (Syn.show scrut')) 299 | end 300 | | _ -> error (sprintf "%s - Failed to synth/elaborate" (Mark.show cs)) 301 | 302 | 303 | and synth_proj_tp r f fs env = 304 | match fs with 305 | | [] -> error "whoops" 306 | | (f',tp)::fs -> if String.equal f f' then Nbe.eval env tp else 307 | synth_proj_tp r f fs (Dom.Env.set env ~key:f' ~data:(Nbe.do_proj f' r)) 308 | 309 | and collect_elim_args pos mot args dtele (desc,params) ctx = 310 | match args,dtele with 311 | | [],[] -> [],ctx 312 | | arg::args,(y,s)::dtele -> 313 | begin 314 | match arg with 315 | | `Arg x -> 316 | let tp = Nbe.resolve_arg_tp (desc,params) s in 317 | let arg,ctx = Nbe.var x tp,Ctx.add ctx ~var:x ~tp in 318 | let args,ctx = collect_elim_args pos mot args dtele ({desc with env = Dom.Env.set desc.env ~key:y ~data:arg},params) ctx in 319 | arg::args,ctx 320 | | `Rec (x,ih) -> 321 | match s with 322 | | Rec -> 323 | let tp = Nbe.resolve_arg_tp (desc,params) s in 324 | let arg = Nbe.var x tp in 325 | let ctx = ctx |> Ctx.add ~var:x ~tp |> Ctx.add ~var:ih ~tp:(Nbe.do_clos mot arg) in 326 | let args,ctx = collect_elim_args pos mot args dtele ({desc with env = Dom.Env.set desc.env ~key:y ~data:arg},params) ctx in 327 | arg::args,ctx 328 | | _ -> error (sprintf "%s - %s does not have type %s, it cannot be recursively eliminated" pos x desc.name) 329 | end 330 | | _ -> error (sprintf "%s - Elim arm has incorrect number of args" pos) 331 | 332 | 333 | 334 | let rec params_to_pi lvl = function 335 | | [] -> Syn.U lvl 336 | | (x,t)::ps -> Syn.Pi ((x,t),params_to_pi lvl ps) 337 | 338 | let params_to_dpi lvl env = function 339 | | [] -> Dom.U lvl 340 | | (x,t)::ps -> Dom.Pi (Nbe.eval env t,{name = x ; tm = params_to_pi lvl ps ; env}) 341 | 342 | let rec params_to_lam name acc = function 343 | | [] -> Syntax.Data {name ; params = List.rev acc} 344 | | (x,_)::ps -> Syntax.Lam (x,params_to_lam name (Var x::acc) ps ) 345 | 346 | let params_to_dlam env (desc : Dom.desc) = function 347 | | [] -> Dom.Data {desc ; params = []} 348 | | (x,_)::ps -> Lam {name = x ; env = env ; tm = params_to_lam desc.name [Var x] ps} 349 | 350 | 351 | let rec elab_data ctx dname (cons : CSyn.t bnd list bnd list) (params : CSyn.t bnd list) lvl : Dom.desc = 352 | let ps,pctx = elab_params ctx params in 353 | { name = dname 354 | ; env = Ctx.to_env ctx 355 | ; params = ps 356 | ; cons = sort_cons @@ 357 | List.map ~f:(fun (con,args) -> con,elab_con (Ctx.add pctx ~var:dname ~tp:(U (Const 0))) lvl dname args) cons 358 | ; lvl 359 | ; tm = params_to_lam dname [] ps 360 | ; tp = params_to_pi lvl ps 361 | } 362 | 363 | 364 | and elab_params ctx = function 365 | | [] -> [],ctx 366 | | (x,tp)::ps -> 367 | let tp = check ctx tp (U Omega) in 368 | let ps,ctx = elab_params (Ctx.add_syn ctx ~var:x ~tp) ps in 369 | (x,tp)::ps,ctx 370 | 371 | and resolve_spec ctx lvl dname arg = 372 | match Mark.data arg with 373 | | CSyn.Var x when String.equal x dname -> Dom.Rec 374 | | _ -> Tp (check ctx arg (U lvl)) 375 | 376 | and elab_con ctx lvl dname args = 377 | match args with 378 | | [] -> [] 379 | | (x,arg)::args -> 380 | let arg = resolve_spec ctx lvl dname arg in 381 | let tp = match arg with Tp tp -> tp | Rec -> Var dname in 382 | (x,arg)::elab_con (Ctx.add_syn ctx ~var:x ~tp) lvl dname args 383 | 384 | -------------------------------------------------------------------------------- /src/level.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | | Const of int 5 | | Omega 6 | [@@deriving show,equal] 7 | 8 | let (+) l1 l2 = 9 | match l1,l2 with 10 | | Const i,Const j -> Const (i + j) 11 | | _ -> Omega 12 | 13 | let (<) l1 l2 = 14 | match l1,l2 with 15 | | Const i, Const j -> i < j 16 | | Omega,_ -> false 17 | | _,Omega -> true 18 | 19 | let (<=) l1 l2 = 20 | match l1,l2 with 21 | | Const i, Const j -> i <= j 22 | | Omega,Omega -> true 23 | | Omega,Const _ -> false 24 | | _,Omega -> true 25 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Core 4 | open Parser 5 | 6 | } 7 | 8 | let ident = [^ '(' ')' '\\' ':' ',' '=' ' ' '\t' '\n' '^' ';' '|' '?' '.' ]+ 9 | let dec_num = ("0" | ['1'-'9'](['0'-'9']*)) 10 | 11 | let whitespace = [' ' '\t' '\r'] 12 | 13 | rule initial = parse 14 | | whitespace+ { initial lexbuf } 15 | | '\n' { Lexing.new_line lexbuf; initial lexbuf } 16 | | '(' { L_paren } 17 | | ')' { R_paren } 18 | | ';' { Semicolon } 19 | | ',' { Comma } 20 | | ".1" { DotOne } 21 | | ".2" { DotTwo } 22 | | '.' { Dot } 23 | | '*' | "×" { Star } 24 | | '\\' | "λ" { Lambda } 25 | | "->" | "→" { Arrow } 26 | | "=>" { Thick_arrow } 27 | | "let" { Let } 28 | | "in" { In } 29 | | "sig" { Sig } 30 | | "extends" { Extends } 31 | | "struct" { Struct } 32 | | "data" { Data } 33 | | "elim" { Elim } 34 | | "import" { Import } 35 | | '^' { Caret } 36 | | ':' { Colon } 37 | | '_' { Underbar } 38 | | "?" { Question_mark } 39 | | '/' { F_slash } 40 | | "Type" { Type } 41 | | "def" { Def } 42 | | "axiom" { Axiom } 43 | | "=" { Equal } 44 | | "refl" { Refl } 45 | | "Id" { Id } 46 | | "match" { Match } 47 | | '|' { Bar } 48 | | "with" { With } 49 | | "at" { At } 50 | | dec_num as d { Dec_const (Int.of_string d) } 51 | | "{-" { comment 1 lexbuf } 52 | | "-}" { failwith "Unbalanced comments" } 53 | | "--" { comment_line lexbuf } 54 | | ident as name { Ident name } 55 | | eof { Eof } 56 | | _ as x { failwith ("illegal char: " ^ (Char.to_string x)) } 57 | 58 | 59 | and comment nesting = parse 60 | | '\n' { Lexing.new_line lexbuf; comment nesting lexbuf } 61 | | "{-" { comment (nesting + 1) lexbuf } 62 | | "-}" { match nesting - 1 with | 0 -> initial lexbuf | n' -> comment n' lexbuf } 63 | | eof { failwith "Reached EOF in comment" } 64 | | _ { comment nesting lexbuf } 65 | 66 | and comment_line = parse 67 | | '\n' { Lexing.new_line lexbuf; initial lexbuf } 68 | | eof { failwith "Reached EOF in comment" } 69 | | _ { comment_line lexbuf } 70 | -------------------------------------------------------------------------------- /src/mark.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type src_loc = 4 | { line : int 5 | ; col : int 6 | } 7 | [@@deriving show] 8 | 9 | 10 | type src_span = 11 | { start_loc : src_loc 12 | ; end_loc : src_loc 13 | } 14 | [@@deriving show] 15 | 16 | 17 | let of_position (pos : Lexing.position) : src_loc = 18 | Lexing.{ line = pos.pos_lnum; col = pos.pos_cnum - pos.pos_bol + 1 (* 1-indexed *) } 19 | ;; 20 | 21 | let of_positions (pos_start : Lexing.position) (pos_end : Lexing.position) = 22 | { start_loc = of_position pos_start 23 | ; end_loc = of_position pos_end 24 | } 25 | ;; 26 | 27 | 28 | type 'a t = 'a * src_span option 29 | [@@deriving show] 30 | 31 | let mark (data : 'a) (span : src_span) : 'a t = data, Some span 32 | let mark_opt data span = data,span 33 | let data : 'a t -> 'a = fst 34 | let naked (data : 'a) : 'a t = data, None 35 | let src_span : 'a t -> src_span option = snd 36 | 37 | let show : 'a t -> string = 38 | let show_src_loc = function 39 | | { line; col = 0 } -> string_of_int line 40 | | { line; col } -> string_of_int line ^ "." ^ string_of_int col 41 | in 42 | function 43 | | _,Some span -> sprintf "%s-%s" (show_src_loc span.start_loc) (show_src_loc span.end_loc) 44 | | _,None -> "" 45 | -------------------------------------------------------------------------------- /src/nbe.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Syn = Syntax 4 | module Dom = Domain 5 | 6 | 7 | exception EquateError of string 8 | 9 | let error s = raise (EquateError s) 10 | 11 | let var x tp = Dom.Neutral {ne = Var x ; tp} 12 | 13 | let rec eval (env : Dom.env) (s : Syn.t) : Dom.t = 14 | (* printf "EVAL %s\n" (Syn.show s); *) 15 | match s with 16 | | Var x -> (try Dom.Env.find_exn env x with 17 | _ -> eval env (Dom.Env.find_data_exn env x).tm 18 | ) 19 | | Lift {name ; lvl} -> 20 | let Dom.{tm;tp} : Dom.nf = try Dom.Env.find_def_exn env name with _ -> 21 | let d = Dom.Env.find_data_exn env name in 22 | {tm = eval env d.tm ; tp = eval env d.tp} 23 | in 24 | eval env (Syn.lift lvl (read_back (Dom.Env.key_set env) tm tp)) 25 | | U i -> U i 26 | | Pi ((x,d),r) -> Pi (eval env d,{name = x ; tm = r ; env}) 27 | | Lam (x,s) -> Lam {name = x ; tm = s ; env} 28 | | Ap (f,s) -> do_ap (eval env f) (eval env s) 29 | | Sg ((x,f),s) -> Sg (eval env f,{name = x ; tm = s ; env}) 30 | | Pair (a,b) -> Pair (eval env a, eval env b) 31 | | Fst p -> do_fst (eval env p) 32 | | Snd p -> do_snd (eval env p) 33 | | Data {name ; params} -> Data {desc = Dom.Env.find_data_exn env name ; params = List.map ~f:(eval env) params} 34 | | Intro {name ; args} -> Intro {name ; args = List.map ~f:(eval env) args} 35 | | Elim {mot = (x,m) ; arms ; scrut} -> do_elim Dom.{name = x ; tm = m ; env} arms (eval env scrut) env 36 | | RecordTy fs -> RecordTy (fs,env) 37 | | Record fs -> Record (eval_record env fs) 38 | | Proj (f,e) -> do_proj f (eval env e) 39 | | Id (a,m,n) -> Id (eval env a,eval env m,eval env n) 40 | | Refl x -> Refl (eval env x) 41 | | J {mot = (x,y,p,m); body = (z,e) ; scrut} -> do_j Dom.{names = (x,y,p) ; tm = m ; env} Dom.{name = z ; tm = e ; env} (eval env scrut) 42 | | Let ((x,e1),e2) -> eval (Dom.Env.set env ~key:x ~data:(eval env e1)) e2 43 | | Hole {name ; tp} -> let tp = eval env tp in Neutral {ne = Hole {name ; tp} ; tp} 44 | 45 | and do_clos ({name ; tm ; env } : Dom.clos) (arg : Dom.t) : Dom.t = 46 | eval (Dom.Env.set env ~key:name ~data:arg) tm 47 | 48 | 49 | and do_clos3 ({names = (x,y,z) ; tm ; env } : Dom.clos3) (a : Dom.t) (b : Dom.t) (c : Dom.t) : Dom.t = 50 | eval (env |> Dom.Env.set ~key:x ~data:a |> Dom.Env.set ~key:y ~data:b |> Dom.Env.set ~key:z ~data:c) tm 51 | 52 | and eval_record env = function 53 | | [] -> [] 54 | | (f,e)::fs -> 55 | let e = eval env e in 56 | (f,e)::eval_record (Dom.Env.set env ~key:f ~data:e) fs 57 | 58 | and do_ap (f : Dom.t) (arg : Dom.t) : Dom.t = 59 | match f with 60 | | Lam clos -> do_clos clos arg 61 | | Neutral {tp = Pi (d,clos) ; ne} -> 62 | Neutral {tp = do_clos clos arg ; ne = Ap (ne,{tm = arg ; tp = d})} 63 | | _ -> failwith "do_ap" 64 | 65 | and do_fst (p : Dom.t) : Dom.t = 66 | match p with 67 | | Pair (f,_) -> f 68 | | Neutral {tp = Sg (a,_) ; ne} -> Neutral {tp = a ; ne = Fst ne} 69 | | _ -> failwith "do_fst" 70 | 71 | and do_snd (p : Dom.t) : Dom.t = 72 | match p with 73 | | Pair (_,s) -> s 74 | | Neutral {tp = Sg (_,clos) ; ne} -> Neutral {tp = do_clos clos (do_fst p) ; ne = Snd ne} 75 | | _ -> failwith "do_snd" 76 | 77 | and do_proj (f : string) (r : Dom.t) : Dom.t = 78 | match r with 79 | | Record fs -> List.Assoc.find_exn ~equal:String.equal fs f 80 | | Neutral {tp = RecordTy (fs,env) ; ne} -> Neutral {tp = do_proj_tp f fs env ; ne = Proj (f,ne) } 81 | | _ -> failwith "do_proj" 82 | 83 | and do_proj_tp f fs env = 84 | match fs with 85 | | [] -> failwith "do_proj_tp" 86 | | (f',tp)::fs -> if String.equal f f' then eval env tp else 87 | do_proj_tp f fs (Dom.Env.set env ~key:f' ~data:(var f' (eval env tp))) 88 | 89 | and do_elim mot arms scrut env_s = 90 | match scrut with 91 | | Intro {name ; args} -> 92 | let (vars,body) = List.Assoc.find_exn arms ~equal:String.equal name in 93 | let env = List.fold2_exn args vars ~init:env_s ~f:(fun env arg -> function 94 | | `Arg x -> env |> Dom.Env.set ~key:x ~data:arg 95 | | `Rec (x,r) -> env |> Dom.Env.set ~key:x ~data:arg |> Dom.Env.set ~key:r ~data:(do_elim mot arms arg env_s)) in 96 | eval env body 97 | | Neutral {tp = Data {desc ; params} ; ne} -> 98 | Neutral { tp = do_clos mot scrut 99 | ; ne = Elim { mot 100 | ; arms = List.map arms ~f:(fun (con,(vs,body)) -> con,Dom.{names = vs ; arm = body ; env = env_s}) 101 | ; scrut = ne 102 | ; desc 103 | ; params 104 | } 105 | } 106 | | _ -> failwith "do_elim" 107 | 108 | 109 | and do_j (mot : Dom.clos3) (body : Dom.clos) (scrut : Dom.t) : Dom.t = 110 | match scrut with 111 | | Refl x -> do_clos body x 112 | | Neutral {tp = Id (a,e1,e2) ; ne} -> 113 | Neutral {tp = do_clos3 mot e1 e2 scrut; 114 | ne = J {mot ; body ; tp = a ; scrut = ne} 115 | } 116 | | d -> failwith (sprintf "do_j - %s" (Dom.show d)) 117 | 118 | and fresh used x = if String.equal x "_" then x,used else 119 | let rec go x = 120 | if String.Set.mem used x then go (x ^ "'") else x 121 | in let y = go x in 122 | y,String.Set.add used y 123 | 124 | and fresh3 used (x,y,z) = 125 | let x,used = fresh used x in 126 | let y,used = fresh used y in 127 | let z,used = fresh used z in 128 | (x,y,z,used) 129 | 130 | 131 | and resolve_name used (f : Dom.t) (x : string) = 132 | match f,x with 133 | | Lam clos,"_" -> clos.name,used 134 | | _,"_" -> fresh used "x" 135 | | _ -> fresh used x 136 | 137 | and resolve_arg_tp (desc,params) : Dom.spec -> Dom.t = function 138 | | Rec -> Data {desc ; params} 139 | | Tp tp -> eval desc.env tp 140 | 141 | and apply_params (desc : Dom.desc) param_tps ps = 142 | match param_tps,ps with 143 | | [],[] -> desc 144 | | (x,_)::param_tps,p::ps -> 145 | apply_params {desc with env = Dom.Env.set desc.env ~key:x ~data:p} param_tps ps 146 | | _ -> failwith "apply_params" 147 | 148 | 149 | and equate ?(subtype = false) (used : String.Set.t) (e1 : Dom.t) (e2 : Dom.t) (tp : Dom.t) : Syn.t = 150 | (* printf "-----\nEQUATING\n%s\nWITH\n%s\nAT\n%s\n-----\n" (Dom.show e1) (Dom.show e2) (Dom.show tp); *) 151 | match e1,e2,tp with 152 | | U i, U j, U _ -> 153 | if subtype then 154 | if Level.(<=) i j then U i else error (sprintf "Level Error: %s !<= %s" (Level.show i) (Level.show j)) 155 | else 156 | if Level.equal i j then U i else error (sprintf "Level Error: %s !<= %s" (Level.show i) (Level.show j)) 157 | | f1,f2, Pi (d,clos) -> 158 | let x,used = resolve_name used f1 (clos.name) in 159 | Lam (x,equate ~subtype used (do_ap f1 (var x d)) (do_ap f2 (var x d)) (do_clos clos (var x d))) 160 | | Pi (d1,clos1), Pi (d2,clos2), U i -> 161 | let d = equate ~subtype used d2 d1 (U i) in 162 | let x,used = fresh used clos1.name in 163 | Pi ((x,d),equate ~subtype used (do_clos clos1 (var x d1)) (do_clos clos2 (var x d2)) (U i)) 164 | | Sg (d1,clos1), Sg (d2,clos2), U i -> 165 | let d = equate ~subtype used d2 d1 (U i) in 166 | let x,used = fresh used clos1.name in 167 | Sg ((x,d),equate ~subtype used (do_clos clos1 (var x d1)) (do_clos clos2 (var x d2)) (U i)) 168 | | RecordTy (fs1,env1), RecordTy (fs2,env2), U i -> 169 | let q = List.fold2 fs1 fs2 ~init:([],env1,env2) ~f:(fun (r,env1,env2) (f1,tp1) (f2,tp2) -> 170 | if not (String.equal f1 f2) then error "non_equal fields" else 171 | let tp1 = eval env1 tp1 in 172 | let tp2 = eval env2 tp2 in 173 | (f1,equate ~subtype used tp1 tp2 (U i))::r,Dom.Env.set env1 ~key:f1 ~data:(var f1 tp1),Dom.Env.set env2 ~key:f2 ~data:(var f2 tp2) 174 | ) in 175 | begin 176 | match q with 177 | | Ok (fs,_,_) -> RecordTy (List.rev fs) 178 | | Unequal_lengths -> error "unequal length records" 179 | end 180 | | r1,r2, RecordTy (fs,env) -> 181 | let q = List.fold fs ~init:([],env) ~f:(fun (r,env) (f,tp) -> 182 | let p1 = do_proj f r1 in 183 | let p = equate ~subtype used p1 (do_proj f r2) (eval env tp) in 184 | ((f,p)::r,Dom.Env.set env ~key:f ~data:p1) 185 | ) in Record (List.rev @@ fst q) 186 | | p1,p2, Sg (f,clos) -> 187 | let fst_p1 = do_fst p1 in 188 | Pair (equate ~subtype used fst_p1 (do_fst p2) f, equate ~subtype used (do_snd p1) (do_snd p2) (do_clos clos fst_p1)) 189 | | Data d1, Data d2, U _ -> 190 | if String.equal d1.desc.name d2.desc.name 191 | then Data {name = d1.desc.name ; params = equate_params ~subtype used d1.params d2.params d1.desc.params d1.desc.env} 192 | else error (sprintf "%s != %s" d1.desc.name d2.desc.name) 193 | | Intro i1, Intro i2, Data {desc ; params} -> 194 | if not (String.equal i1.name i2.name) then error (sprintf "%s != %s" i1.name i2.name) else 195 | let args = equate_intro_args ~subtype used i1.args i2.args (List.Assoc.find_exn ~equal:String.equal desc.cons i1.name) (apply_params desc desc.params params,params) in 196 | Intro {name = i1.name ; args} 197 | | Id (a1,m1,n1),Id (a2,m2,n2), U i -> 198 | Id (equate ~subtype used a1 a2 (U i),equate ~subtype used m1 m2 a1,equate ~subtype used n1 n2 a1) 199 | | Refl x1, Refl x2, Id (a,_,_) -> 200 | Refl (equate ~subtype used x1 x2 a) 201 | | Neutral n1,Neutral n2,_ -> equate_ne ~subtype used n1.ne n2.ne 202 | | _ -> error (sprintf "equate - Inputs not convertible - %s != %s at %s" (Dom.show e1) (Dom.show e2) (Dom.show tp)) 203 | 204 | and equate_intro_args ~subtype used args1 args2 dtele (desc,params) = 205 | match args1,args2,dtele with 206 | | [],[],[] -> [] 207 | | arg1::args1,arg2::args2,(x,s)::dtele -> 208 | let arg = equate ~subtype used arg1 arg2 (resolve_arg_tp (desc,params) s) in 209 | arg::equate_intro_args ~subtype used args1 args2 dtele ({desc with env = Dom.Env.set desc.env ~key:x ~data:arg1},params) 210 | | _ -> error (sprintf "Intro argument mismatch - %s %s" (List.to_string ~f:Dom.show args1) (List.to_string ~f:Dom.show args2)) 211 | 212 | and equate_params ~subtype used args1 args2 dtele env = 213 | match args1,args2,dtele with 214 | | [],[],[] -> [] 215 | | arg1::args1,arg2::args2,(x,tp)::dtele -> 216 | let arg = equate ~subtype used arg1 arg2 (eval env tp) in 217 | arg::equate_params ~subtype used args1 args2 dtele (Dom.Env.set env ~key:x ~data:arg1) 218 | | _ -> error (sprintf "Param argument mismatch - %s %s" (List.to_string ~f:Dom.show args1) (List.to_string ~f:Dom.show args2)) 219 | 220 | and equate_ne ~subtype used ne1 ne2 = 221 | match ne1,ne2 with 222 | | Var x,Var y -> if String.equal x y then Var x else error (sprintf "%s != %s" x y) 223 | | Ap (f1,nf1),Ap (f2,nf2) -> Ap (equate_ne ~subtype used f1 f2,equate ~subtype used nf1.tm nf2.tm nf1.tp) 224 | | Fst ne1, Fst ne2 -> Fst (equate_ne ~subtype used ne1 ne2) 225 | | Snd ne1, Snd ne2 -> Snd (equate_ne ~subtype used ne1 ne2) 226 | | Proj (f1,ne1), Proj (f2,ne2) -> if String.equal f1 f2 then Proj (f1,equate_ne ~subtype used ne1 ne2) else error (sprintf "Different projections: %s != %s" f1 f2) 227 | | Elim e1,Elim e2 -> 228 | let x,used = fresh used e1.mot.name in 229 | Elim { mot = (x,equate ~subtype used (do_clos e1.mot (var x (Data {desc = e1.desc ; params = e1.params}))) (do_clos e2.mot (var x (Data {desc=e2.desc;params=e2.params}))) (U Omega)) 230 | ; arms = List.map2_exn e1.arms e2.arms ~f:(fun (con1,clos1) (_,clos2) -> 231 | let dtele = List.Assoc.find_exn e1.desc.cons ~equal:String.equal con1 in 232 | let args,env1 = collect_elim_args e1.mot clos1.names dtele (apply_params e1.desc e1.desc.params e1.params,e1.params) clos1.env in 233 | let _,env2 = collect_elim_args e2.mot clos2.names dtele (apply_params e2.desc e2.desc.params e2.params,e2.params) clos2.env in 234 | (con1,(clos1.names,equate ~subtype used (eval env1 clos1.arm) (eval env2 clos2.arm) (do_clos e1.mot (Intro {name = con1 ; args})))) 235 | ) 236 | ; scrut = equate_ne ~subtype used e1.scrut e2.scrut 237 | } 238 | | J j1, J j2 -> 239 | let tp = j1.tp in 240 | let x,y,p,usedM = fresh3 used (j1.mot.names) in 241 | let z,usedB = fresh used (j1.body.name) in 242 | let mot = equate ~subtype usedM (do_clos3 j1.mot (var x tp) (var y tp) (var p (Id (tp,var x tp, var y tp)))) 243 | (do_clos3 j2.mot (var x tp) (var y tp) (var p (Id (tp,var x tp, var y tp)))) 244 | (U Omega) in 245 | J { mot = (x,y,p,mot) 246 | ; body = (z,equate ~subtype usedB (do_clos j1.body (var z tp)) (do_clos j2.body (var z tp)) (do_clos3 j1.mot (var z tp) (var z tp) (Refl (var z tp)))) 247 | ; scrut = equate_ne ~subtype used j1.scrut j2.scrut 248 | } 249 | | Hole h1, Hole h2 when String.equal h1.name h2.name -> Hole {name = h1.name ; tp = equate ~subtype used h1.tp h2.tp (U Omega)} 250 | | _ -> error "equate_ne - Inputs not convertible" 251 | 252 | 253 | 254 | and collect_elim_args mot args dtele (desc,params) env = 255 | match args,dtele with 256 | | [],[] -> [],env 257 | | arg::args,(y,s)::dtele -> 258 | begin 259 | match arg with 260 | | `Arg x -> 261 | let tp = resolve_arg_tp (desc,params) s in 262 | let arg = var x tp in 263 | let env = Dom.Env.set env ~key:x ~data:arg in 264 | let args,env = collect_elim_args mot args dtele ({desc with env = Dom.Env.set desc.env ~key:y ~data:tp},params) env in 265 | arg::args,env 266 | | `Rec (x,ih) -> 267 | let tp = resolve_arg_tp (desc,params) s in 268 | let arg = var x tp in 269 | let arg_ih = var ih (do_clos mot arg) in 270 | let env = env |> Dom.Env.set ~key:x ~data:arg |> Dom.Env.set ~key:ih ~data:arg_ih in 271 | let args,env = collect_elim_args mot args dtele ({desc with env = Dom.Env.set desc.env ~key:y ~data:tp},params) env in 272 | arg::args,env 273 | end 274 | | _ -> error "collect_elim_args NBE" 275 | 276 | 277 | and read_back used e tp = equate used e e tp 278 | 279 | and convertible used e1 e2 tp = (fun _ -> ()) (equate ~subtype:true used e1 e2 tp) 280 | 281 | let convertible_b used e1 e2 tp = 282 | try convertible used e1 e2 tp; true with 283 | | _ -> false 284 | 285 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | open Core.List 4 | 5 | let rec args_to_tele = function 6 | | [] -> [] 7 | | (xs,t)::args -> map xs ~f:(fun x -> (x,t)) @ args_to_tele args 8 | 9 | let func_syntax (args,t,e) = 10 | let tele = args_to_tele args in 11 | (Mark.naked @@ Concrete_syntax.Lam (map ~f:fst tele,e), Mark.naked @@ Concrete_syntax.Pi (tele,t)) 12 | 13 | (* 14 | let rec_func_syntax (name,args,t,e) = 15 | let tele = args_to_tele args in 16 | (Mark.naked @@ Concrete_syntax.Fun {name ; args = map ~f:fst tele ; body = e},Mark.naked @@ Concrete_syntax.Pi (tele,t)) 17 | *) 18 | 19 | let hole_count = ref (-1) 20 | let new_hole () = hole_count := (!hole_count) + 1; Int.to_string (!hole_count) 21 | 22 | %} 23 | 24 | %token Eof 25 | %token Import 26 | %token Question_mark 27 | %token L_paren R_paren L_angle R_angle 28 | %token Lambda Thick_arrow Arrow 29 | %token Comma DotOne DotTwo Star 30 | %token Dot Sig Struct Extends 31 | %token Let In 32 | %token Type Caret 33 | %token Colon Semicolon 34 | %token Underbar 35 | %token Id Refl 36 | %token Match With Bar At 37 | %token Data Elim F_slash 38 | %token Def Equal Axiom 39 | %token Ident 40 | %token Dec_const 41 | 42 | 43 | %right Arrow 44 | %right Equal 45 | %right Star 46 | 47 | %type init 48 | 49 | %start init 50 | 51 | %% 52 | 53 | 54 | let m(x) := 55 | | x = x; { Mark.mark x (Mark.of_positions $startpos(x) $endpos(x))} 56 | 57 | 58 | let paren(x) == L_paren; ~ = x; R_paren; <> 59 | 60 | let init := ~ = nonempty_list(cmd); Eof; <> 61 | 62 | 63 | let cmd := 64 | | Def; ~ = bound_name; Thick_arrow; ~ = m(term); 65 | | Def; x = bound_name; Colon; tp = m(term); Thick_arrow; tm = m(term); { Concrete_syntax.Def (x, Mark.naked @@ Concrete_syntax.Ascribe {tp ; tm}) } 66 | | Def; x = bound_name; args = nonempty_list(paren(annot_args)); Colon; t = m(term); Thick_arrow; e = m(term); 67 | { let tm,tp = func_syntax (args,t,e) in 68 | Concrete_syntax.Def (x,Mark.naked @@ Concrete_syntax.Ascribe {tm ; tp}) 69 | } 70 | | Axiom; x = bound_name; Colon; tp = m(term); { Concrete_syntax.Axiom (x,tp) } 71 | | data_def 72 | | Import; f = Ident; { Concrete_syntax.Import f } 73 | | ~ = m(term); 74 | 75 | let data_def := 76 | | Data; params = list(paren(annot_args)); name = bound_name; lvl = data_def_lvl; 77 | { Concrete_syntax.Data {name ; cons = [] ; params = args_to_tele params ; lvl}} 78 | | Data; params = list(paren(annot_args)); name = bound_name; lvl = data_def_lvl; Thick_arrow; 79 | option(Bar); cons = separated_nonempty_list(Bar,con); 80 | { Concrete_syntax.Data {name ; cons ; params = args_to_tele params ; lvl}} 81 | 82 | let data_def_lvl := 83 | | { Level.Const 0 } 84 | | Colon; Type; { Level.Const 0 } 85 | | Colon; Type; Caret; n = Dec_const; { Level.Const n } 86 | 87 | let con := 88 | name = bound_name; args = list(paren(annot_args)); 89 | { (name,args_to_tele args) } 90 | 91 | let bound_name := 92 | | Ident 93 | | Underbar; { "_" } 94 | 95 | let hole := 96 | | Ident 97 | | { new_hole () } 98 | 99 | let annot_args := 100 | | ~ = nonempty_list(bound_name); Colon ; ~ = m(term) ; <> 101 | 102 | 103 | 104 | let atomic := 105 | | paren(term) 106 | | Question_mark; x = hole; { Concrete_syntax.Hole ("?" ^ x) } 107 | | x = Ident; { Concrete_syntax.Var x } 108 | | name = Ident; Caret; lvl = Dec_const; { Concrete_syntax.Lift {name ; lvl} } 109 | | ~ = paren(separated_list(Comma,m(term))); 110 | | ~ = m(atomic); DotOne; 111 | | ~ = m(atomic); DotTwo; 112 | | e = m(atomic); Dot; f = Ident; { Concrete_syntax.Proj (f,e) } 113 | | Type; Caret; i = Dec_const; { Concrete_syntax.U (Const i) } 114 | | Type; { Concrete_syntax.U (Const 0) } 115 | | Refl; { Concrete_syntax.Refl } 116 | | Lambda; L_paren; R_paren; { Concrete_syntax.Absurd } 117 | 118 | let spine := 119 | | { Concrete_syntax.Nil } 120 | | ~ = spine; ~ = m(atomic); 121 | 122 | let nonempty_spine := 123 | | ~ = spine; ~ = m(atomic); 124 | 125 | let record_term := 126 | | f = Ident; xs = list(bound_name); Thick_arrow; e = m(term); 127 | { match xs with 128 | | [] -> (f,e) 129 | | _ -> (f, Mark.mark_opt (Concrete_syntax.Lam (xs,e)) (Mark.src_span e)) 130 | } 131 | 132 | let record_type := 133 | | f = Ident; Colon; e = m(term); { (f,e) } 134 | 135 | 136 | let term := 137 | | atomic 138 | | ~ = m(atomic); ~ = nonempty_spine; 139 | | Lambda; xs = nonempty_list(bound_name); Thick_arrow; e = m(term); 140 | | args = nonempty_list(paren(annot_args)); Arrow; e = m(term); { Concrete_syntax.Pi (args_to_tele args,e) } 141 | | t1 = m(term); Arrow; t2 = m(term); { Concrete_syntax.Pi ([("_",t1)],t2) } 142 | | args = nonempty_list(paren(annot_args)); Star; e = m(term); { Concrete_syntax.Sg (args_to_tele args,e) } 143 | | t1 = m(term); Star; t2 = m(term); { Concrete_syntax.Sg ([("_",t1)],t2) } 144 | | Id; t = m(atomic); e1 = m(atomic); e2 = m(atomic); 145 | | Sig; option(Bar); fs = separated_list(Bar,record_type); { Concrete_syntax.RecordTy {extends = [] ; fields = fs} } 146 | | Sig; Extends; exts = separated_list(Comma,m(term)); Bar; fs = separated_list(Bar,record_type); { Concrete_syntax.RecordTy {extends = exts ; fields = fs}} 147 | | Struct; option(Bar); fs = separated_list(Bar,record_term); { Concrete_syntax.Record {extends = [] ; fields = fs} } 148 | | Struct; Extends; exts = separated_list(Comma,m(term)); Bar; fs = separated_list(Bar,record_term); { Concrete_syntax.Record {extends = exts ; fields = fs}} 149 | | e1 = m(term); Equal; e2 = m(term); { Concrete_syntax.Eq (e1,e2) } 150 | 151 | | Let; x = bound_name; Thick_arrow; e1 = m(term); In; e2 = m(term); 152 | {Concrete_syntax.Let ((x,e1),e2) } 153 | 154 | | Let; x = bound_name; Colon; t = m(term); Thick_arrow; e1 = m(term); In; e2 = m(term); 155 | { Concrete_syntax.Let ((x,Mark.naked @@ Concrete_syntax.Ascribe {tm = e1 ; tp = t}),e2) } 156 | 157 | | Let; x = bound_name; args = nonempty_list(paren(annot_args)); Colon; t = m(term); Thick_arrow; e = m(term); In; e2 = m(term); 158 | { let tm,tp = func_syntax (args,t,e) in 159 | Concrete_syntax.Let ((x,Mark.naked @@ Concrete_syntax.Ascribe {tm ; tp}),e2) 160 | } 161 | 162 | | Lambda; Elim; 163 | option(Bar); arms = separated_list(Bar,arm); 164 | { Concrete_syntax.ElimFun arms} 165 | 166 | | Elim; scrut = m(term); At; x = bound_name; Thick_arrow; mot = m(term); With; 167 | option(Bar); arms = separated_list(Bar,arm); 168 | { Concrete_syntax.Elim {mot = Some (x,mot) ; scrut ; arms}} 169 | 170 | | Elim; scrut = m(term); With; 171 | option(Bar); arms = separated_list(Bar,arm); 172 | { Concrete_syntax.Elim {mot = None ; scrut ; arms}} 173 | 174 | | Match; scrut = m(term); With; 175 | option(Bar); Refl; a = bound_name; Thick_arrow; case = m(term); 176 | { Concrete_syntax.J {mot = None ; body = (a,case) ; scrut } } 177 | 178 | | Match; scrut = m(term); At; x = bound_name; y = bound_name; z = bound_name; Thick_arrow; mot = m(term); With; 179 | option(Bar); Refl; a = bound_name; Thick_arrow; case = m(term); 180 | { Concrete_syntax.J {mot = Some (x,y,z,mot) ; body = (a,case) ; scrut} } 181 | 182 | let arm := 183 | | con = Ident; args = list(arm_pat); Thick_arrow; body = m(term); { (con,(args,body)) } 184 | 185 | let arm_pat := 186 | | ~ = bound_name; <`Arg> 187 | | L_paren; x = bound_name; F_slash; y = bound_name; R_paren; <`Rec> -------------------------------------------------------------------------------- /src/repl.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Concrete_syntax 3 | 4 | module Syn = Syntax 5 | module Dom = Domain 6 | 7 | exception ParseError of string 8 | 9 | type loc = {line : int ; col : int} 10 | 11 | let of_position (pos : Lexing.position) : loc = 12 | Lexing.{ line = pos.pos_lnum; col = pos.pos_cnum - pos.pos_bol + 1 (* 1-indexed *) } 13 | 14 | let show_loc {line ; col} = sprintf "%i:%i" line col 15 | 16 | let parse s = 17 | let lexbuf = Lexing.from_string s in 18 | try Parser.init Lexer.initial lexbuf with 19 | | _ -> 20 | let (s,e) = of_position lexbuf.lex_start_p,of_position lexbuf.lex_curr_p in 21 | raise @@ ParseError (sprintf "%s-%s" (show_loc s) (show_loc e)) 22 | 23 | let parse_file s = 24 | let p = Stdlib.open_in s in 25 | let lexbuf = Lexing.from_channel p in 26 | try Parser.init Lexer.initial lexbuf with 27 | | _ -> 28 | let (s,e) = of_position lexbuf.lex_start_p,of_position lexbuf.lex_curr_p in 29 | raise @@ ParseError (sprintf "%s:%s" (show_loc s) (show_loc e)) 30 | 31 | let get_prefix s = 32 | match String.rindex s '/' with 33 | | None -> "" 34 | | Some i -> String.prefix s i ^ "/" 35 | 36 | let chop_extension s = 37 | match String.rindex s '.' with 38 | | None -> s 39 | | Some i -> String.prefix s i 40 | 41 | let rec show_module_deps = function 42 | | [] -> "" 43 | | [x] -> x 44 | | x::xs -> sprintf "%s <- %s" x (show_module_deps xs) 45 | 46 | let rec run_cmds prefix importing imported ctx = function 47 | | [] -> imported,ctx 48 | | cmd::cmds -> 49 | match cmd with 50 | | Eval e -> 51 | let tp,tm = Elab.synth ctx e in 52 | printf "_ : %s\n\n" (Syn.show (Nbe.read_back (Ctx.to_names ctx) tp (U Omega))); 53 | printf "_ = %s\n\n" (Syn.show (Elab.normalize ~tm ~tp ~ctx)); 54 | run_cmds prefix importing imported ctx cmds 55 | | Def (x,e) -> 56 | let tp,e = Elab.synth ctx e in 57 | let e = Nbe.eval (Ctx.to_env ctx) e in 58 | printf "def %s\n\n" x; 59 | run_cmds prefix importing imported (Ctx.add_def ctx ~var:x ~def:e ~tp) cmds 60 | | Axiom (x,tp) -> 61 | let tp = Nbe.eval (Ctx.to_env ctx) @@ Elab.check ctx tp (U Omega) in 62 | printf "axiom %s\n\n" x; 63 | run_cmds prefix importing imported (Ctx.add_def ctx ~var:x ~def:(Nbe.var x tp) ~tp) cmds 64 | | Data {name ; cons ; params ; lvl} -> 65 | let desc = Elab.elab_data ctx name cons params lvl in 66 | printf "data %s\n\n" name; 67 | run_cmds prefix importing imported (Ctx.add_data ctx desc) cmds 68 | | Import modu -> 69 | let path = prefix^modu^".dtt" in 70 | if List.mem ~equal:String.equal importing path then failwith (sprintf "Cylcic module dependency: %s" (show_module_deps (path :: importing))); 71 | if String.Set.mem imported path then run_cmds prefix importing imported ctx cmds else 72 | (printf "import %s\n\n" modu; 73 | let imported,ctx = run_cmds prefix (path::importing) imported ctx (parse_file path) in 74 | run_cmds prefix importing (String.Set.add imported path) ctx cmds) 75 | 76 | 77 | let rec repl (imported,ctx) = 78 | print_string "-- "; 79 | let txt = Stdlib.read_line () in 80 | if String.equal txt "" then repl (imported,ctx); 81 | try repl @@ run_cmds "" [] imported ctx (parse txt) with 82 | | Elab.TypeError e -> printf "Type Error: %s\n" e;repl (imported,ctx) 83 | | ParseError e -> printf "Parse Error: %s\n" e; repl (imported,ctx) 84 | 85 | 86 | 87 | 88 | let _ : unit = 89 | let args = Sys.get_argv () in 90 | if Array.length args = 1 then repl (String.Set.empty,Ctx.empty); 91 | let s = parse_file args.(1) in 92 | let prefix = get_prefix args.(1) in 93 | try repl @@ run_cmds prefix [args.(1)] String.Set.empty Ctx.empty s with 94 | | Elab.TypeError e -> printf "Type Error: %s\n" e 95 | | ParseError e -> printf "Parse Error: %s\n" e 96 | -------------------------------------------------------------------------------- /src/syntax.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type 'a bnd = string * 'a 4 | [@@deriving show] 5 | 6 | type t = 7 | | Var of string 8 | | Lift of {name : string ; lvl : int} 9 | | U of Level.t 10 | | Pi of t bnd * t 11 | | Lam of string * t 12 | | Ap of t * t 13 | | Sg of t bnd * t 14 | | Pair of t * t 15 | | Fst of t 16 | | Snd of t 17 | | RecordTy of (string * t) list 18 | | Record of (string * t) list 19 | | Proj of string * t 20 | | Data of {name : string ; params : t list} 21 | | Intro of {name : string ; args : t list} 22 | | Elim of {mot : t bnd ; arms : ([`Rec of string * string | `Arg of string] list * t) bnd list ; scrut : t} 23 | | Id of t * t * t 24 | | Refl of t 25 | | J of {mot : string * string * string * t ; scrut : t ; body : string * t} 26 | | Let of t bnd * t 27 | | Hole of {name : string ; tp : t} 28 | [@@deriving show] 29 | 30 | let rec flatten_arm_args = function 31 | | [] -> [] 32 | | `Arg x::args -> x::flatten_arm_args args 33 | | `Rec (x,r)::args -> x::r::flatten_arm_args args 34 | 35 | let rec_map (f : t -> t) = function 36 | | Var x -> Var x 37 | | Lift x -> Lift x 38 | | Pi ((x,d),r) -> Pi ((x,f d), f r) 39 | | Lam (x,e) -> Lam (x,f e) 40 | | Ap (g,e) -> Ap (f g, f e) 41 | | U i -> U i 42 | | RecordTy fs -> RecordTy (List.map ~f:(fun (field,tp) -> (field,f tp)) fs) 43 | | Record fs -> Record (List.map ~f:(fun (field,tm) -> (field,f tm)) fs) 44 | | Proj (field,t) -> Proj (field,f t) 45 | | Data {name ; params} -> Data {name ; params = List.map ~f params} 46 | | Intro {name ; args} -> Intro {name ; args = List.map ~f args} 47 | | Elim {mot = (x,m) ; scrut ; arms} -> Elim {mot = (x,f m) ; scrut = f scrut ; arms = List.map arms ~f:(fun (con,(vs,e)) -> (con, (vs,f e)))} 48 | | Id (a,x,y) -> Id (f a, f x, f y) 49 | | Refl x -> Refl (f x) 50 | | J {mot = (x,y,p,m) ; body = (z,e) ; scrut} -> J {mot = (x,y,p,f m) ; body = (z,f e) ; scrut = f scrut} 51 | | Sg ((x,d),r) -> Sg ((x,f d),f r) 52 | | Pair (x,y) -> Pair (f x, f y) 53 | | Fst p -> Fst (f p) 54 | | Snd p -> Snd (f p) 55 | | Let ((x,e1),e2) -> Let ((x,f e1),f e2) 56 | | Hole {name ; tp} -> Hole {name ; tp = f tp} 57 | 58 | 59 | 60 | let rec bottom_up f x = x |> rec_map (bottom_up f) |> f 61 | let rec top_down f x = x |> f |> rec_map (top_down f) 62 | 63 | let lift i = bottom_up (function 64 | | U (Const j) -> U (Const (j + i)) 65 | | x -> x) 66 | 67 | let rec pp_term (e : t) : string = 68 | match e with 69 | | Lam (x,e) -> sprintf "λ %s ⇒ %s" x (pp_term e) 70 | | Pi (("_",(Pi _ | Sg _ as d)),r) -> sprintf "(%s) → %s" (pp_term d) (pp_term r) 71 | | Pi (("_",d),r) -> sprintf "%s → %s" (pp_term d) (pp_term r) 72 | | Pi ((x,d),r) -> sprintf "(%s : %s) → %s" x (pp_term d) (pp_term r) 73 | | Sg (("_",t),(Sg _ as e)) -> sprintf "%s × %s" (pp_atomic t) (pp_term e) 74 | | Sg (("_",t),e) -> sprintf "%s × %s" (pp_atomic t) (pp_atomic e) 75 | | Sg ((x,t),(Sg _ as e)) -> sprintf "(%s : %s) × %s" x (pp_term t) (pp_term e) 76 | | Sg ((x,t),e) -> sprintf "(%s : %s) × %s" x (pp_term t) (pp_atomic e) 77 | | Ap ((Lam _ | J _ | Elim _) as e1,e2) -> sprintf "(%s) %s" (pp_term e1) (pp_term e2) 78 | | Ap (e1,(Ap _ as e2)) -> sprintf "%s (%s)" (pp_term e1) (pp_term e2) 79 | | Ap (e1,e2) -> sprintf "%s %s" (pp_term e1) (pp_atomic e2) 80 | | Intro {name ; args = arg::args} -> sprintf "%s %s" name (pp_args (arg::args)) 81 | | Data {name ; params = p::ps} -> sprintf "%s %s" name (pp_args (p::ps)) 82 | | Elim {mot = _ ; arms = [] ; scrut} -> 83 | sprintf "elim %s with" (pp_atomic scrut) 84 | | Elim {mot = _ ; arms ; scrut} -> 85 | sprintf "elim %s with %s" (pp_atomic scrut) (pp_arms arms) 86 | | Id (_,(Lam _ | Pi _ as x), (Lam _ | Pi _ as y)) -> sprintf "%s = %s" (pp_atomic x) (pp_atomic y) 87 | | Id (_,(Lam _ | Pi _ as x), y) -> sprintf "%s = %s" (pp_atomic x) (pp_term y) 88 | | Id (_,x,(Lam _ | Pi _ as y)) -> sprintf "%s = %s" (pp_term x) (pp_atomic y) 89 | | Id (_,x,y) -> sprintf "%s = %s" (pp_term x) (pp_term y) 90 | | J {mot = _; body = (a,case) ; scrut} -> 91 | sprintf "match %s with refl %s ⇒ %s" (pp_atomic scrut) a (pp_term case) 92 | | Refl x -> sprintf "refl %s" (pp_atomic x) 93 | | Let ((x,e1),e2) -> sprintf "let %s = %s in %s" x (pp_term e1) (pp_term e2) 94 | | RecordTy (f::fs) -> "Σ "^pp_record ":" (f::fs) 95 | | Record (f::fs) -> "σ "^pp_record "⇒" (f::fs) 96 | | _ -> pp_atomic e 97 | 98 | and pp_record sep = function 99 | | [] -> "" 100 | | [(f,(Record _ | RecordTy _ as t))] -> sprintf "%s %s %s" f sep (pp_atomic t) 101 | | [(f,t)] -> sprintf "%s %s %s" f sep (pp_term t) 102 | | (f,(Record _ | RecordTy _ as t))::fs -> sprintf "%s %s %s | %s" f sep (pp_atomic t) (pp_record sep fs) 103 | | (f,t)::fs -> sprintf "%s %s %s | %s" f sep (pp_term t) (pp_record sep fs) 104 | 105 | and pp_args = function 106 | | [] -> "" 107 | | [x] -> pp_atomic x 108 | | x::xs -> pp_atomic x ^ " " ^ pp_args xs 109 | 110 | and pp_arms = function 111 | | [] -> "" 112 | | arm::arms -> sprintf "%s %s" (pp_arm arm) (pp_arms arms) 113 | 114 | and pp_arm (con,(args,arm)) = 115 | match args with 116 | | [] -> sprintf "| %s ⇒ %s" con (pp_term arm) 117 | | _ -> sprintf "| %s %s ⇒ %s" con (pp_arm_args args) (pp_term arm) 118 | 119 | and pp_arm_arg = function 120 | | `Arg x -> x 121 | | `Rec (x,r) -> sprintf "(%s / %s)" x r 122 | 123 | and pp_arm_args = function 124 | | [] -> "" 125 | | [x] -> pp_arm_arg x 126 | | x::xs -> pp_arm_arg x ^ " " ^ pp_arm_args xs 127 | 128 | and pp_atomic (e : t) : string = 129 | match e with 130 | | Var x -> x 131 | | Hole {name;_} -> name 132 | | U Omega -> "Type^ω" 133 | | U (Const 0) -> "Type" 134 | | U (Const i) -> sprintf "Type^%i" i 135 | | Pair (e1,e2) -> sprintf "(%s,%s)" (pp_term e1) (pp_term e2) 136 | | Fst e -> sprintf "%s.1" (pp_atomic e) 137 | | Snd e -> sprintf "%s.2" (pp_atomic e) 138 | | Proj (f,t) -> sprintf "%s.%s" (pp_atomic t) f 139 | | Data {name ; params = []} -> name 140 | | Intro {name ; args = []} -> name 141 | | Record [] -> "struct" 142 | | RecordTy [] -> "sig" 143 | | _ -> sprintf "(%s)" (pp_term e) 144 | 145 | let show = pp_term 146 | 147 | 148 | let (++) m (key,data) = String.Map.set m ~key ~data 149 | 150 | let rec equal (i : int) (g1 : int String.Map.t) (e1 : t) (g2 : int String.Map.t) (e2 : t) : bool = 151 | match e1,e2 with 152 | | Var x,Var y -> 153 | begin 154 | match String.Map.find g1 x,String.Map.find g2 y with 155 | | Some i, Some j -> i = j 156 | | None,None -> String.equal x y 157 | | _ -> false 158 | end 159 | | Lift l1,Lift l2 -> l1.lvl = l2.lvl && String.equal l1.name l2.name 160 | | Ap (e1,e2),Ap (e1',e2') -> 161 | equal i g1 e1 g2 e1' && equal i g1 e2 g2 e2' 162 | | Lam (x,e), Lam (y,e') -> 163 | equal (i+1) (g1 ++ (x,i)) e (g2 ++ (y,i)) e' 164 | | Pi ((x,t),e),Pi ((y,t'),e') | Sg ((x,t),e),Sg ((y,t'),e') | Let ((x,t),e),Let ((y,t'),e') -> 165 | equal i g1 t g2 t' && equal (i+1) (g1 ++ (x,i)) e (g2 ++ (y,i)) e' 166 | | Pair (x,y), Pair (x',y') -> 167 | equal i g1 x g2 x' && equal i g1 y g2 y' 168 | | U Omega, U Omega -> true 169 | | U Const i, U Const j -> i = j 170 | | Refl e, Refl e' | Fst e, Fst e' | Snd e, Snd e' -> 171 | equal i g1 e g2 e' 172 | | Id (t,e1,e2), Id (t',e1',e2') -> 173 | equal i g1 t g2 t' && equal i g1 e1 g2 e1' && equal i g1 e2 g2 e2' 174 | | J {mot = (x,y,z,mot) ; body = (a,case) ; scrut = scrut},J {mot = (x',y',z',mot') ; body = (a',case') ; scrut = scrut'} -> 175 | equal (i+3) (g1 ++ (x,i) ++ (y,i+1) ++ (z,i+2)) mot (g2 ++ (x',i) ++ (y',i+1) ++ (z',i+2)) mot' && 176 | equal (i+1) (g1 ++ (a,i)) case (g2 ++ (a',i)) case' && 177 | equal i g1 scrut g2 scrut' 178 | | Data d, Data d' -> String.equal d.name d'.name && List.equal (fun e1 e2 -> equal i g1 e1 g2 e2) d.params d'.params 179 | | Intro con, Intro con' -> String.equal con.name con'.name && List.equal (fun e1 e2 -> equal i g1 e1 g2 e2) con.args con'.args 180 | | Elim e, Elim e' -> 181 | let (x,m),(x',m') = e.mot,e'.mot in 182 | equal (i+1) (g1 ++ (x,i)) m (g2 ++ (x',i)) m' && 183 | equal i g1 e.scrut g2 e'.scrut && 184 | begin 185 | match List.for_all2 ~f:(fun (con1,(args1,arm1)) (con2,(args2,arm2)) -> 186 | String.equal con1 con2 && equal_arm i g1 (flatten_arm_args args1,arm1) g2 (flatten_arm_args args2,arm2)) e.arms e'.arms with 187 | | Ok b -> b 188 | | _ -> false 189 | end 190 | | Record [], Record [] 191 | | RecordTy [], RecordTy [] -> true 192 | | RecordTy ((f1,tp1)::fs1), RecordTy ((f2,tp2)::fs2) -> String.equal f1 f2 && equal i g1 tp1 g2 tp2 && equal (i+1) (g1++(f1,i)) (RecordTy fs1) (g2++(f2,i)) (RecordTy fs2) 193 | | Record ((f1,tm1)::fs1), Record ((f2,tm2)::fs2) -> String.equal f1 f2 && equal i g1 tm1 g2 tm2 && equal i g1 (Record fs1) g2 (Record fs2) 194 | | Proj (f1,e1),Proj (f2,e2) -> String.equal f1 f2 && equal i g1 e1 g2 e2 195 | | Hole h1, Hole h2 -> String.equal h1.name h2.name && equal i g1 h1.tp g2 h2.tp 196 | | _ -> false 197 | 198 | and equal_arm i g1 (args1,arm1) g2 (args2,arm2) = 199 | match args1,args2 with 200 | | [],[] -> equal i g1 arm1 g2 arm2 201 | | arg1::args1,arg2::args2 -> equal_arm (i+1) (g1++(arg1,i)) (args1,arm1) (g2++(arg2,i)) (args2,arm2) 202 | | _ -> false 203 | 204 | 205 | let subst (sub : t) (fr : t) (e : t) : t = 206 | let rec go i g e = if equal i g e String.Map.empty fr then sub else 207 | match e with 208 | | Ap (e1,e2) -> Ap (go i g e1,go i g e2) 209 | | Lam (x,e) -> Lam (x,go (i+1) (g++(x,i)) e) 210 | | Pi ((x,d),r) -> Pi ((x,go i g d),go (i+1) (g++(x,i)) r) 211 | | Sg ((x,d),r) -> Sg ((x,go i g d),go (i+1) (g++(x,i)) r) 212 | | Fst e -> Fst (go i g e) 213 | | Snd e -> Snd (go i g e) 214 | | Let ((x,d),r) -> Let ((x,go i g d),go (i+1) (g++(x,i)) r) 215 | | Pair (e1,e2) -> Pair (go i g e1,go i g e2) 216 | | Refl e -> Refl (go i g e) 217 | | Hole {name ; tp} -> Hole {name ; tp = go i g tp} 218 | | Id (a,m,n) -> Id (go i g a,go i g m,go i g n) 219 | | J { mot = (x,y,p,m) ; body = (z,e) ; scrut} -> J {mot = (x,y,p,go (i+3) (g++(x,i)++(y,i+1)++(p,i+2)) m) ; body = (z,go (i+1) (g++(z,i)) e) ; scrut = go i g scrut} 220 | | Intro {name;args} -> Intro {name ; args = List.map ~f:(go i g) args} 221 | | Data {name;params} -> Data {name ; params = List.map ~f:(go i g) params} 222 | | Elim {mot = (x,m) ; arms ; scrut} -> 223 | Elim {mot = (x,go (i+1) (g++(x,i)) m) ; scrut = go i g scrut ; arms = List.map ~f:(fun (con,(vs,arm)) -> (con,(vs,go_arm i g (flatten_arm_args vs) arm))) arms} 224 | | RecordTy fs -> RecordTy (go_fields i g fs) 225 | | Record fs -> Record (List.map ~f:(fun (f,tm) -> (f,go i g tm)) fs) 226 | | Proj (f,e) -> Proj (f,go i g e) 227 | | Var x -> Var x 228 | | Lift x -> Lift x 229 | | U l -> U l 230 | 231 | and go_arm i g args arm = 232 | match args with 233 | | [] -> go i g arm 234 | | x::xs -> go_arm (i+1) (g++(x,i)) xs arm 235 | 236 | and go_fields i g fs = 237 | match fs with 238 | | [] -> [] 239 | | (f,t)::fs -> (f,go i g t)::go_fields (i+1) (g++(f,i)) fs 240 | 241 | in go 0 String.Map.empty e 242 | 243 | 244 | 245 | let rec to_concrete (e : t) : Concrete_syntax.t = Mark.naked @@ to_concrete_ e 246 | 247 | and to_concrete_ (e : t) : Concrete_syntax.t_ = let open Concrete_syntax in 248 | match e with 249 | | Var x -> Var x 250 | | Lift {name ; lvl} -> Lift {name ; lvl} 251 | | U i -> U i 252 | | Pi ((x,d),r) -> Pi ([(x,to_concrete d)],to_concrete r) 253 | | Lam (x,e) -> Lam ([x],to_concrete e) 254 | | Ap (f,e) -> Spine (to_concrete f,Snoc (Nil,to_concrete e)) 255 | | Sg ((x,d),r) -> Sg ([(x,to_concrete d)],to_concrete r) 256 | | Pair (x,y) -> Tuple [to_concrete x;to_concrete y] 257 | | Fst p -> Fst (to_concrete p) 258 | | Snd p -> Snd (to_concrete p) 259 | | Data {name ; params} -> Spine (to_concrete (Var name),params |> List.map ~f:to_concrete |> list_to_spine) 260 | | Intro {name ; args} -> Spine (to_concrete (Var name),args |> List.map ~f:to_concrete |> list_to_spine) 261 | | Elim {mot = (x,m) ; scrut ; arms} -> Elim {mot = Some (x,to_concrete m) ; scrut = to_concrete scrut ; arms = List.map ~f:(fun (con,(vs,arm)) -> (con,(vs,to_concrete arm))) arms} 262 | | RecordTy fs -> RecordTy {extends = [] ; fields = List.map ~f:(fun (f,tp) -> (f,to_concrete tp)) fs} 263 | | Record fs -> Record {extends = [] ; fields = List.map ~f:(fun (f,tm) -> (f,to_concrete tm)) fs} 264 | | Proj (f,e) -> Proj (f,to_concrete e) 265 | | Id (a,m,n) -> Id (to_concrete a,to_concrete m,to_concrete n) 266 | | Refl _ -> Refl 267 | | J {mot = (x,y,p,m) ; body = (z,e) ; scrut} -> J {mot = Some (x,y,p,to_concrete m) ; body = (z,to_concrete e) ; scrut = to_concrete scrut} 268 | | Let ((x,d),r) -> Let ((x,to_concrete d),to_concrete r) 269 | | Hole {name;_} -> Hole name --------------------------------------------------------------------------------