├── dune-project ├── lib └── combi │ ├── dune │ ├── parser.mli │ └── parser.ml ├── examples ├── empty.pure ├── U.pure ├── stlc.pure ├── F.pure ├── Fw+.pure ├── Fw.pure ├── coc.pure └── coc-unicode.pure ├── .gitignore ├── dune ├── statics.mli ├── lang_parser.mli ├── dynamics.mli ├── pure.mli ├── prim_parser.mli ├── pure.ml ├── prim_parser.ml ├── lang_parser.ml ├── statics.ml ├── repl.ml ├── README.md └── dynamics.ml /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.5) 2 | -------------------------------------------------------------------------------- /lib/combi/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name COMBI)) 3 | -------------------------------------------------------------------------------- /examples/empty.pure: -------------------------------------------------------------------------------- 1 | %SORTS 2 | %AXIOMS 3 | %RULES 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | pure 4 | test.pure 5 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name repl) 3 | (libraries COMBI)) 4 | -------------------------------------------------------------------------------- /examples/U.pure: -------------------------------------------------------------------------------- 1 | %SORTS * | □ | △ 2 | %AXIOMS * : □ | □ : △ 3 | %RULES *,*,* | □,*,* | □,□,□ | △,*,* | △,□,□ -------------------------------------------------------------------------------- /statics.mli: -------------------------------------------------------------------------------- 1 | 2 | module Make (T : Pure.THEORY) : 3 | sig 4 | exception TypeError of string 5 | val synthtype : Pure.term Pure.Context.t * Pure.term Pure.Context.t -> Pure.term -> Pure.term 6 | end 7 | -------------------------------------------------------------------------------- /examples/stlc.pure: -------------------------------------------------------------------------------- 1 | %SORTS <> | Unit | Void | Type 2 | %AXIOMS <> : Unit | Unit : Type | Void : Type | Type : Type 3 | %RULES Type,Type,Type 4 | 5 | let id-unit : Unit -> Unit = \(x) x 6 | 7 | let id-void : Void -> Void = \(x) x 8 | 9 | -------------------------------------------------------------------------------- /lang_parser.mli: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Make (P : Prim_parser.S) (T : Pure.THEORY) : 4 | sig 5 | type cmd = 6 | | EXP of Pure.term 7 | | DEC of string * Pure.term 8 | 9 | val exp : Pure.term P.parser 10 | val dec : (string * Pure.term) P.parser 11 | val prgm : (string * Pure.term) list P.parser 12 | val cmd : cmd P.parser 13 | 14 | end 15 | -------------------------------------------------------------------------------- /dynamics.mli: -------------------------------------------------------------------------------- 1 | 2 | 3 | val reset_var_stream : unit -> unit 4 | val instantiate : Pure.term -> Pure.term -> Pure.term 5 | val unbind : string -> Pure.term -> string * Pure.term 6 | val bind : string -> Pure.term -> Pure.term 7 | val subst : string -> Pure.term -> Pure.term -> Pure.term 8 | val beta : Pure.term Pure.Context.t -> Pure.term -> Pure.term 9 | val bind_up : Pure.term -> Pure.term 10 | val pretty : Pure.term -> string 11 | 12 | 13 | -------------------------------------------------------------------------------- /pure.mli: -------------------------------------------------------------------------------- 1 | 2 | type term = 3 | | F of string 4 | | B of int 5 | | APP of term * term 6 | | ALAM of (string * term) * term 7 | | LAM of string * term 8 | | PI of (string * term) * term 9 | | SORT of string 10 | | ANNOT of term * term 11 | 12 | val alpha_eq : term * term -> bool 13 | 14 | module Context : Map.S with type key = string 15 | 16 | val (++) : 'a Context.t -> (string * 'a) -> 'a Context.t 17 | 18 | val to_string : term -> string 19 | 20 | module type THEORY = 21 | sig 22 | val sorts : string list 23 | val axioms : (string * string) list 24 | val rules : (string * string * string) list 25 | end 26 | -------------------------------------------------------------------------------- /examples/F.pure: -------------------------------------------------------------------------------- 1 | %SORTS Type | Kind 2 | %AXIOMS Type : Kind 3 | %RULES Type,Type,Type | Kind,Type,Type 4 | 5 | let Nat : Type = \/(A : Type) (A -> A) -> A -> A 6 | 7 | let Nat-elim : Nat -> \/(A : Type) (A -> A) -> A -> A = 8 | \(x) x 9 | 10 | let 0 : Nat = \(_ f x) x 11 | 12 | let Z : Nat = 0 13 | 14 | let S : Nat -> Nat = \(n A f x) f (n A f x) 15 | 16 | let 1 : Nat = S 0 17 | 18 | let 2 : Nat = S 1 19 | 20 | let 3 : Nat = S 2 21 | 22 | let + : Nat -> Nat -> Nat = 23 | \(m n A f x) m A f (n A f x) 24 | 25 | let * : Nat -> Nat -> Nat = 26 | \(m n) Nat-elim m Nat (+ n) 0 27 | 28 | let ^ : Nat -> Nat -> Nat = 29 | \(m n) Nat-elim n Nat (* m) 1 30 | -------------------------------------------------------------------------------- /prim_parser.mli: -------------------------------------------------------------------------------- 1 | 2 | module type S = 3 | sig 4 | include COMBI.Parser.S 5 | exception ParseError 6 | val pragmas : (string list * (string * string) list * (string * string * string) list) parser 7 | val ignore : unit parser 8 | val paren : 'a parser -> 'a parser 9 | val pre : 'a parser -> 'a parser 10 | val post : 'a parser -> 'a parser 11 | val symbol : string -> string parser 12 | val variable : string parser 13 | val bind_fold : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b 14 | val annotated_bind_fold : (('a * 'b) * 'c -> 'c) -> 'a list * 'b -> 'c -> 'c 15 | val multi_bind : (('a * 'b) * 'c -> 'c) -> ('a list * 'b) list -> 'c -> 'c 16 | end 17 | 18 | module Make (P : COMBI.Parser.S) : S with type 'a m = 'a P.m 19 | -------------------------------------------------------------------------------- /examples/Fw+.pure: -------------------------------------------------------------------------------- 1 | %SORTS Type | Kind | Sort 2 | %AXIOMS Type : Kind | Kind : Sort 3 | %RULES Type,Type,Type | Kind,Type,Type | Kind,Kind,Kind | Sort,Sort,Sort | Sort,Kind,Kind 4 | 5 | 6 | let && : Kind -> Kind -> Kind = 7 | \(A B) \/(C : Kind) (A -> B -> C) -> C 8 | 9 | let tPair : \/(A B : Kind) A -> B -> && A B = 10 | \(_ _ x y)\(_ e) e x y 11 | 12 | let tFst : \/(A B : Kind) && A B -> A = 13 | \(A _ p) p A (\(x _) x) 14 | 15 | let tSnd : \/(A B : Kind) && A B -> B = 16 | \(_ B p) p B (\(_ y) y) 17 | 18 | 19 | let & : Type -> Type -> Type = 20 | \(A B) \/(C : Type) (A -> B -> C) -> C 21 | 22 | let pair : \/(A B : Type) A -> B -> & A B = 23 | \(_ _ x y)\(_ e) e x y 24 | 25 | let fst : \/(A B : Type) & A B -> A = 26 | \(A _ p) p A (\(x _) x) 27 | 28 | let snd : \/(A B : Type) & A B -> B = 29 | \(_ B p) p B (\(_ y) y) 30 | -------------------------------------------------------------------------------- /examples/Fw.pure: -------------------------------------------------------------------------------- 1 | %SORTS Type | Kind 2 | %AXIOMS Type : Kind 3 | %RULES Type,Type,Type | Kind,Type,Type | Kind,Kind,Kind 4 | 5 | let T : Type = \/(A : Type) A -> A 6 | 7 | let <> : T = \(_ x) x 8 | 9 | let id = <> 10 | 11 | let >>> : \/(A B C : Type) (A -> B) -> (B -> C) -> A -> C = 12 | \(_ _ _ f g x) g (f x) 13 | 14 | 15 | let List : Type -> Type = \(A : Type)\/(B : Type) (A -> B -> B) -> B -> B 16 | 17 | let [] : \/(A : Type) List A = 18 | \(_)\(_ g z) z 19 | 20 | let cons : \/(A : Type) A -> List A -> List A = 21 | \(_ x xs)\(B g z) g x (xs B g z) 22 | 23 | 24 | let Exists : (Type -> Type) -> Type = 25 | \(P : Type -> Type) \/(B : Type) (\/(t:Type) P t -> B) -> B 26 | 27 | 28 | let Eq : Type -> Type -> Type = 29 | \(A B) \/(P : Type -> Type) P A -> P B 30 | 31 | let eq-refl : \/(A : Type) Eq A A = 32 | \(A P) id (P A) 33 | 34 | let eq-sym : \/(A B : Type) Eq A B -> Eq B A = 35 | \(A B eq) eq (\(t) Eq t A) (eq-refl A) 36 | 37 | let eq-trans : \/(A B C : Type) Eq A B -> Eq B C -> Eq A C = 38 | \(A B C eq1 eq2 P) >>> (P A) (P B) (P C) (eq1 P) (eq2 P) 39 | 40 | 41 | let & : Type -> Type -> Type = 42 | \(A B) \/(C : Type) (A -> B -> C) -> C 43 | 44 | let pair : \/(A B : Type) A -> B -> & A B = 45 | \(_ _ x y)\(_ e) e x y 46 | 47 | let fst : \/(A B : Type) & A B -> A = 48 | \(A _ p) p A (\(x _) x) 49 | 50 | let snd : \/(A B : Type) & A B -> B = 51 | \(_ B p) p B (\(_ y) y) 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /pure.ml: -------------------------------------------------------------------------------- 1 | 2 | type term = 3 | | F of string 4 | | B of int 5 | | APP of term * term 6 | | ALAM of (string * term) * term 7 | | LAM of string * term 8 | | PI of (string * term) * term 9 | | SORT of string 10 | | ANNOT of term * term 11 | 12 | 13 | let rec alpha_eq = function 14 | | F x, F y -> x = y 15 | | B i, B j -> i = j 16 | | APP (m,n), APP (m',n') -> alpha_eq (m,m') && alpha_eq (n,n') 17 | | SORT s, SORT s' -> s = s' 18 | | ALAM ((_,t),e), ALAM ((_,t'),e') -> alpha_eq (t,t') && alpha_eq (e,e') 19 | | LAM (_,e), LAM (_,e') 20 | | ALAM (_,e), LAM (_,e') 21 | | LAM (_,e), ALAM (_,e') -> alpha_eq (e,e') 22 | | PI ((_,t),e), PI ((_,t'),e') -> alpha_eq (t,t') && alpha_eq (e,e') 23 | | ANNOT (e,t), ANNOT (e',t') -> alpha_eq (e,e') && alpha_eq (t,t') 24 | | _ -> false 25 | 26 | module Context = Map.Make (String) 27 | let (++) g (x,t) = Context.add x t g 28 | 29 | let rec to_string = function 30 | | F x -> "F " ^ x 31 | | B i -> "B " ^ Int.to_string i 32 | | APP (m,n) -> "APP ("^to_string m^") ("^to_string n^")" 33 | | ALAM ((x,t),e) -> "LAM ("^x^": "^to_string t^") ("^to_string e^")" 34 | | LAM (x,e) -> "LAM ("^x^") "^to_string e 35 | | PI ((x,t),e) -> "PI ("^x^": "^to_string t^") ("^to_string e^")" 36 | | SORT s -> "SORT "^s 37 | | ANNOT (e,t) -> "("^to_string e^" : "^to_string t^")" 38 | 39 | module type THEORY = 40 | sig 41 | val sorts : string list 42 | val axioms : (string * string) list 43 | val rules : (string * string * string) list 44 | end 45 | -------------------------------------------------------------------------------- /prim_parser.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | include COMBI.Parser.S 4 | exception ParseError 5 | val pragmas : (string list * (string * string) list * (string * string * string) list) parser 6 | val ignore : unit parser 7 | val paren : 'a parser -> 'a parser 8 | val pre : 'a parser -> 'a parser 9 | val post : 'a parser -> 'a parser 10 | val symbol : string -> string parser 11 | val variable : string parser 12 | val bind_fold : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b 13 | val annotated_bind_fold : (('a * 'b) * 'c -> 'c) -> 'a list * 'b -> 'c -> 'c 14 | val multi_bind : (('a * 'b) * 'c -> 'c) -> ('a list * 'b) list -> 'c -> 'c 15 | end 16 | 17 | module Make (P : COMBI.Parser.S) = 18 | struct 19 | 20 | include P 21 | 22 | exception ParseError 23 | let ignore = consume @@ many whitespace 24 | let pre p = ignore *> p 25 | let post p = p <* ignore 26 | 27 | let symbol s = post (string s) 28 | 29 | let illegal_chr = ['\\';'(';')';' ';'\t';'\n';'%';',';':';'='] 30 | let illegal_str = ["let";"->";"→";"∀";"λ";"Π"] 31 | let variable = 32 | post (let* v = ident illegal_chr in if List.mem v illegal_str then fail else return v) 33 | 34 | let paren x = between (symbol "(") (symbol ")") x 35 | 36 | let annotated_bind_fold c (xs,t) = List.fold_right (fun x e' -> c ((x,t),e')) xs 37 | 38 | let bind_fold c = List.fold_right (fun x e' -> c (x,e')) 39 | 40 | let multi_bind c = List.fold_right (annotated_bind_fold c) 41 | 42 | 43 | let pair p s = (fun x y -> (x,y)) <$> (p <* s) <*> p 44 | let triple p s = (fun x y z -> (x,y,z)) <$> (p <* s) <*> (p <* s) <*> p 45 | let ax = pair variable (symbol ":") 46 | let rule = triple variable (symbol ",") 47 | let sorts = symbol "%SORTS" *> sepby variable (symbol "|") 48 | let axioms = symbol "%AXIOMS" *> sepby ax (symbol "|") 49 | let rules = symbol "%RULES" *> sepby rule (symbol "|") 50 | 51 | let pragmas = pre ((fun x y z -> (x,y,z)) <$> sorts <*> axioms <*> rules) 52 | 53 | end 54 | -------------------------------------------------------------------------------- /lang_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | module Make (P : Prim_parser.S) (T : Pure.THEORY) = 3 | struct 4 | 5 | open Pure 6 | open P 7 | 8 | let arrow = symbol "->" <|> symbol "→" 9 | let forall = symbol "\\/" <|> symbol "∀" <|> symbol "Π" 10 | let lambda = symbol "\\" <|> symbol "λ" 11 | 12 | let rec expr i = chainr1 expr1 (arrow *> return (fun t1 t2 -> PI (("",t1),t2))) i 13 | 14 | and expr1 i = chainl1 expr2 (return (fun m n -> APP (m,n))) i 15 | 16 | and expr2 i = (annot <|> sort <|> var <|> lam <|> alam <|> pi <|> (fun i -> paren expr i)) i 17 | 18 | 19 | and annot i = paren ((fun e t -> ANNOT (e,t)) <$> 20 | expr <*> 21 | symbol ":" *> 22 | expr) i 23 | 24 | and sort i = ((fun s -> SORT s) <$> 25 | let* v = variable in 26 | if List.mem v T.sorts 27 | then return v 28 | else fail) i 29 | 30 | and var i = ((fun v -> F v) <$> variable) i 31 | 32 | and lam i = (bind_fold (fun (x,e) -> LAM (x,e)) <$> 33 | lambda *> 34 | paren (many1 variable) <*> 35 | expr) i 36 | 37 | and alam i = (multi_bind (fun (x,e) -> ALAM (x,e)) <$> 38 | lambda *> 39 | many1 (paren args) <*> 40 | expr) i 41 | 42 | 43 | and pi i = (multi_bind (fun (x,e) -> PI (x,e)) <$> 44 | forall *> 45 | many1 (paren args) <*> 46 | expr) i 47 | 48 | and args i = ((fun xs t -> xs,t) <$> 49 | many1 variable <*> 50 | symbol ":" *> 51 | expr) i 52 | 53 | let plain_dec i = ((fun x y -> (x,y)) <$> 54 | symbol "let" *> 55 | variable <*> 56 | symbol "=" *> 57 | expr) i 58 | 59 | let annot_dec i = ((fun x t e -> (x,ANNOT (e,t))) <$> 60 | symbol "let" *> 61 | variable <*> 62 | symbol ":" *> 63 | expr <*> 64 | symbol "=" *> 65 | expr) i 66 | 67 | let dec = pre (annot_dec <|> plain_dec) 68 | let exp = pre expr 69 | let prgm = many dec 70 | 71 | type cmd = 72 | | EXP of term 73 | | DEC of string * term 74 | 75 | let cmd = ((fun (x,y) -> DEC (x,y)) <$> dec) <|> ((fun x -> EXP x) <$> exp) 76 | end 77 | -------------------------------------------------------------------------------- /lib/combi/parser.mli: -------------------------------------------------------------------------------- 1 | module type BASE = 2 | sig 3 | type 'a t 4 | val return : 'a -> 'a t 5 | val bind : 'a t -> ('a -> 'b t) -> 'b t 6 | val fail : 'a t 7 | val choice : 'a t -> 'a t -> 'a t 8 | end 9 | 10 | module type S = 11 | sig 12 | type 'a m 13 | type 'a t = char list -> ('a * char list) m 14 | type 'a parser = 'a t 15 | include BASE with type 'a t := 'a parser 16 | 17 | val (<$>) : ('a -> 'b) -> 'a parser -> 'b parser 18 | val (<$) : 'a -> 'b parser -> 'a parser 19 | val ($>) : 'a parser -> 'b -> 'b parser 20 | val (<*>) : ('a -> 'b) parser -> 'a parser -> 'b parser 21 | val (<* ) : 'a parser -> 'b parser -> 'a parser 22 | val ( *>) : 'a parser -> 'b parser -> 'b parser 23 | val lift2 : ('a -> 'b -> 'c) -> 'a parser -> 'b parser -> 'c parser 24 | val (>>=) : 'a parser -> ('a -> 'b parser) -> 'b parser 25 | val (<|>) : 'a parser -> 'a parser -> 'a parser 26 | 27 | val (let*) : 'a parser -> ('a -> 'b parser) -> 'b parser 28 | val item : char parser 29 | val sat : (char -> bool) -> char parser 30 | val letter : char parser 31 | val lower : char parser 32 | val upper : char parser 33 | val digit : char parser 34 | val alphanum : char parser 35 | val whitespace : char parser 36 | val char : char -> char parser 37 | val char_list : char list -> char list parser 38 | val string : string -> string parser 39 | val to_string : char list parser -> string parser 40 | val nat : int parser 41 | val int : int parser 42 | val many : 'a parser -> 'a list parser 43 | val many1 : 'a parser -> 'a list parser 44 | val sepby : 'a parser -> 'sep parser -> 'a list parser 45 | val sepby1 : 'a parser -> 'sep parser -> 'a list parser 46 | val between : 'dl parser -> 'dr parser -> 'a parser -> 'a parser 47 | val chainl : 'a parser -> ('a -> 'a -> 'a) parser -> 'a -> 'a parser 48 | val chainl1 : 'a parser -> ('a -> 'a -> 'a) parser -> 'a parser 49 | val chainr : 'a parser -> ('a -> 'a -> 'a) parser -> 'a -> 'a parser 50 | val chainr1 : 'a parser -> ('a -> 'a -> 'a) parser -> 'a parser 51 | val postfix : 'a parser -> ('a -> 'a) parser -> 'a parser 52 | val prefix : ('a -> 'a) parser -> 'a parser -> 'a parser 53 | val consume : 'a parser -> unit parser 54 | val ident : char list -> string parser 55 | val (%) : 'a parser -> string -> ('a * char list) m 56 | end 57 | 58 | module OptionBase : BASE with type 'a t = 'a option 59 | 60 | module ListBase : BASE with type 'a t = 'a list 61 | 62 | module Make (M : BASE) : S with type 'a m = 'a M.t 63 | 64 | 65 | -------------------------------------------------------------------------------- /statics.ml: -------------------------------------------------------------------------------- 1 | module Make (T : Pure.THEORY) = 2 | struct 3 | 4 | open Pure 5 | open Dynamics 6 | 7 | exception TypeError of string 8 | 9 | let rec check_A s = function 10 | | [] -> raise (TypeError ("The sort '"^s^"' has no type. Check axioms?")) 11 | | (s1,s2)::ss -> if s = s1 then SORT s2 else check_A s ss 12 | 13 | let rec check_R (s1,s2) = function 14 | | [] -> 15 | raise (TypeError 16 | ("Illegal Pi Type: value of type '"^s2^"' cannot depend on value of type '"^s1^"'")) 17 | | (s1',s2',s3)::rs -> if s1 = s1' && s2 = s2' then SORT s3 else check_R (s1,s2) rs 18 | 19 | let (++) (g,d) kv = (g ++ kv,d) 20 | 21 | let go = Fun.const () 22 | 23 | let rec synth ((g,d) as c) = function 24 | | SORT s -> check_A s T.axioms 25 | | F x -> 26 | begin 27 | match Context.find_opt x g with 28 | | Some a -> go @@ synth c a; a 29 | | _ -> raise (TypeError ("Unbound var: '"^x^"'")) 30 | end 31 | | B _ -> raise (Failure "Should never be type checking a bound var") 32 | | ANNOT (e,t) -> go @@ synth c t; go @@ check c (e,beta d t);t 33 | | PI ((x,t),e) -> 34 | let (f,e') = unbind x e in 35 | begin 36 | match beta d @@ synth c t with 37 | | SORT s1 -> 38 | begin 39 | match beta d @@ synth (c ++ (f,t)) e' with 40 | | SORT s2 -> go @@ check_R (s1,s2) T.rules; SORT s2 41 | | x -> raise (TypeError ("'"^pretty x^"' must be a sort")) 42 | end 43 | | x -> raise (TypeError ("'"^pretty x^"' must be a sort")) 44 | end 45 | | APP (m,n) -> 46 | begin 47 | match beta d @@ synth c m with 48 | | PI ((x,t),e) -> let (f,e') = unbind x e in 49 | go @@ check c (n,t); subst f n e' 50 | | t -> raise (TypeError ("In expresion '"^pretty (APP (m,n))^"', '"^pretty m^"' has type '"^pretty t^"'. It is not a function, it cannot be applied")) 51 | end 52 | | ALAM ((x,t),e) -> 53 | let (f,e') = unbind x e in 54 | let b = synth (c ++ (f,t)) e' in 55 | let r = PI ((x,t),bind f b) in 56 | go @@ synth c r; r 57 | 58 | | x -> raise (TypeError ("Cannot infer type for: '"^pretty x^"'")) 59 | 60 | 61 | and check ((_,d) as c) = function 62 | | LAM (x,e), (PI ((_,a),b) as t) -> let (f,e') = unbind x e in 63 | let b' = instantiate (F f) b in 64 | go @@ check (c++(f,a)) (e',b'); go @@ synth c t; t 65 | | m,b -> go @@ synth c b; let a = synth c m in if alpha_eq (beta d a, beta d b) then b 66 | else raise (TypeError ("Expected '"^pretty m^"' to have type '"^pretty b^"', but it has type '"^pretty a^"'")) 67 | 68 | let synthtype = synth 69 | 70 | end 71 | -------------------------------------------------------------------------------- /repl.ml: -------------------------------------------------------------------------------- 1 | 2 | module PP = Prim_parser.Make (COMBI.Parser.Make (COMBI.Parser.OptionBase)) 3 | open PP 4 | 5 | let parse p s = 6 | match p % s with 7 | | Some (t,[]) -> t 8 | | _ -> raise ParseError 9 | 10 | let parse' p s = 11 | match p s with 12 | | Some (t,[]) -> t 13 | | _ -> raise ParseError 14 | 15 | 16 | module MkRepl (T : Pure.THEORY) = 17 | struct 18 | module S = Statics.Make (T) 19 | open S 20 | open Lang_parser.Make (PP) (T) 21 | open Pure 22 | open Dynamics 23 | 24 | let prgm = prgm 25 | 26 | let fold_decs = 27 | List.fold_left 28 | (fun (g,d) (x,e) -> 29 | let e = bind_up e in 30 | let t = synthtype (g,d) e in 31 | let e' = beta d e in 32 | print_endline (x ^ " : " ^ pretty t); 33 | print_string "\n"; 34 | (g++(x,t),d++(x,e')) 35 | ) (Context.empty,Context.empty) 36 | 37 | 38 | let rec repl (g,d) = 39 | try 40 | print_string "-- "; 41 | let s = Stdlib.read_line () in 42 | if s = "" then repl (g,d) else 43 | match parse cmd s with 44 | | EXP e -> 45 | begin 46 | let e = bind_up e in 47 | let t = synthtype (g,d) e in 48 | let e' = beta d e in 49 | print_endline ("_ : " ^ pretty t); 50 | print_endline ("_ = " ^ pretty e'); 51 | print_string "\n"; 52 | repl (g,d) 53 | end 54 | | DEC (x,e) -> 55 | let e = bind_up e in 56 | let t = synthtype (g,d) e in 57 | let e' = beta d e in 58 | let (g',d') = (g++(x,t),d++(x,e')) in 59 | print_endline (x ^" : " ^ pretty t); 60 | print_endline (x ^ " = " ^ pretty e'); 61 | print_string "\n"; 62 | repl (g',d') 63 | with | ParseError -> print_endline "Parse Error"; repl (g,d) 64 | | TypeError e -> print_endline ("Type Error: "^e); repl (g,d) 65 | end 66 | 67 | 68 | let read_file f = 69 | let ch = open_in f in 70 | let s = really_input_string ch (in_channel_length ch) in 71 | close_in ch; 72 | s 73 | 74 | let parse_theory f = 75 | let s = read_file f in 76 | match pragmas % s with 77 | | None -> raise (Failure "Missing SORTS, AXIOMS, or RULES") 78 | | Some ((sorts,axioms,rules),rest) -> 79 | let theory = 80 | (module struct 81 | let sorts = sorts 82 | let axioms = axioms 83 | let rules = rules 84 | end : Pure.THEORY) 85 | in (theory,rest) 86 | 87 | 88 | let _ = 89 | if Array.length Sys.argv < 2 then 90 | print_endline "Please provide file with SORTS, AXIOMS, RULES and optional definitions" 91 | else 92 | let file = Sys.argv.(1) in 93 | let (theory,txt) = parse_theory file in 94 | let module T = (val theory : Pure.THEORY) in 95 | let module Repl = MkRepl (T) in 96 | try 97 | let ds = parse' Repl.prgm txt in 98 | let (g,d) = Repl.fold_decs ds in 99 | Repl.repl (g,d) 100 | with | Repl.S.TypeError s -> print_endline ("Type Error: "^s) 101 | 102 | 103 | 104 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pure 2 | This is an interpreter for arbitrary pure type systems. Check [here](https://en.wikipedia.org/wiki/Pure_type_system) for a solid description. 3 | 4 | Pure uses bidirectional type checking, so it's typing rules are slightly different from the ones listed on wikipedia. Here are the typing rules, inspired by the recipe for bidirectionalization in the paper [Bidirectional Typechecking](https://arxiv.org/abs/1908.05839). 5 | 6 | ![Rules](https://i.imgur.com/je1Cumj.png) 7 | 8 | Oleg Grenrus has a [blog post](https://oleg.fi/gists/posts/2020-08-03-bidi-pts.html) on bidirectional type checking for pure type systems. I've only skimmed it, but we seem to have come up with pretty much the same set of rules. He goes somewhat deeper in exploring the idea than I do with Pure, however. 9 | 10 | ## Compiling 11 | 12 | Pure uses [Dune](https://github.com/ocaml/dune), which can be installed with `opam install dune`. 13 | 14 | To build the interpreter, run `dune build repl.exe`, and run the resulting file at `_build/default/repl.exe` with a `.pure` file as an argument. 15 | 16 | ## Using Pure 17 | 18 | The top of every `.pure` file must contain 3 interpreter pragmas: `%SORTS`, `%AXIOMS`, and `%RULES`. To use System F as an example: 19 | 20 | ``` 21 | %SORTS Type | Kind 22 | %AXIOMS Type : Kind 23 | %RULES Type,Type,Type | Kind,Type,Type 24 | ``` 25 | These define the system that the rest of the file will be type checked against. The rest of the file can be zero or more declarations. 26 | 27 | Declarations are in OCaml style, using `let` with an optional type annotation. 28 | 29 | Use of unicode characters in names and as alternatives to `\/`,`->`,and `\` is supported. 30 | ``` 31 | let id = \(A : Type)(x : A) x 32 | let id : \/(A : Type) A -> A = \(A)\(x) x 33 | let f : \/(A B : Type) (A -> A -> B) -> A -> A -> B = \(A B : Type)(f : A -> A -> B)(x y : A) f x y 34 | let g : \/(A B : Type) (A -> A -> B) -> A -> A -> B = \(_ _ f x y) f x y 35 | let ℕ : Type = ∀ (A : Type) (A → A) → A → A 36 | let Z : ℕ = λ(_ _ x) x 37 | ``` 38 | Lambda functions have optional type annotations on their arguments. If none are provided, Pure will try to infer the type of the function. 39 | A function declared at the top level with no annotations on it's arguments cannot have it's type inferred, so an annoation on the declaration becomes necessary. 40 | Notice how the type annotation on the declaration allows us to avoid giving names to the the type parameters of the lambda. 41 | In annoted lambdas and in pi types, arguments with the same type can be conviniently grouped together. In unannotated lambdas, all arguments can be grouped together. 42 | Once a file has been read, you'll be presented with a REPL. Here you can evaluate expressions and make new top level bindings. 43 | 44 | Check out the `examples` folder for more... examples. In `coc.pure`, I prove that 1 + 1 = 2 :) 45 | 46 | ## Some Well Known Pure Type Systems 47 | ### Simply Typed Lambda Calculus, with the unit type 48 | ``` 49 | %SORTS <> | Unit | Type 50 | %AXIOMS <> : Unit | Unit : Type 51 | %RULES Type,Type,Type 52 | ``` 53 | 54 | ### System F 55 | ``` 56 | %SORTS Type | Kind 57 | %AXIOMS Type : Kind 58 | %RULES Type,Type,Type | Kind,Type,Type 59 | ``` 60 | 61 | ### System Fω 62 | ``` 63 | %SORTS Type | Kind 64 | %AXIOMS Type : Kind 65 | %RULES Type,Type,Type | Kind,Type,Type | Kind,Kind,Kind 66 | ``` 67 | 68 | ### Calculus of Constructions 69 | ``` 70 | %SORTS Prop | Type 71 | %AXIOMS Prop : Type 72 | %RULES Prop,Prop,Prop | Prop,Type,Type | Type,Prop,Prop | Type,Type,Type 73 | ``` 74 | 75 | ### System U 76 | ``` 77 | %SORTS * | □ | △ 78 | %AXIOMS * : □ | □ : △ 79 | %RULES *,*,* | □,*,* | □,□,□ | △,*,* | △,□,□ 80 | ``` 81 | 82 | 83 | 84 | 85 | -------------------------------------------------------------------------------- /dynamics.ml: -------------------------------------------------------------------------------- 1 | 2 | open Pure 3 | 4 | let r = ref 0 5 | 6 | let fresh v = (r := !r + 1; v ^ Int.to_string (!r)) 7 | 8 | let reset_var_stream () = r := 0 9 | 10 | let instantiate y = 11 | let rec replace b = function 12 | | F x -> F x 13 | | B i when i = b -> y 14 | | B i -> B i 15 | | APP (m,n) -> APP (replace b m, replace b n) 16 | | ALAM ((x,t),e) -> ALAM ((x,replace b t), replace (b+1) e) 17 | | LAM (x,e) -> LAM (x,replace (b+1) e) 18 | | PI ((x,t),e) -> PI ((x,replace b t),replace (b+1) e) 19 | | SORT s -> SORT s 20 | | ANNOT (e,t) -> ANNOT (replace b e, replace b t) 21 | in replace 0 22 | 23 | let unbind x e = let f = fresh x in (f,instantiate (F f) e) 24 | 25 | let bind y = 26 | let rec replace b = function 27 | | F x when x = y -> B b 28 | | F x -> F x 29 | | B i -> B i 30 | | APP (m,n) -> APP (replace b m, replace b n) 31 | | ALAM ((x,t),e) -> ALAM ((x,replace b t),replace (b+1) e) 32 | | LAM (x,e) -> LAM (x,replace (b+1) e) 33 | | PI ((x,t),e) -> PI ((x,replace b t),replace (b+1) e) 34 | | SORT s -> SORT s 35 | | ANNOT (e,t) -> ANNOT (replace b e, replace b t) 36 | in replace 0 37 | 38 | let rec subst y w = function 39 | | F x when x = y -> w 40 | | F x -> F x 41 | | B i -> B i 42 | | APP (m,n) -> APP (subst y w m,subst y w n) 43 | | ALAM ((x,t),e) -> ALAM ((x,subst y w t),subst y w e) 44 | | LAM (x,e) -> LAM (x,subst y w e) 45 | | PI ((x,t),e) -> PI ((x,subst y w t),subst y w e) 46 | | SORT s -> SORT s 47 | | ANNOT (e,t) -> ANNOT (subst y w e, subst y w t) 48 | 49 | let paren s = "("^s^")" 50 | 51 | let rec binds y = function 52 | | B i when i = y -> true 53 | | B _ -> false 54 | | F _ -> false 55 | | APP (m,n) -> binds y m || binds y n 56 | | ALAM ((_,t),e) | PI ((_,t),e) -> binds y t || binds (y+1) e 57 | | LAM (_,e) -> binds (y+1) e 58 | | SORT _ -> false 59 | | ANNOT (e,t) -> binds y e || binds y t 60 | 61 | 62 | 63 | 64 | let rec free_in y = function 65 | | F x when x = y -> true 66 | | F _ -> false 67 | | B _ -> false 68 | | APP (m,n) -> free_in y m || free_in y n 69 | | ALAM ((_,t),e) | PI ((_,t),e) -> free_in y t || free_in y e 70 | | LAM (_,e) -> free_in y e 71 | | SORT _ -> false 72 | | ANNOT (e,t) -> free_in y e || free_in y t 73 | 74 | let pretty s = reset_var_stream (); 75 | let rec pretty = function 76 | | F x -> x 77 | | B _ -> raise (Failure "Shouldn't be printing bound vars") 78 | | SORT s -> s 79 | | ANNOT (e,t) -> paren (pretty e^" : "^pretty t) 80 | | APP (m,n) -> 81 | begin 82 | match (m,n) with 83 | | (_,APP _) | (_, ALAM _) | (_, LAM _) | (_,PI _) -> pretty m^" "^paren (pretty n) 84 | | (ALAM _,_) | (LAM _ , _ ) | (PI _, _) -> paren (pretty m)^" "^pretty n 85 | | _ -> pretty m^" "^pretty n 86 | end 87 | | ALAM ((x,t),e) -> 88 | let x' = if free_in x e then fresh x else x in 89 | "\\("^x'^":"^pretty t^") "^pretty (instantiate (F x') e) 90 | | LAM (x,e) -> 91 | let x' = if free_in x e then fresh x else x in 92 | "\\("^x'^") "^pretty (instantiate (F x') e) 93 | | PI ((x,t),e) -> 94 | let x' = if free_in x e then fresh x else x in 95 | if binds 0 e then "\\/("^x'^":"^pretty t^") "^pretty (instantiate (F x') e) 96 | else match t with 97 | | PI _ -> paren (pretty t)^" -> "^pretty (instantiate (F x') e) 98 | | _ -> pretty t^" -> "^pretty (instantiate (F x') e) 99 | 100 | in pretty s 101 | 102 | let rec beta g = function 103 | | F x -> Option.value (Context.find_opt x g) ~default:(F x) 104 | | B i -> B i 105 | | ANNOT (e,_) -> beta g e 106 | | LAM (x,e) -> let (f,e') = unbind x e in 107 | LAM (x,bind f (beta g e')) 108 | | ALAM ((x,t),e) -> let (f,e') = unbind x e in 109 | ALAM ((x,beta g t),bind f (beta g e')) 110 | | PI ((x,t),e) -> let (f,e') = unbind x e in 111 | PI ((x,beta g t),bind f (beta g e')) 112 | | SORT s -> SORT s 113 | | APP (m,n) -> 114 | match (beta g m, beta g n) with 115 | | (ALAM ((x,_),e),n') | (LAM (x,e),n') -> let (f,e') = unbind x e in beta (g++(f,n')) e' 116 | | (m',n') -> APP (m',n') 117 | 118 | let rec bind_up = function 119 | | F x -> F x 120 | | B i -> B i 121 | | APP (m,n) -> APP (bind_up m, bind_up n) 122 | | ALAM ((x,t),e) -> ALAM ((x,bind_up t), bind x (bind_up e)) 123 | | LAM (x,e) -> LAM (x, bind x (bind_up e)) 124 | | PI ((x,t),e) -> PI ((x,bind_up t), bind x (bind_up e)) 125 | | SORT s -> SORT s 126 | | ANNOT (e,t) -> ANNOT (bind_up e, bind_up t) 127 | 128 | 129 | 130 | 131 | -------------------------------------------------------------------------------- /examples/coc.pure: -------------------------------------------------------------------------------- 1 | %SORTS Prop | Type 2 | %AXIOMS Prop : Type 3 | %RULES Prop,Prop,Prop | Prop,Type,Type | Type,Prop,Prop | Type,Type,Type 4 | 5 | 6 | let T : Prop = 7 | \/(A : Prop) A -> A 8 | 9 | let <> : T = 10 | \(_ x) x 11 | 12 | let id : T = 13 | <> 14 | 15 | let F : Prop = 16 | \/(A : Prop) A 17 | 18 | 19 | let >>> : \/(A B C : Prop) (A -> B) -> (B -> C) -> A -> C = 20 | \(_ _ _ f g x) g (f x) 21 | 22 | 23 | let & : Prop -> Prop -> Prop = 24 | \(A B) \/(C : Prop) (A -> B -> C) -> C 25 | 26 | let pair : \/(A B : Prop) A -> B -> & A B = 27 | \(_ _ x y)\(_ e) e x y 28 | 29 | let fst : \/(A B : Prop) & A B -> A = 30 | \(A _ p) p A (\(x _) x) 31 | 32 | let snd : \/(A B : Prop) & A B -> B = 33 | \(_ B p) p B (\(_ y) y) 34 | 35 | 36 | let + : Prop -> Prop -> Prop = 37 | \(A B) \/(C : Prop) (A -> C) -> (B -> C) -> C 38 | 39 | let inl : \/(A B : Prop) A -> + A B = 40 | \(_ _ x)\(_ e _) e x 41 | 42 | let inr : \/(A B : Prop) B -> + A B = 43 | \(_ _ y)\(_ _ e) e y 44 | 45 | let case : \/(A B : Prop) + A B -> \/(C : Prop) (A -> C) -> (B -> C) -> C = 46 | \(_ _ s C e1 e2) s C e1 e2 47 | 48 | 49 | let curry : \/(A B C : Prop) (& A B -> C) -> A -> B -> C = 50 | \(A B _ f x y) f (pair A B x y) 51 | 52 | let uncurry : \/(A B C : Prop) (A -> B -> C) -> & A B -> C = 53 | \(A B _ f p) f (fst A B p) (snd A B p) 54 | 55 | 56 | let Sigma : \/(A : Prop) (A -> Prop) -> Prop = 57 | \(A P) \/(B : Prop) (\/(x:A) P x -> B) -> B 58 | 59 | let Exists = Sigma 60 | 61 | let dFst : \/(A : Prop)(P : A -> Prop) Sigma A P -> A = 62 | \(A _ s) s A (\(x _) x) 63 | 64 | 65 | 66 | let List : Prop -> Prop = \(A)\/(B : Prop) (A -> B -> B) -> B -> B 67 | 68 | let [] : \/(A : Prop) List A = 69 | \(_)\(_ g z) z 70 | 71 | let cons : \/(A : Prop) A -> List A -> List A = 72 | \(_ x xs)\(B g z) g x (xs B g z) 73 | 74 | 75 | let Exists-Prop : (Prop -> Prop) -> Prop = 76 | \(P) \/(B : Prop) (\/(t : Prop) P t -> B) -> B 77 | 78 | 79 | let Eq-Prop : Prop -> Prop -> Prop = 80 | \(A B) \/(P : Prop -> Prop) P A -> P B 81 | 82 | let eq-prop-refl : \/(A : Prop) Eq-Prop A A = 83 | \(A P) id (P A) 84 | 85 | let eq-prop-sym : \/(A B : Prop) Eq-Prop A B -> Eq-Prop B A = 86 | \(A B eq) eq (\(t) Eq-Prop t A) (eq-prop-refl A) 87 | 88 | let eq-prop-trans : \/(A B C : Prop) Eq-Prop A B -> Eq-Prop B C -> Eq-Prop A C = 89 | \(A B C eq1 eq2 P) >>> (P A) (P B) (P C) (eq1 P) (eq2 P) 90 | 91 | 92 | 93 | let Refl : (\/(A : Prop) A -> A -> Prop) -> Prop = 94 | \(R) \/(A : Prop)(x : A) R A x x 95 | 96 | let Sym : (\/(A : Prop) A -> A -> Prop) -> Prop = 97 | \(R) \/(A : Prop)(x y : A) R A x y -> R A y x 98 | 99 | let Trans : (\/(A : Prop) A -> A -> Prop) -> Prop = 100 | \(R) \/(A : Prop)(x y z : A) R A x y -> R A y z -> R A x z 101 | 102 | 103 | let Eq : \/(A : Prop) A -> A -> Prop = 104 | \(A x y) \/(P : A -> Prop) P x -> P y 105 | 106 | let eq-refl : Refl Eq = 107 | \(A x)\(P) id (P x) 108 | 109 | let eq-sym : Sym Eq = 110 | \(A x y eq)\(P) eq (\(z) P z -> P x) (eq-refl A x P) 111 | 112 | let eq-trans : Trans Eq = 113 | \(A x y z eq1 eq2)\(P) >>> (P x) (P y) (P z) (eq1 P) (eq2 P) 114 | 115 | 116 | let Nat : Prop = \/(A : Prop) (A -> A) -> A -> A 117 | 118 | let Nat-elim : Nat -> \/(A : Prop) (A -> A) -> A -> A = 119 | \(x) x 120 | 121 | let 0 : Nat = \(A f x) x 122 | 123 | let Z : Nat = 0 124 | 125 | let S : Nat -> Nat = \(n A f x) f (n A f x) 126 | 127 | let 1 : Nat = S 0 128 | let 2 : Nat = S 1 129 | let 3 : Nat = S 2 130 | let 4 : Nat = S 3 131 | let 5 : Nat = S 4 132 | let 6 : Nat = S 5 133 | let 7 : Nat = S 6 134 | let 8 : Nat = S 7 135 | let 9 : Nat = S 8 136 | 137 | let add : Nat -> Nat -> Nat = 138 | \(m n A f x) m A f (n A f x) 139 | 140 | let mul : Nat -> Nat -> Nat = 141 | \(m n) Nat-elim m Nat (add n) 0 142 | 143 | let exp : Nat -> Nat -> Nat = 144 | \(m n) Nat-elim n Nat (mul m) 1 145 | 146 | let 1+1-is-2 : Eq Nat (add 1 1) 2 = eq-refl Nat 2 147 | 148 | let 2*3-is-6 : Eq Nat (mul 2 3) 6 = eq-refl Nat 6 149 | 150 | let Bool : Prop = + T T 151 | 152 | let true : Bool = inl T T <> 153 | 154 | let false : Bool = inr T T <> 155 | 156 | let if : Bool -> \/(R : Prop) R -> R -> R = 157 | \(b R t f) case T T b R (\(_) t) (\(_) f) 158 | 159 | 160 | let if-spec-true : Prop = 161 | \/(b : Bool)(R : Prop)(t f : R) Eq Bool true b -> Eq R t (if b R t f) 162 | 163 | let if-spec-false : Prop = 164 | \/(b : Bool)(R : Prop)(t f : R) Eq Bool false b -> Eq R f (if b R t f) 165 | 166 | let if-spec : Prop = 167 | & if-spec-true if-spec-false 168 | 169 | 170 | let if-true : if-spec-true = 171 | \(b R t f eq) eq (\(x) Eq R t (if x R t f)) (eq-refl R t) 172 | 173 | let if-false : if-spec-false = 174 | \(b R t f eq) eq (\(x) Eq R f (if x R t f)) (eq-refl R f) 175 | 176 | let if-correct : if-spec = pair if-spec-true if-spec-false if-true if-false 177 | 178 | let id-correct : \/(A : Prop)(x : A) Eq A x (id A x) = eq-refl 179 | 180 | 181 | -------------------------------------------------------------------------------- /lib/combi/parser.ml: -------------------------------------------------------------------------------- 1 | 2 | module type BASE = 3 | sig 4 | type 'a t 5 | val return : 'a -> 'a t 6 | val bind : 'a t -> ('a -> 'b t) -> 'b t 7 | val fail : 'a t 8 | val choice : 'a t -> 'a t -> 'a t 9 | end 10 | 11 | 12 | module type S = 13 | sig 14 | type 'a m 15 | type 'a t = char list -> ('a * char list) m 16 | type 'a parser = 'a t 17 | include BASE with type 'a t := 'a parser 18 | 19 | val (<$>) : ('a -> 'b) -> 'a parser -> 'b parser 20 | val (<$) : 'a -> 'b parser -> 'a parser 21 | val ($>) : 'a parser -> 'b -> 'b parser 22 | val (<*>) : ('a -> 'b) parser -> 'a parser -> 'b parser 23 | val (<* ) : 'a parser -> 'b parser -> 'a parser 24 | val ( *>) : 'a parser -> 'b parser -> 'b parser 25 | val lift2 : ('a -> 'b -> 'c) -> 'a parser -> 'b parser -> 'c parser 26 | val (>>=) : 'a parser -> ('a -> 'b parser) -> 'b parser 27 | val (<|>) : 'a parser -> 'a parser -> 'a parser 28 | 29 | val (let*) : 'a parser -> ('a -> 'b parser) -> 'b parser 30 | val item : char parser 31 | val sat : (char -> bool) -> char parser 32 | val letter : char parser 33 | val lower : char parser 34 | val upper : char parser 35 | val digit : char parser 36 | val alphanum : char parser 37 | val whitespace : char parser 38 | val char : char -> char parser 39 | val char_list : char list -> char list parser 40 | val string : string -> string parser 41 | val to_string : char list parser -> string parser 42 | val nat : int parser 43 | val int : int parser 44 | val many : 'a parser -> 'a list parser 45 | val many1 : 'a parser -> 'a list parser 46 | val sepby : 'a parser -> 'sep parser -> 'a list parser 47 | val sepby1 : 'a parser -> 'sep parser -> 'a list parser 48 | val between : 'dl parser -> 'dr parser -> 'a parser -> 'a parser 49 | val chainl : 'a parser -> ('a -> 'a -> 'a) parser -> 'a -> 'a parser 50 | val chainl1 : 'a parser -> ('a -> 'a -> 'a) parser -> 'a parser 51 | val chainr : 'a parser -> ('a -> 'a -> 'a) parser -> 'a -> 'a parser 52 | val chainr1 : 'a parser -> ('a -> 'a -> 'a) parser -> 'a parser 53 | val postfix : 'a parser -> ('a -> 'a) parser -> 'a parser 54 | val prefix : ('a -> 'a) parser -> 'a parser -> 'a parser 55 | val consume : 'a parser -> unit parser 56 | val ident : char list -> string parser 57 | val (%) : 'a parser -> string -> ('a * char list) m 58 | end 59 | 60 | 61 | module OptionBase : BASE with type 'a t = 'a option = 62 | struct 63 | type 'a t = 'a option 64 | let return x = Some x 65 | let bind x f = 66 | match x with 67 | | Some x -> f x 68 | | _ -> None 69 | 70 | let fail = None 71 | let choice x y = 72 | match (x,y) with 73 | | (Some x,_) -> Some x 74 | | (_,Some y) -> Some y 75 | | _ -> None 76 | end 77 | 78 | module ListBase : BASE with type 'a t = 'a list = 79 | struct 80 | type 'a t = 'a list 81 | let return x = [x] 82 | 83 | let bind x f = List.concat (List.map f x) 84 | 85 | let fail = [] 86 | 87 | let choice = (@) 88 | end 89 | 90 | module Make (M : BASE) : S 91 | with type 'a m = 'a M.t = 92 | struct 93 | type 'a m = 'a M.t 94 | type 'a t = char list -> ('a * char list) M.t 95 | type 'a parser = 'a t 96 | 97 | 98 | let uncurry f (x,y) = f x y 99 | let cons x xs = x::xs 100 | let foldr f z xs = List.fold_right f xs z 101 | let foldl = List.fold_left 102 | let explode s = List.init (String.length s) (String.get s) 103 | let implode chars = 104 | let buf = Buffer.create 16 in 105 | List.iter (Buffer.add_char buf) chars; 106 | Buffer.contents buf 107 | 108 | let return x i = M.return (x,i) 109 | 110 | let bind p f i = 111 | M.bind (p i) (uncurry f) 112 | 113 | let fail _ = M.fail 114 | 115 | let choice p q i = M.choice (p i) (q i) 116 | 117 | let (<|>) = choice 118 | 119 | let (>>=) = bind 120 | let (let*) = bind 121 | 122 | let map f p = 123 | let* x = p in 124 | return @@ f x 125 | 126 | let (<$>) = map 127 | 128 | let (<$) x = map @@ Fun.const x 129 | let ($>) x = Fun.flip (<$) @@ x 130 | 131 | let apply p q = 132 | let* f = p in 133 | let* x = q in 134 | return @@ f x 135 | 136 | let (<*>) = apply 137 | 138 | let ( <* ) p q = 139 | let* x = p in 140 | let* _ = q in 141 | return x 142 | 143 | let ( *> ) p q = 144 | let* _ = p in 145 | let* y = q in 146 | return y 147 | 148 | let lift2 f p q = f <$> p <*> q 149 | 150 | let item = function 151 | | [] -> fail [] 152 | | (x::xs) -> return x xs 153 | 154 | let sat p = 155 | let* c = item in 156 | if p c then return c else fail 157 | 158 | let in_range (x,y) c = x <= c && c <= y 159 | 160 | let digit = sat @@ in_range ('0','9') 161 | let lower = sat @@ in_range ('a','z') 162 | let upper = sat @@ in_range ('A','Z') 163 | 164 | let letter = lower <|> upper 165 | let alphanum = letter <|> digit 166 | 167 | let whitespace = sat (fun c -> c = ' ' || c = '\n' || c ='\t') 168 | 169 | let char c = sat (fun x -> x = c) 170 | 171 | let rec char_list = function 172 | | [] -> return [] 173 | | c::cs -> lift2 cons (char c) (char_list cs) 174 | 175 | let string s = implode <$> (char_list (explode s)) 176 | 177 | let rec many p = lift2 cons p (fun x -> many p x) <|> return [] 178 | let many1 p = lift2 cons p (many p) 179 | 180 | let nat = 181 | let toNum c = Char.code c - Char.code '0' in 182 | let eval = foldl (fun i c -> toNum c + 10*i) 0 in 183 | eval <$> many1 digit 184 | 185 | let int = 186 | let p = (char '-' $> Int.neg) <|> return Fun.id in 187 | p <*> nat 188 | 189 | let to_string p = implode <$> p 190 | 191 | let sepby1 p sep = lift2 cons p (many @@ sep *> p) 192 | let sepby p sep = sepby1 p sep <|> return [] 193 | 194 | let between l r p = l *> p <* r 195 | 196 | let chainl1 t o = 197 | let rec rest x = 198 | (let* f = o in 199 | let* y = t in 200 | rest @@ f x y) 201 | <|> return x 202 | in 203 | t >>= rest 204 | 205 | let chainl t o v = 206 | chainl1 t o <|> return v 207 | 208 | let rec chainr1 t o = 209 | let* x = t in 210 | (let* f = o in 211 | let* y = chainr1 t o in 212 | return @@ f x y) <|> return x 213 | 214 | let chainr t o v = 215 | chainr1 t o <|> return v 216 | 217 | let postfix p o = 218 | let rec rest x = 219 | (let* f = o in 220 | rest @@ f x) <|> return x 221 | in 222 | p >>= rest 223 | 224 | let prefix o p = 225 | lift2 (foldr (@@)) p (many o) 226 | 227 | let ident illegal = to_string @@ many1 (sat (fun x -> not (List.mem x illegal))) 228 | 229 | let consume p = () <$ p 230 | 231 | let (%) p s = p (explode s) 232 | end 233 | 234 | 235 | -------------------------------------------------------------------------------- /examples/coc-unicode.pure: -------------------------------------------------------------------------------- 1 | %SORTS 2 | Prop 3 | | Type 4 | %AXIOMS 5 | Prop : Type 6 | %RULES 7 | Prop,Prop,Prop 8 | | Prop,Type,Type 9 | | Type,Prop,Prop 10 | | Type,Type,Type 11 | 12 | 13 | let ⊤ : Prop = ∀ (A : Prop) A → A 14 | let 𝟙 = ⊤ 15 | let tt : ⊤ = λ(_ x) x 16 | let id = tt 17 | 18 | let ⊥ : Prop = ∀ (A : Prop) A 19 | let ⊥-elim : ⊥ → ∀ (A : Prop) A = λ(f) f 20 | 21 | let ¬ : Prop → Prop = λ(p) p → ⊥ 22 | 23 | let ∧ : Prop → Prop → Prop = 24 | λ(A B) ∀ (C : Prop) (A → B → C) → C 25 | 26 | let pair : ∀ (A B : Prop) A → B → ∧ A B = 27 | λ(_ _ x y) λ(_ elim) elim x y 28 | 29 | let π₁ : ∀ (A B : Prop) ∧ A B → A = 30 | λ(A B p) p A (λ(x y) x) 31 | 32 | let π₂ : ∀ (A B : Prop) ∧ A B → B = 33 | λ(A B p) p B (λ(x y) y) 34 | 35 | 36 | let ∨ : Prop → Prop → Prop = 37 | λ(A B) ∀ (C : Prop) (A → C) → (B → C) → C 38 | 39 | let inj₁ : ∀ (A B : Prop) A → ∨ A B = 40 | λ(_ _ a _ l r) l a 41 | 42 | let inj₂ : ∀ (A B : Prop) B → ∨ A B = 43 | λ(_ _ b _ l r) r b 44 | 45 | let case : ∀ (A B : Prop) ∨ A B → ∀ (C : Prop) (A → C) → (B → C) → C = 46 | λ(_ _ x) x 47 | 48 | 49 | let Σ : ∀ (A : Prop) (A → Prop) → Prop = 50 | λ(A P) ∀ (C : Prop) (∀ (x : A) P x → C) → C 51 | 52 | let exists : ∀ (A : Prop) (P : A → Prop) (x : A) P x → Σ A P = 53 | λ(_ _ x p _ elim) elim x p 54 | 55 | let ≡ : ∀ (A : Prop) A → A → Prop = 56 | λ(A x y) ∀ (P : A → Prop) P x → P y 57 | 58 | let refl : ∀ (A : Prop) (x : A) ≡ A x x = 59 | λ(_ _ _ Px) Px 60 | 61 | let sym : ∀ (A : Prop) (x y : A) ≡ A x y → ≡ A y x = 62 | λ(A x y x≡y P) x≡y (λ(w) P w → P x) (refl A x P) 63 | 64 | let trans : ∀ (A : Prop) (x y z : A) ≡ A x y → ≡ A y z → ≡ A x z = 65 | λ(A x y z x≡y y≡z P Px) y≡z P (x≡y P Px) 66 | 67 | let ≃ : Prop → Prop → Prop = 68 | λ(A B) 69 | Σ (A → B) λ(a→b) 70 | Σ (B → A) λ(b→a) 71 | ∧ (∀ (a : A) ≡ A (b→a (a→b a)) a) (∀ (b : B) ≡ B (a→b (b→a b)) b) 72 | 73 | let ⇔ : Prop → Prop → Prop = 74 | λ(A B) ∧ (A → B) (B → A) 75 | 76 | let 𝔹 : Prop = ∨ ⊤ ⊤ 77 | let true : 𝔹 = inj₁ ⊤ ⊤ tt 78 | let false : 𝔹 = inj₂ ⊤ ⊤ tt 79 | 80 | let if : 𝔹 → ∀ (A : Prop) A → A → A = 81 | λ(b A t f) case ⊤ ⊤ b A (λ(_) t) (λ(_) f) 82 | 83 | let 𝔹 : Prop = ∀ (A : Prop) A → A → A 84 | let true : 𝔹 = λ(_ x y) x 85 | let false : 𝔹 = λ(_ x y) y 86 | 87 | let if : 𝔹 → ∀ (A : Prop) A → A → A = 88 | λ(x) x 89 | 90 | let && : 𝔹 → 𝔹 → 𝔹 = 91 | λ(b1 b2) if b1 𝔹 (if b2 𝔹 true false) false 92 | 93 | let || : 𝔹 → 𝔹 → 𝔹 = 94 | λ(b1 b2) if b1 𝔹 true (if b2 𝔹 true false) 95 | 96 | let ℕ : Prop = ∀ (A : Prop) (A → A) → A → A 97 | let Z : ℕ = λ(_ _ x) x 98 | let S : ℕ → ℕ = λ(n A f x) f (n A f x) 99 | let 0 : ℕ = Z 100 | let 1 : ℕ = S 0 101 | let 2 : ℕ = S 1 102 | let 3 : ℕ = S 2 103 | let 4 : ℕ = S 3 104 | let 5 : ℕ = S 4 105 | let 6 : ℕ = S 5 106 | let 7 : ℕ = S 6 107 | let 8 : ℕ = S 7 108 | let 9 : ℕ = S 8 109 | 110 | let ℕ-elim : ℕ → ∀ (A : Prop) (A → A) → A → A = λ(x) x 111 | 112 | let pred : ℕ → ℕ = 113 | λ(n) π₁ ℕ ℕ 114 | (ℕ-elim n (∧ ℕ ℕ) 115 | (λ(p) pair ℕ ℕ (π₂ ℕ ℕ p) (S (π₂ ℕ ℕ p))) 116 | (pair ℕ ℕ 0 0)) 117 | 118 | let + : ℕ → ℕ → ℕ = 119 | λ(m n) ℕ-elim m ℕ S n 120 | 121 | let - : ℕ → ℕ → ℕ = 122 | λ(m n) ℕ-elim n ℕ pred m 123 | 124 | let * : ℕ → ℕ → ℕ = 125 | λ(m n) ℕ-elim m ℕ (+ n) 0 126 | 127 | let ^ : ℕ → ℕ → ℕ = 128 | λ(m n) ℕ-elim n ℕ (* m) 1 129 | 130 | let zero? : ℕ → 𝔹 = 131 | λ(n) ℕ-elim n 𝔹 (λ(_) false) true 132 | 133 | let zero?-correct : ∀ (n : ℕ) ≡ ℕ 0 n → ≡ 𝔹 true (zero? n) = 134 | λ(n 0≡n) 0≡n (λ(x) ≡ 𝔹 true (zero? x)) (refl 𝔹 true) 135 | 136 | let ≤ᵇ : ℕ → ℕ → 𝔹 = 137 | λ(m n) zero? (- m n) 138 | 139 | let ≥ᵇ : ℕ → ℕ → 𝔹 = 140 | λ(m n) ≤ᵇ n m 141 | 142 | let <ᵇ : ℕ → ℕ → 𝔹 = 143 | λ(m n) if (&& (zero? m) (zero? n)) 𝔹 false (≤ᵇ m (pred n)) 144 | 145 | let >ᵇ : ℕ → ℕ → 𝔹 = 146 | λ(m n) <ᵇ n m 147 | 148 | let 1+1≡2 : ≡ ℕ (+ 1 1) 2 = refl ℕ 2 149 | 150 | let 2*3≡6 : ≡ ℕ (* 2 3) 6 = refl ℕ 6 151 | 152 | let 3^2≡9 : ≡ ℕ (^ 3 2) 9 = refl ℕ 9 153 | 154 | let 4<ᵇ5 : ≡ 𝔹 (<ᵇ 4 5) true = refl 𝔹 true 155 | 156 | let ∞-ℕ : ∀ (n : ℕ) Σ ℕ λ(m) ≡ ℕ (+ n 1) m = 157 | λ(n) λ(_ elim) elim (+ n 1) (refl ℕ (+ n 1)) 158 | 159 | let ≤ : ℕ → ℕ → Prop = 160 | λ(x y) ∀ (C : ℕ → ℕ → Prop) (∀ (n : ℕ) C 0 n) → (∀ (m n : ℕ) C m n → C (S m) (S n)) → C x y 161 | 162 | let Z≤Z : ∀ (n : ℕ) ≤ 0 n = 163 | λ(n C b h) b n 164 | 165 | let S≤S : ∀ (x y : ℕ) ≤ x y → ≤ (S x) (S y) = 166 | λ(x y m≤n C b h) h x y (m≤n C b h) 167 | 168 | 169 | let List : Prop → Prop = 170 | λ(A) ∀ (B : Prop) (A → B → B) → B → B 171 | 172 | let [] : ∀ (A : Prop) List A = 173 | λ(A B g z) z 174 | 175 | let ∷ : ∀ (A : Prop) A → List A → List A = 176 | λ(A x xs) λ(B g z) g x (xs B g z) 177 | 178 | let foldr : ∀ (A : Prop) List A → ∀ (B : Prop) (A → B → B) → B → B = 179 | λ(_ x) x 180 | 181 | let map : ∀ (A B : Prop) (A → B) → List A → List B = 182 | λ(A B f xs) xs (List B) (λ(x xs) ∷ B (f x) xs) ([] B) 183 | 184 | 185 | let xs : List ℕ = ∷ ℕ 0 (∷ ℕ 1 (∷ ℕ 2 ([] ℕ))) 186 | 187 | let Maybe : Prop → Prop = 188 | λ(A) ∨ A 𝟙 189 | 190 | let Some : ∀(A : Prop) A → Maybe A = λ(A) inj₁ A 𝟙 191 | let None : ∀(A : Prop) Maybe A = λ(A) inj₂ A 𝟙 tt 192 | 193 | let _ : Maybe (List ℕ) = None (List ℕ) 194 | let _ : Maybe (List ℕ) = Some (List ℕ) (∷ ℕ 1 ([] ℕ)) 195 | 196 | let hd : ∀ (A : Prop) List A → Maybe A = 197 | λ(A xs) foldr A xs (Maybe A) (λ(x xs) Some A x) (None A) 198 | 199 | let Vec : Prop → ℕ → Prop = 200 | λ(A n) ∀ (B : ℕ → Prop) (∀ (m : ℕ) A → B m → B (S m)) → B 0 → B n 201 | 202 | let <> : ∀ (A : Prop) Vec A 0 = 203 | λ(A) λ(B g z) z 204 | 205 | let vcons : ∀ (A : Prop)(n : ℕ) A → Vec A n → Vec A (S n) = 206 | λ(A n x xs) λ(B g z) g n x (xs B g z) 207 | 208 | let ∃ : (Prop → Prop) → Prop = 209 | λ(P) ∀ (C : Prop) (∀ (t : Prop) P t → C) → C 210 | 211 | let pack : ∀ (t : Prop) (P : Prop → Prop) P t → ∃ P = 212 | λ(t P imp) λ(C f) f t imp 213 | 214 | let unpack : ∀ (P : Prop → Prop) ∃ P → ∀ (C : Prop) (∀ (t : Prop) P t → C) → C = 215 | λ(P x) x 216 | 217 | let MONOID : Prop → Prop = λ(M) ∧ M (M → M → M) 218 | 219 | let M/* : ∀ (M : Prop) MONOID M → M → M → M = 220 | λ(M C) π₂ M (M → M → M) C 221 | 222 | let M/unit : ∀ (M : Prop) MONOID M → M = 223 | λ(M C) π₁ M (M → M → M) C 224 | 225 | let M/mk : ∀ (M : Prop) M → (M → M → M) → MONOID M = 226 | λ(M unit *) pair M (M → M → M) unit * 227 | 228 | 229 | let MONOID-VERIFIED : Prop → Prop = 230 | λ(M) 231 | Σ M λ(unit) 232 | Σ (M → M → M) λ(*) 233 | ∧ 234 | (∧ 235 | (∀ (a : M) ≡ M (* unit a) a) 236 | (∀ (a : M) ≡ M (* a unit) a)) 237 | (∀ (a b c : M) ≡ M (* a (* b c)) (* (* a b) c)) 238 | 239 | let Monoid-ℕ-+ : MONOID ℕ = 240 | M/mk ℕ 0 + 241 | 242 | let Monoid-ℕ-* : MONOID ℕ = 243 | M/mk ℕ 1 * 244 | 245 | let f : ∀ (M : Prop) MONOID M → M = 246 | λ(M C) M/* M C (M/unit M C) (M/unit M C) 247 | 248 | let foldMap : ∀ (A M : Prop) MONOID M → (A → M) → List A → M = 249 | λ(A M C f xs) (map A M f xs) M (M/* M C) (M/unit M C) 250 | 251 | let sum : List ℕ → ℕ = foldMap ℕ ℕ Monoid-ℕ-+ (id ℕ) 252 | let prod : List ℕ → ℕ = foldMap ℕ ℕ Monoid-ℕ-* (id ℕ) 253 | 254 | let xs = ∷ ℕ 1 (∷ ℕ 2 (∷ ℕ 3 (∷ ℕ 4 ([] ℕ)))) 255 | 256 | 257 | let EM : Prop = ∀ (A : Prop) ∨ A (¬ A) 258 | let DNE : Prop = ∀ (A : Prop) ¬ (¬ A) → A 259 | 260 | let EM→DNE : EM → DNE = 261 | λ(em A ¬¬A) (em A) A (λ(a) a) (λ(¬a) (¬¬A ¬a) A) 262 | 263 | let DNE→EM : DNE → EM = 264 | λ(dne A) λ(C a→c ¬a→c) dne C (λ(¬c) ¬c (¬a→c λ(a) ¬c (a→c a))) 265 | 266 | --------------------------------------------------------------------------------