├── BUGS ├── LICENSE ├── Makefile ├── README.md ├── TODO ├── adjsc.ml ├── ast.ml ├── ast.mli ├── base.ml ├── base.mli ├── context.ml ├── context.mli ├── cover.txt ├── examples ├── Makefile ├── test0.adjs ├── test1.adjs ├── test2.adjs ├── test3.adjs ├── test4.adjs ├── test5.adjs ├── test6.adjs ├── test7.adjs ├── test8-broken.adjs ├── test8.adjs └── test9-broken.adjs ├── foo.txt ├── higher-kinds.txt ├── js.ml ├── js.mli ├── kinding.ml ├── kinding.mli ├── lambda.ml ├── lambda.mli ├── lexer.mli ├── lexer.mll ├── lin.txt ├── linearity.txt ├── parseloc.ml ├── parseloc.mli ├── parser.mly ├── poly.ml ├── poly.mli ├── pp.ml ├── pp.mli ├── runtime.js ├── stdlib.old ├── stdlib.sig ├── subtype.ml ├── subtype.mli ├── subtype.txt ├── testing.ml ├── tests.ml ├── token.ml ├── toplevel.ml ├── toplevel.mli ├── translate.ml ├── translate.mli ├── typing.txt ├── unittest.ml └── unittest.mli /BUGS: -------------------------------------------------------------------------------- 1 | BUGS 2 | ==== 3 | 4 | * Datatypes without parameters are broken. 5 | 6 | To fix this temporarily, change the check_kind/synth_kind routines 7 | to return TApp(TVar d, []) instead of TVar d when d is a datatype 8 | binding. 9 | 10 | * Guardedness checking in datatype declarations is not implemented. 11 | 12 | * Datatypes are assumed to be stable, which means 13 | 14 | type foo = Foo of next int 15 | 16 | is incorrectly assumed to be stable! 17 | 18 | * next(e, e') should put the permission second, not first 19 | 20 | * higher-rank polymorphism does not correctly implement the instantiation 21 | routines from "Complete and Easy Bidirectional Typechecking for Higher-Rank 22 | Polymorphism" 23 | 24 | * Pattern and constructor syntax for cons cells is asymmetric 25 | 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OCAMLC=ocamlc 2 | OCAMLLEX=ocamllex 3 | OCAMLYACC=ocamlyacc 4 | OPTS=-g -annot 5 | BASE=base.mli base.ml 6 | UNITTEST=unittest.mli unittest.ml 7 | LAMBDA=lambda.mli lambda.ml 8 | PP=pp.mli pp.ml 9 | JS=js.mli js.ml 10 | CONTEXT=context.mli context.ml 11 | SUBTYPE=subtype.mli subtype.ml 12 | TRANSLATE=translate.mli translate.ml 13 | AST=ast.mli ast.ml 14 | POLY=poly.mli poly.ml 15 | PARSELOC=parseloc.mli parseloc.ml 16 | TOPLEVEL=toplevel.mli toplevel.ml 17 | KINDING=kinding.mli kinding.ml 18 | OBJS=unittest.cmo base.cmo ast.cmo parser.cmo lexer.cmo parseloc.cmo lambda.cmo context.cmo kinding.cmo subtype.cmo poly.cmo pp.cmo js.cmo translate.cmo toplevel.cmo 19 | 20 | 21 | compiler: jscomp.cma 22 | ocamlc -o adjsc jscomp.cma adjsc.ml 23 | 24 | lib: jscomp.cma 25 | 26 | jscomp.cma: $(OBJS) 27 | $(OCAMLC) $(OPTS) -a -o jscomp.cma $(OBJS) 28 | 29 | unittest.cmo: $(UNITTEST) 30 | $(OCAMLC) $(OPTS) $(UNITTEST) 31 | 32 | lambda.cmo: base.cmo $(LAMBDA) 33 | $(OCAMLC) $(OPTS) base.cmo $(LAMBDA) 34 | 35 | pp.cmo: $(PP) 36 | $(OCAMLC) $(OPTS) $(PP) 37 | 38 | js.cmo: base.cmo pp.cmo $(JS) 39 | $(OCAMLC) $(OPTS) base.cmo pp.cmo $(JS) 40 | 41 | context.cmo: base.cmo ast.cmo lambda.cmo $(CONTEXT) 42 | $(OCAMLC) $(OPTS) base.cmo ast.cmo $(CONTEXT) 43 | 44 | kinding.cmo: base.cmo ast.cmo lambda.cmo context.cmo $(KINDING) 45 | $(OCAMLC) $(OPTS) base.cmo ast.cmo lambda.cmo context.cmo $(KINDING) 46 | 47 | 48 | subtype.cmo: base.cmo ast.cmo lambda.cmo context.cmo kinding.cmo $(SUBTYPE) 49 | $(OCAMLC) $(OPTS) base.cmo ast.cmo lambda.cmo context.cmo kinding.cmo $(SUBTYPE) 50 | 51 | poly.cmo: base.cmo ast.cmo lambda.cmo context.cmo kinding.cmo subtype.cmo $(POLY) 52 | $(OCAMLC) $(OPTS) base.cmo ast.cmo lambda.cmo context.cmo kinding.cmo subtype.cmo $(POLY) 53 | 54 | translate.cmo: base.cmo pp.cmo js.cmo lambda.cmo $(TRANSLATE) 55 | $(OCAMLC) $(OPTS) base.cmo pp.cmo js.cmo lambda.cmo $(TRANSLATE) 56 | 57 | toplevel.cmo: base.cmo ast.cmo lambda.cmo context.cmo kinding.cmo subtype.cmo poly.cmo pp.cmo js.cmo translate.cmo $(TOPLEVEL) 58 | $(OCAMLC) $(OPTS) base.cmo ast.cmo lambda.cmo context.cmo kinding.cmo subtype.cmo poly.cmo pp.cmo js.cmo translate.cmo $(TOPLEVEL) 59 | 60 | base.cmo: $(BASE) 61 | $(OCAMLC) $(OPTS) $(BASE) 62 | 63 | ast.cmo: base.cmo $(AST) 64 | $(OCAMLC) $(OPTS) base.cmo $(AST) 65 | 66 | lexer.cmo: lexer.ml base.cmo ast.cmo parser.cmo 67 | $(OCAMLC) $(OPTS) base.cmo ast.cmo parser.cmo lexer.mli lexer.ml 68 | 69 | lexer.ml: lexer.mll 70 | $(OCAMLLEX) lexer.mll 71 | 72 | parser.cmo: base.cmo ast.cmo parser.ml 73 | $(OCAMLC) $(OPTS) base.cmo ast.cmo parser.mli parser.ml 74 | 75 | parser.ml: parser.mly 76 | $(OCAMLYACC) -v parser.mly 77 | 78 | parseloc.cmo: lexer.cmo parser.cmo $(PARSELOC) 79 | $(OCAMLC) $(OPTS) base.cmo ast.cmo parser.cmo lexer.cmo parseloc.mli parseloc.ml 80 | 81 | clean: 82 | rm *~ *.cmi *.cmo *.cma *.annot parser.mli parser.ml lexer.ml parser.output *.cmt *.cmti *.o *.cmx *.cmxi *.cmxa 83 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A Higher-Order FRP compiler 2 | =========================== 3 | 4 | This is a repository for a small compiler for the higher-order FRP work 5 | that I and my collaborators have developed, primarily in the following papers: 6 | 7 | * [*Higher-Order Reactive Programming without Spacetime Leaks*](http://www.cs.bham.ac.uk/~krishnan/simple-frp.pdf) 8 | 9 | This gives the main implementation strategy. 10 | 11 | * [*A Semantic Model for Graphical User Interfaces*](http://www.cs.bham.ac.uk/~krishnan/icfp11-krishnaswami-benton.pdf) 12 | 13 | This explains the use of linear types. 14 | 15 | * [*Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism*](http://www.cs.bham.ac.uk/~krishnan/bidir.pdf) 16 | 17 | This explains how type inference works. 18 | 19 | To build, you need a recent-ish version of Ocaml. Go into the adjs/ directory and run make. 20 | 21 | For convenience, I used Firefox's let-binding extensions to 22 | Javascript, so you'll need to use it to run programs. -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Desired type system extensions: 2 | 3 | 0. Stable/dynamic datatypes 4 | 1. Abstract types 5 | 2. Mutually recursive definitions 6 | 3. Explicit polymorphic abstractions 7 | 4. Type definitions 8 | 5. Higher-kinded polymorphism 9 | 6. Records 10 | 7. Arrays 11 | 8. Index domains 12 | 9. Disjunctive linear datatypes 13 | 10. GADTs 14 | 11. Row polymorphism 15 | 12. Implicit/qualified types 16 | 13. Dependent types 17 | 18 | Questions: 19 | 20 | 0. Syntax for kind annotations 21 | 22 | We want to leave off kind annotations if possible. This means introducing kind evars 23 | into our context, which is easy. What is harder is the syntax for kind annotations. 24 | 25 | This is Coq-style: 26 | 27 | forall (a b : int), (c d : lin). (a -> b) -> G(c -o d) 28 | 29 | We can also explicitly parenthesize and annotates each tycon needing annotation: 30 | 31 | forall a b c (d : int -> int) e. a -> b -> d c 32 | 33 | I will try the latter form for now, with the option of changing it to 34 | something less noisy later. 35 | 36 | 1. Can we accomodate type definitions *without* necessarily having type-level lambdas? 37 | 38 | 1a. We can do this by requiring that all type definitions be fully applied when they 39 | are used. As a result, we can give a definition like: 40 | 41 | type pair : int -> int -> int 42 | type pair a b = (a & b) 43 | 44 | but we can only use it as "pair int int", and not as "pair". This considerably 45 | limits the utility of such definitions. Does it restrict them too much? 46 | 47 | 1b. Another approach is to restrict subtyping for higher-kinded definitions. 48 | 49 | We can say that 50 | 51 | \Gamma, a:k1 |- F a <: G a : k2 52 | ------------------------------- 53 | \Gamma |- F <: G : k1 -> k2 54 | 55 | This means that the subtyping relation assumes that all type 56 | definitions are potentially co- and contra-variant. As as a result, 57 | we do not need to make any hypotheses about the variance of the 58 | type constructors. 59 | 60 | Then the subtyping relation at higher kind just eta-expands until 61 | it hits a base kind, and then unfolding a definition will never 62 | leave us with a lambda. 63 | 64 | This subsumes 1a, while still blocking type-level lambda 65 | abstractions. The question is: how does this interact with 66 | stability? 67 | 68 | So the only substitution rule remains the same: 69 | 70 | \Gamma |-* \Gamma(A) <: \Gamma(B) : b 71 | --------------------------------------- 72 | \Gamma |- A <: B : b 73 | 74 | We should represent applications in spine form to make this work 75 | nicely. 76 | 77 | 1. Do we need subkinding between stable and dynamic types, or can 78 | we get away without it? 79 | 80 | I don't want it. I have enough subtyping already, and subkinding 81 | will screw up dependent types when I add it. Implicit/qualified 82 | types can handle the reasonable uses by letting us pass stability 83 | constraints as arguments. 84 | 85 | 1' How about the stability flags on datatypes? 86 | 87 | We can declare datatypes to be *stable*, which means that every 88 | branch is a stable type, assuming that all the type arguments are 89 | stable. Consider: 90 | 91 | stable type list a = Nil of unit | Cons of (a & list a) 92 | 93 | Now, we assume a is stable, that list is a stable type constructor. 94 | 95 | Note that unit is stable, and (a & list a) is stable if a and list 96 | a are stable. We assumed a is stable, so this leaves showing list a 97 | is stable. However, we assumed list is a stable type constructor, 98 | so applying it to the stable type a gives a stable type. 99 | 100 | This means each type variable needs to carry a 101 | 102 | 2. How can we handle explicit type applications? (For fullly 103 | impredicative applications.) 104 | 105 | 1. put term-level applications in spine form. 106 | 2. Add a head marker (ala Coq) to switch to explicit 107 | mode. 108 | 3. Syntax of explicit type applications: 109 | 110 | val id : forall a. a -> a 111 | let id a x = x 112 | 113 | Then we can write: 114 | 115 | @(map ~num ~num (fun x -> x + x) (Cons(3, Cons(4, Nil)))) 116 | 117 | vs 118 | 119 | map (fun x -> x) (Cons(3, Cons(4, Nil))) 120 | 121 | or even 122 | 123 | @(id ~(forall a. a -> a) id) : (forall a. a -> a) 124 | 125 | 3. Records 126 | 127 | The obvious thing is Morrow-style row polymorphism. There are 128 | questions about how to map records with duplicated labels to JS 129 | objects. -------------------------------------------------------------------------------- /adjsc.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type config = { 4 | stdlib: string; 5 | runtime: string; 6 | source: string; 7 | target: string; 8 | title: string; 9 | } 10 | 11 | let default = { 12 | stdlib = ""; 13 | runtime = ""; 14 | target = "a"; 15 | source = ""; 16 | title = "" 17 | } 18 | 19 | let process_args argv = 20 | let len = Array.length argv in 21 | let rec loop i acc = 22 | if i < len then 23 | let (i, acc) = 24 | try (match argv.(i) with 25 | | "-o" -> (i+2, {acc with target = argv.(i+1)}) 26 | | "-I" -> (i+2, {acc with 27 | stdlib = argv.(i+1) ^ "/stdlib.sig"; 28 | runtime = argv.(i+1) ^ "/runtime.js"; 29 | }) 30 | | "-t" -> (i+2, {acc with title = argv.(i+1)}) 31 | | filename when i = len - 1 -> (i+1, {acc with source = filename}) 32 | | _ -> Printf.printf "unexpected end of arguments"; exit (-1)) 33 | with 34 | | e -> Printf.printf "%s" (Printexc.to_string e); exit (-1) 35 | in 36 | loop i acc 37 | else 38 | acc 39 | in 40 | loop 1 default 41 | 42 | let template config = 43 | let out = open_out (config.target ^ ".html") in 44 | let () = Printf.fprintf out " 45 | 46 | %s 47 | 48 | 49 | 50 | 51 |
52 | 53 | " config.title config.runtime config.target in 54 | let () = close_out out in 55 | () 56 | 57 | let translate (stdlib, program) = 58 | let cmd = let (>>) = Context.(>>) in 59 | Toplevel.process_signature stdlib >> 60 | Toplevel.elaborate program in 61 | match Context.run cmd [] Base.dummy_pos with 62 | | Context.Value(lams, _) -> Toplevel.translate_program lams 63 | | Context.Error msg -> raise (Toplevel.CompileError msg) 64 | 65 | let parse stdlib_name program_name = 66 | let sigparse = Parseloc.wrap Parser.signature Lexer.token in 67 | let progparse = Parseloc.wrap Parser.program Lexer.token in 68 | let stdlib = sigparse (Lexing.from_channel (open_in stdlib_name)) in 69 | let program = progparse (Lexing.from_channel (open_in program_name)) in 70 | (stdlib, program) 71 | 72 | let compile config = 73 | try 74 | let out = open_out (config.target ^ ".js") in 75 | let () = Pp.print (Js.print_stmts (translate (parse config.stdlib config.source))) out in 76 | let () = template config in 77 | let () = flush out in 78 | let () = close_out out in 79 | () 80 | with 81 | | Toplevel.CompileError msg -> Printf.printf "%s\n" msg; exit (-1) 82 | | SyntaxError(loc, msg) -> Printf.printf "%s: %s\n" (string_of_pos loc) msg; exit (-1) 83 | | e -> Printf.printf "%s\n" (Printexc.to_string e); exit (-1) 84 | 85 | let _ = compile (process_args Sys.argv) 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | -------------------------------------------------------------------------------- /ast.ml: -------------------------------------------------------------------------------- 1 | (* Syntax of the mixed linepar/nonlinear term language *) 2 | 3 | open Base 4 | 5 | type kind = 6 | | Int 7 | | Lin 8 | | KVar of id 9 | | KArrow of kind * kind 10 | 11 | type tp = 12 | | Num 13 | | Bool 14 | | String 15 | | Pure of tp 16 | | Next of tp 17 | | Stream of tp 18 | | G of tp 19 | | Product of tp list 20 | | Arrow of tp * tp 21 | | Forall of id * kind option * tp 22 | | Exists of id * kind option * tp 23 | | TApp of tp * tp list 24 | | F of tp 25 | | Tensor of tp list 26 | | Lolli of tp * tp 27 | | Dom of tp 28 | | Frame of tp 29 | | Svg of tp 30 | | TVar of id 31 | | TAnnot of tp * kind 32 | | TLam of id * tp 33 | | TLet of id * tp * tp 34 | 35 | type pat = pos * pat' 36 | and pat' = 37 | | PTop 38 | | PVar of id 39 | | PBang of pat 40 | | PCon of conid * pat 41 | | PCons of pat * pat 42 | | PNext of pat 43 | | PTuple of pat list 44 | | PF of pat 45 | 46 | type exp = Base.pos * exp' 47 | and exp' = 48 | | EVar of id 49 | | EBang of exp 50 | | ENext of exp (* * exp *) 51 | | ETuple of exp list 52 | | ELam of pat * exp 53 | | EApp of exp * exp 54 | | EBool of bool 55 | | EIf of exp * exp * exp 56 | | ENum of float 57 | | EString of string 58 | | ECons of exp * exp 59 | | EAnnot of exp * tp 60 | | EFix of id * exp 61 | | ELoop of id * pat * exp 62 | | EG of exp 63 | | EF of exp 64 | | EOp of op * exp * exp 65 | | ECase of exp * branch list 66 | | ECon of conid * exp 67 | | ELet of pat * exp * exp 68 | | ELetVar of id * id * exp 69 | | ERun of exp 70 | and branch = (pat * exp) 71 | 72 | type datatype = kind * (id * kind) list * (conid * tp) list 73 | 74 | type decl = 75 | | DataBind of pos * id * datatype 76 | | ValueBind of (pos * id * exp * tp) 77 | | ValueDecl of (pos * id * tp) 78 | | TypeBind of (pos * id * tp * kind) 79 | | TypeDecl of (pos * id * kind) 80 | 81 | type program = decl list * exp 82 | 83 | type signature_elt = 84 | | DataDecl of pos * id * datatype 85 | | SigTypeDecl of pos * id * tp 86 | 87 | type signature = signature_elt list 88 | 89 | let rec pat_eq (_, p) (_, q) = pat_eq' (p, q) 90 | and pat_eq' = function 91 | | PTop, PTop -> true 92 | | PVar x, PVar y -> x = y 93 | | PBang p, PBang q -> pat_eq p q 94 | | PCons(p, p'), PCons(q, q') -> pat_eq p q && pat_eq p' q' 95 | | PNext p, PNext q -> pat_eq p q 96 | | PF p, PF q -> pat_eq p q 97 | | PCon(c, p), PCon(c', q) when c = c' -> pat_eq p q 98 | | PTuple ps, PTuple qs when List.length ps = List.length qs -> 99 | List.for_all2 pat_eq ps qs 100 | | _, _ -> false 101 | 102 | let rec exp_eq (_, f) (_, g) = exp_eq' (f, g) 103 | and exp_eq' = function 104 | | EVar x, EVar x' -> x = x' 105 | | EBang e, EBang e' -> exp_eq e e' 106 | | ENext e, ENext e' -> exp_eq e e' 107 | (* | ENext(e1,e2), ENext(e1',e2') -> exp_eq e1 e1' && exp_eq e2 e2' *) 108 | | ETuple es, ETuple es' -> List.length es = List.length es' && List.for_all2 exp_eq es es' 109 | | ELam(p,e), ELam(p',e') -> pat_eq p p' && exp_eq e e' 110 | | EApp(e1,e2), EApp(e1',e2') -> exp_eq e1 e1' && exp_eq e2 e2' 111 | | EBool b, EBool b' -> b = b' 112 | | ECons(e1,e2), ECons(e1',e2') -> exp_eq e1 e1' && exp_eq e2 e2' 113 | | EIf(e1,e2,e3), EIf(e1',e2',e3') -> exp_eq e1 e1' && exp_eq e2 e2' && exp_eq e3 e3' 114 | | ENum float, ENum float' -> float = float' 115 | | EString string, EString string' -> string = string' 116 | | EAnnot(e,ftype), EAnnot(e',ftype') -> ftype = ftype' && exp_eq e e' 117 | | EFix(x,e), EFix(x',e') -> x = x' && exp_eq e e' 118 | | ELoop(x,p,e), ELoop(x',p',e') -> x = x' && pat_eq p p' && exp_eq e e' 119 | | EF e, EF e' -> exp_eq e e' 120 | | EG lexp, EG lexp' -> exp_eq lexp lexp' 121 | | EOp(op,e1,e2), EOp(op',e1',e2') -> op = op' && exp_eq e1 e1' && exp_eq e2 e2' 122 | | ELet(p,e1,e2), ELet(p',e1',e2') -> pat_eq p p' && exp_eq e1 e1' && exp_eq e2 e2' 123 | | ECase(e, bs), ECase(e', bs') -> exp_eq e e' && List.for_all2 branch_eq bs bs' 124 | | ECon(c, e), ECon(c', e') -> c = c' && exp_eq e e' 125 | | ERun e, ERun e' -> exp_eq e e' 126 | | _, _ -> false 127 | 128 | and branch_eq (p, e) (p', e') = pat_eq p p' && exp_eq e e' 129 | 130 | let (singleton, union, empty, add, diff, remove, mem) = 131 | (Base.Ids.singleton, Base.Ids.union, Base.Ids.empty, Base.Ids.add, Base.Ids.diff, Base.Ids.remove, Base.Ids.mem) 132 | 133 | let rec freevars_kind = function 134 | | Int -> empty 135 | | Lin -> empty 136 | | KArrow(k1, k2) -> union (freevars_kind k1) (freevars_kind k2) 137 | | KVar x -> singleton x 138 | 139 | let rec freevars_tp = function 140 | | Num 141 | | Bool 142 | | String -> empty 143 | | Pure tp 144 | | Next tp 145 | | Stream tp 146 | | G tp 147 | | F tp 148 | | Frame tp 149 | | Dom tp 150 | | Svg tp -> freevars_tp tp 151 | | Forall (id, None, tp) 152 | | Exists (id, None, tp) -> remove id (freevars_tp tp) 153 | | Forall (id, Some k, tp) 154 | | Exists (id, Some k, tp) -> union (freevars_kind k) (remove id (freevars_tp tp)) 155 | | Lolli (tp, tp') 156 | | Arrow (tp, tp') -> union (freevars_tp tp) (freevars_tp tp') 157 | | Product tps 158 | | Tensor tps -> freevars_tp_list tps 159 | | TApp (tp, tps) -> union (freevars_tp tp) (freevars_tp_list tps) 160 | | TVar id -> singleton id 161 | | TAnnot(tp, kind) -> union (freevars_tp tp) (freevars_kind kind) 162 | | TLet(a, tp1, tp2) -> union (freevars_tp tp1) 163 | (remove a (freevars_tp tp2)) 164 | | TLam(a, tp) -> remove a (freevars_tp tp) 165 | 166 | and freevars_tp_list tps = List.fold_left union empty (List.map freevars_tp tps) 167 | 168 | let rec rename_kind a b = function 169 | | Int -> Int 170 | | Lin -> Lin 171 | | KArrow(k1, k2) -> KArrow(rename_kind a b k1, rename_kind a b k2) 172 | | KVar a' -> if a = a' then KVar b else KVar a 173 | 174 | let rec rename_tp a a' = function 175 | | Num -> Num 176 | | Bool -> Bool 177 | | String -> String 178 | | Pure tp -> Pure (rename_tp a a' tp) 179 | | Next tp -> Next (rename_tp a a' tp) 180 | | Stream tp -> Stream (rename_tp a a' tp) 181 | | G tp -> G (rename_tp a a' tp) 182 | | F tp -> F (rename_tp a a' tp) 183 | | Dom tp -> Dom (rename_tp a a' tp) 184 | | Frame tp -> Frame (rename_tp a a' tp) 185 | | Svg tp -> Svg (rename_tp a a' tp) 186 | | Forall (id, None, tp) -> Forall(id, None, if a = id then tp else rename_tp a a' tp) 187 | | Exists (id, None, tp) -> Exists(id, None, if a = id then tp else rename_tp a a' tp) 188 | | Forall (id, Some k, tp) -> Forall(id, Some (rename_kind a a' k), if a = id then tp else rename_tp a a' tp) 189 | | Exists (id, Some k, tp) -> Exists(id, Some (rename_kind a a' k), if a = id then tp else rename_tp a a' tp) 190 | | Lolli (tp, tp') -> Lolli(rename_tp a a' tp, rename_tp a a' tp') 191 | | Arrow (tp, tp') -> Arrow(rename_tp a a' tp, rename_tp a a' tp') 192 | | Product tps -> Product (List.map (rename_tp a a') tps) 193 | | Tensor tps -> Tensor (List.map (rename_tp a a') tps) 194 | | TApp (tp, tps) -> TApp(rename_tp a a' tp, 195 | map (rename_tp a a') tps) 196 | | TVar id -> TVar (if id = a then a' else id) 197 | | TAnnot(tp, k) -> TAnnot(rename_tp a a' tp, rename_kind a a' k) 198 | | TLet(b, tp1, tp2) -> TLet(b, 199 | rename_tp a a' tp1, 200 | if a = b then tp2 else rename_tp a a' tp2) 201 | | TLam(b, tp) when a =b -> TLam(b, tp) 202 | | TLam(b, tp) -> TLam(b, rename_tp a a' tp) 203 | 204 | 205 | 206 | let rec pvars (_, p) = 207 | match p with 208 | | PTop -> empty 209 | | PVar id -> singleton id 210 | | PBang p -> pvars p 211 | | PCon(c, p) -> pvars p 212 | | PNext p -> pvars p 213 | | PF p -> pvars p 214 | | PCons(p,p') -> union (pvars p) (pvars p') 215 | | PTuple ps -> List.fold_left union empty (List.map pvars ps) 216 | 217 | let rec freevars_exp (_, e) = 218 | match e with 219 | | EVar x -> singleton x 220 | | ENext e 221 | | EBang e -> freevars_exp e 222 | | EAnnot(e, tp) -> union (freevars_exp e) (freevars_tp tp) 223 | | ETuple es -> List.fold_left union empty (List.map freevars_exp es) 224 | | ELam(p, e) -> diff (freevars_exp e) (pvars p) 225 | | EOp(_, e1, e2) 226 | | ECons(e1, e2) 227 | | EApp(e1, e2) -> union (freevars_exp e1) (freevars_exp e2) 228 | | EBool _ 229 | | ENum _ 230 | | EString _ -> empty 231 | | EIf(e1, e2, e3) -> union (freevars_exp e1) (union (freevars_exp e2) (freevars_exp e3)) 232 | | EFix(x, e) -> remove x (freevars_exp e) 233 | | ELoop(f, p, e) -> remove f (diff (freevars_exp e) (pvars p)) 234 | | EG lexp -> freevars_exp lexp 235 | | ELet(p, e1, e2) -> union (freevars_exp e1) (diff (freevars_exp e2) (pvars p)) 236 | | ELetVar(x, y, e) -> union (singleton y) (diff (freevars_exp e) (singleton x)) 237 | | ECase(e, branches) -> union (freevars_exp e) (freevars_branches branches) 238 | | ECon(c, e) -> freevars_exp e 239 | | EF e -> freevars_exp e 240 | | ERun e -> freevars_exp e 241 | 242 | and freevars_branches bs = 243 | match bs with 244 | | [] -> empty 245 | | (p, e) :: rest -> union (freevars_branches rest) (diff (freevars_exp e) (pvars p)) 246 | 247 | let rec rename_exp x x' (pos, e) = (pos, rename' x x' e) 248 | and rename' x x' e = 249 | match e with 250 | | EVar y -> if x = y then EVar x' else EVar y 251 | | EAnnot(e, tp) -> EAnnot(rename_exp x x' e, rename_tp x x' tp) 252 | | EBang e -> EBang (rename_exp x x' e) 253 | | ENext e -> ENext (rename_exp x x' e) 254 | | ETuple es -> ETuple (List.map (rename_exp x x') es) 255 | | ELam(p, e) -> if mem x (pvars p) then ELam(p, e) else ELam(p, rename_exp x x' e) 256 | | EOp(op, e1, e2) -> EOp(op, rename_exp x x' e1, rename_exp x x' e2) 257 | | EApp(e1, e2) -> EApp(rename_exp x x' e1, rename_exp x x' e2) 258 | | EBool b -> EBool b 259 | | ENum n -> ENum n 260 | | EString s -> EString s 261 | | ECons(e1, e2) -> ECons(rename_exp x x' e1, rename_exp x x' e2) 262 | | EIf(e1, e2, e3) -> EIf(rename_exp x x' e1, rename_exp x x' e2, rename_exp x x' e3) 263 | | EFix(y, e) -> if x = y then EFix(y, e) else EFix(y, rename_exp x x' e) 264 | | ELoop(f, p, e) -> if x = f || mem x (pvars p) then ELoop(f, p, e) else ELoop(f, p, rename_exp x x' e) 265 | | EG lexp -> EG (rename_exp x x' lexp) 266 | | ELet(p, e1, e2) -> ELet(p, rename_exp x x' e1, if mem x (pvars p) then e2 else rename_exp x x' e2) 267 | | ELetVar(y, z, e) -> ELetVar(y, (if x = z then x' else z), if x = y then e else rename_exp x x' e) 268 | | ECase(e, branches) -> ECase(rename_exp x x' e, rename_branches x x' branches) 269 | | ECon(c, e) -> ECon(c, rename_exp x x' e) 270 | | EF e -> EF (rename_exp x x' e) 271 | | ERun e -> ERun (rename_exp x x' e) 272 | 273 | and rename_branches x x' bs = 274 | List.map (fun (p, e) -> if mem x (pvars p) then (p, e) else (p, rename_exp x x' e)) bs 275 | 276 | 277 | let rec string_of_kind = function 278 | | Int -> "int" 279 | | Lin -> "lin" 280 | | KArrow(KArrow(_, _) as k1, k2) -> 281 | Printf.sprintf "(%s) -> %s" (string_of_kind k1) (string_of_kind k2) 282 | | KArrow(k1, k2) -> 283 | Printf.sprintf "%s -> %s" (string_of_kind k1) (string_of_kind k2) 284 | | KVar x -> x 285 | 286 | let rec self_delimited = function 287 | | Num 288 | | Bool 289 | | String 290 | | Product _ 291 | | Tensor _ 292 | | TVar _ -> true 293 | | TApp(tp, []) -> self_delimited tp 294 | | _ -> false 295 | 296 | let rec string_of_tp = function 297 | | Num -> "num" 298 | | Bool -> "bool" 299 | | String -> "string" 300 | | Pure tp -> Printf.sprintf "!%s" (string_of_tp tp) 301 | | Stream tp -> Printf.sprintf "stream(%s)" (string_of_tp tp) 302 | | Next tp -> Printf.sprintf "next(%s)" (string_of_tp tp) 303 | | G ltp -> Printf.sprintf "G(%s)" (string_of_tp ltp) 304 | | Product tps -> Printf.sprintf "(%s)" (String.concat " & " (List.map string_of_tp tps)) 305 | | Arrow(Arrow(_, _) as tp1, tp2) -> 306 | Printf.sprintf "(%s) -> %s" (string_of_tp tp1) (string_of_tp tp2) 307 | | Arrow(tp1, tp2) -> 308 | Printf.sprintf "%s -> %s" (string_of_tp tp1) (string_of_tp tp2) 309 | | Tensor tps -> Printf.sprintf "(%s)" (String.concat " * " (List.map string_of_tp tps)) 310 | | Dom tp -> Printf.sprintf "dom(%s)" (string_of_tp tp) 311 | | Frame tp -> Printf.sprintf "frame(%s)" (string_of_tp tp) 312 | | Svg tp -> Printf.sprintf "svg(%s)" (string_of_tp tp) 313 | | F ftype -> Printf.sprintf "F(%s)" (string_of_tp ftype) 314 | | Lolli((Lolli(_, _)) as tp1, tp2) -> 315 | Printf.sprintf "(%s) -o %s" (string_of_tp tp1) (string_of_tp tp2) 316 | | Lolli(tp1, tp2) -> 317 | Printf.sprintf "%s -o %s" (string_of_tp tp1) (string_of_tp tp2) 318 | | Forall(a, None, tp) -> Printf.sprintf "forall %s:?. %s" a (string_of_tp tp) 319 | | Forall(a, Some k, tp) -> Printf.sprintf "forall %s:%s. %s" a (string_of_kind k) (string_of_tp tp) 320 | | Exists(a, None, tp) -> Printf.sprintf "exists %s:?. %s" a (string_of_tp tp) 321 | | Exists(a, Some k, tp) -> Printf.sprintf "exists %s:%s. %s" a (string_of_kind k) (string_of_tp tp) 322 | | TVar a -> a 323 | | TApp(tp, tps) -> 324 | let pr tp = 325 | if self_delimited tp 326 | then Printf.sprintf "%s" (string_of_tp tp) 327 | else string_of_tp tp 328 | in 329 | String.concat " " (map pr (tp :: tps)) 330 | | TLet(a, tp, tp') -> Printf.sprintf "let %s = %s in %s" a (string_of_tp tp) (string_of_tp tp') 331 | | TLam(a, tp) -> Printf.sprintf "fun %s -> %s" a (string_of_tp tp) 332 | | TAnnot(tp, k) -> Printf.sprintf "(%s : %s)" (string_of_tp tp) (string_of_kind k) 333 | 334 | 335 | let rec string_of_kind = function 336 | | Lin -> "lin" 337 | | Int -> "int" 338 | | KVar a -> a 339 | | KArrow(KArrow(_, _) as k1, k2) -> Printf.sprintf "(%s) -> %s" (string_of_kind k1) (string_of_kind k2) 340 | | KArrow(k1, k2) -> (string_of_kind k1) ^ " -> " ^ (string_of_kind k2) 341 | 342 | let fmt_tp () = string_of_tp 343 | let fmt_kind () = string_of_kind 344 | 345 | let exp_pos (pos, _) = pos 346 | let pat_pos (pos, _) = pos 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | -------------------------------------------------------------------------------- /ast.mli: -------------------------------------------------------------------------------- 1 | type kind = 2 | | Int 3 | | Lin 4 | | KVar of Base.id 5 | | KArrow of kind * kind 6 | 7 | 8 | type tp = 9 | | Num 10 | | Bool 11 | | String 12 | | Pure of tp 13 | | Next of tp 14 | | Stream of tp 15 | | G of tp 16 | | Product of tp list 17 | | Arrow of tp * tp 18 | | Forall of Base.id * kind option * tp 19 | | Exists of Base.id * kind option * tp 20 | | TApp of tp * tp list 21 | | F of tp 22 | | Tensor of tp list 23 | | Lolli of tp * tp 24 | | Dom of tp 25 | | Frame of tp 26 | | Svg of tp 27 | | TVar of Base.id 28 | | TAnnot of tp * kind 29 | | TLam of Base.id * tp 30 | | TLet of Base.id * tp * tp 31 | 32 | 33 | type pat = Base.pos * pat' 34 | and pat' = 35 | | PTop 36 | | PVar of Base.id 37 | | PBang of pat 38 | | PCon of Base.conid * pat 39 | | PCons of pat * pat 40 | | PNext of pat 41 | | PTuple of pat list 42 | | PF of pat 43 | 44 | type exp = Base.pos * exp' 45 | and exp' = 46 | | EVar of Base.id 47 | | EBang of exp 48 | | ENext of exp 49 | | ETuple of exp list 50 | | ELam of pat * exp 51 | | EApp of exp * exp 52 | | EBool of bool 53 | | EIf of exp * exp * exp 54 | | ENum of float 55 | | EString of string 56 | | ECons of exp * exp 57 | | EAnnot of exp * tp 58 | | EFix of Base.id * exp 59 | | ELoop of Base.id * pat * exp 60 | | EG of exp 61 | | EF of exp 62 | | EOp of Base.op * exp * exp 63 | | ECase of exp * branch list 64 | | ECon of Base.conid * exp 65 | | ELet of pat * exp * exp 66 | | ELetVar of Base.id * Base.id * exp 67 | | ERun of exp 68 | and branch = (pat * exp) 69 | 70 | type datatype = kind * (Base.id * kind) list * (Base.conid * tp) list 71 | 72 | type decl = 73 | | DataBind of Base.pos * Base.id * datatype 74 | | ValueBind of (Base.pos * Base.id * exp * tp) 75 | | ValueDecl of (Base.pos * Base.id * tp) 76 | | TypeBind of (Base.pos * Base.id * tp * kind) 77 | | TypeDecl of (Base.pos * Base.id * kind) 78 | 79 | type program = decl list * exp 80 | 81 | type signature_elt = 82 | | DataDecl of Base.pos * Base.id * datatype 83 | | SigTypeDecl of Base.pos * Base.id * tp 84 | 85 | type signature = signature_elt list 86 | 87 | val pat_eq : pat -> pat -> bool 88 | val exp_eq : exp -> exp -> bool 89 | 90 | val freevars_kind : kind -> Base.Ids.t 91 | val freevars_tp : tp -> Base.Ids.t 92 | val pvars : pat -> Base.Ids.t 93 | val freevars_exp : exp -> Base.Ids.t 94 | 95 | val rename_kind : Base.id -> Base.id -> kind -> kind 96 | val rename_tp : Base.id -> Base.id -> tp -> tp 97 | val rename_exp : Base.id -> Base.id -> exp -> exp 98 | 99 | val string_of_kind : kind -> string 100 | val string_of_tp : tp -> string 101 | val exp_pos : exp -> Base.pos 102 | val pat_pos : pat -> Base.pos 103 | 104 | val fmt_tp : unit -> tp -> string 105 | val fmt_kind : unit -> kind -> string 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /base.ml: -------------------------------------------------------------------------------- 1 | (* Some basic types, common to every stage of the compiler *) 2 | 3 | type id = string 4 | type conid = string 5 | type op = Plus | Minus | Times | Equal | Lt | Leq | Gt | Geq | And | Or 6 | 7 | type pos = Lexing.position * Lexing.position 8 | let dummy_pos = (Lexing.dummy_pos, Lexing.dummy_pos) 9 | 10 | exception ParseError of Lexing.position * string 11 | 12 | let string_of_pos (beg, fin) = 13 | let line p = p.Lexing.pos_lnum in 14 | let col p = (p.Lexing.pos_cnum - p.Lexing.pos_bol) in 15 | Format.sprintf "%d.%d-%d.%d" (line beg) (col beg) (line fin) (col fin) 16 | 17 | let print_op = function 18 | | Plus -> "+" 19 | | Minus -> "-" 20 | | Times -> "*" 21 | | Equal -> "===" 22 | | Lt -> "<" 23 | | Leq -> "<=" 24 | | Gt -> ">" 25 | | Geq -> ">=" 26 | | And -> "&&" 27 | | Or -> "||" 28 | 29 | 30 | 31 | let foldr = List.fold_right 32 | let foldr2 = List.fold_right2 33 | let map = List.map 34 | let map2 = List.map2 35 | let length = List.length 36 | let rec filter_map f = function 37 | | [] -> [] 38 | | x :: xs -> 39 | (match f x with 40 | | None -> filter_map f xs 41 | | Some y -> y :: filter_map f xs) 42 | 43 | let rec fail_map f = function 44 | | [] -> Some [] 45 | | x :: xs -> 46 | (match f x with 47 | | None -> None 48 | | Some y -> 49 | (match fail_map f xs with 50 | | Some ys -> Some (y :: ys) 51 | | None -> None)) 52 | 53 | let rec opt_find f = function 54 | | [] -> None 55 | | x :: xs -> (match f x with 56 | | None -> opt_find f xs 57 | | Some y -> Some y) 58 | 59 | let opt_fold f default = function 60 | | None -> default 61 | | Some x -> f x 62 | 63 | let rec break_list n xs = 64 | if n = 0 then 65 | ([], xs) 66 | else 67 | match xs with 68 | | [] -> assert false 69 | | x :: xs -> let (l, r) = break_list (n-1) xs in (x :: l, r) 70 | 71 | 72 | 73 | let fmt_id () id = id 74 | (* 75 | try 76 | Scanf.sscanf id "%s@$%d" (fun name n -> name) 77 | with 78 | End_of_file -> id 79 | *) 80 | let fmt_pos () pos = string_of_pos pos 81 | 82 | let print_pos out pos = Format.fprintf out "%s" (string_of_pos pos) 83 | 84 | let merge ((p, _), (_, q)) = (p,q) 85 | 86 | exception SyntaxError of pos * string 87 | 88 | module Ids = Set.Make(struct type t = id let compare = compare end) 89 | -------------------------------------------------------------------------------- /base.mli: -------------------------------------------------------------------------------- 1 | type id = string 2 | type conid = string 3 | 4 | type op = Plus | Minus | Times | Equal | Lt | Leq | Gt | Geq | And | Or 5 | 6 | val print_op : op -> string 7 | 8 | type pos = Lexing.position * Lexing.position 9 | val dummy_pos : pos 10 | 11 | val print_pos : Format.formatter -> pos -> unit 12 | val string_of_pos : pos -> string 13 | val merge : pos * pos -> pos 14 | 15 | exception SyntaxError of pos * string 16 | 17 | val map : ('a -> 'b) -> 'a list -> 'b list 18 | val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 19 | val foldr : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b 20 | val foldr2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c 21 | val filter_map : ('a -> 'b option) -> 'a list -> 'b list 22 | val fail_map : ('a -> 'b option) -> 'a list -> 'b list option 23 | val opt_find : ('a -> 'b option) -> 'a list -> 'b option 24 | val opt_fold : ('a -> 'b) -> 'b -> 'a option -> 'b 25 | val break_list : int -> 'a list -> 'a list * 'a list 26 | val length : 'a list -> int 27 | 28 | val fmt_id : unit -> string -> string 29 | val fmt_pos : unit -> pos -> string 30 | 31 | 32 | module Ids : Set.S with type elt = id 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /context.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Base 3 | 4 | type sort = Univ | Exist 5 | type usage = Used | Fresh 6 | type stability = Dyn | Stable 7 | 8 | type hyp = 9 | | Kind of sort * Ast.kind option 10 | | Type of sort * kind * Ast.tp option 11 | | Hyp of stability * Ast.tp * int 12 | | Data of Ast.datatype 13 | | LHyp of Ast.tp * int * usage 14 | | HideLinear 15 | | HideDynamic 16 | 17 | type ctx = (id * hyp) list 18 | 19 | type 'a return = Value of 'a | Error of string 20 | 21 | type state = {ctx : ctx; sym : int; pos : Base.pos} 22 | type 'a t = Ctx of (state -> ('a * state) return) 23 | 24 | let value (v,s) = Value(v, s) 25 | 26 | let return v = Ctx(fun state -> (value(v, state))) 27 | 28 | 29 | let (>>=) (Ctx cmd) f = 30 | Ctx(fun state -> 31 | match cmd state with 32 | | Value(v, state) -> let Ctx op = f v in op state 33 | | Error msg -> Error msg) 34 | 35 | let (>>) m1 m2 = m1 >>= (fun () -> m2) 36 | 37 | let rec seq = function 38 | | [] -> return [] 39 | | m :: ms -> m >>= (fun x -> seq ms >>= (fun xs -> return (x :: xs))) 40 | 41 | let gensym s = fun state -> 42 | let newname = (try Scanf.sscanf s "%s@$%d" (fun name _ -> Printf.sprintf "%s$%d" name state.sym) 43 | with End_of_file -> Printf.sprintf "%s$%d" s state.sym) in 44 | let newstate = {state with sym = state.sym + 1} in 45 | (* Printf.printf "\nGENSYM %s\n\n" newname); *) 46 | Value(newname, newstate) 47 | 48 | let newid s = Ctx(gensym s) 49 | 50 | let fresh rename x term = 51 | newid x >>= (fun x' -> 52 | return (x', rename x x' term)) 53 | 54 | 55 | let error fmt = 56 | Format.ksprintf (fun msg -> Ctx(fun state -> 57 | Error (Format.sprintf "%a: %s" fmt_pos state.pos msg))) fmt 58 | 59 | let orelse (Ctx cmd) (Ctx cmd') = 60 | Ctx(fun s -> 61 | match cmd s with 62 | | Error _ -> cmd' s 63 | | Value(a, s) -> Value(a, s)) 64 | 65 | let get = Ctx(fun s -> Value(s.ctx, s)) 66 | let set ctx = Ctx(fun s -> Value((), {s with ctx = ctx})) 67 | 68 | let setpos pos = Ctx (fun s -> Value((), {s with pos = pos})) 69 | 70 | let print_ids msg ctx = () 71 | (* 72 | Printf.printf "%s: " msg; List.iter (fun (x, _) -> Printf.printf "%s " x) ctx; Printf.printf "\n" 73 | *) 74 | 75 | let print_var x = () 76 | (* Printf.printf "'%s' " x *) 77 | 78 | let push hyp = get >>= (fun ctx -> let ctx' = hyp :: ctx in print_ids (Format.sprintf "push %a" fmt_id (fst hyp)) ctx'; set ctx') 79 | 80 | let pop x = 81 | let rec loop = function 82 | | [] -> error "pop: unbound variable '%a'" fmt_id x 83 | | (y, _) :: ctx when x = y -> return ctx 84 | | (y, hyp) :: ctx -> loop ctx >>= (fun ctx' -> 85 | return ctx') 86 | in 87 | get >>= (fun ctx -> print_ids (Printf.sprintf "pop '%a'" fmt_id x) ctx; loop ctx) >>= set 88 | 89 | let used id = 90 | let rec used = function 91 | | [] -> return () 92 | | (id', LHyp(_, _, Fresh)) :: _ when id = id' -> error "unused linear variable '%a'" fmt_id id 93 | | (x', hyp) :: ctx -> used ctx 94 | in 95 | get >>= used 96 | 97 | let with_hyp (x, hyp) cmd = 98 | push (x, hyp) >> cmd >>= (fun a -> used x >> pop x >> return a) 99 | 100 | let lookup x = 101 | let rec lookup hide_linear hide_dynamic ctx = 102 | match ctx with 103 | | [] -> error "unbound variable '%a'" fmt_id x 104 | | (x', HideLinear) :: ctx' -> 105 | lookup true hide_dynamic ctx' >>= (fun (result, ctx') -> 106 | return (result, (x', HideLinear) :: ctx')) 107 | | (x', HideDynamic) :: ctx' -> 108 | lookup hide_linear true ctx' >>= (fun (result, ctx') -> 109 | return (result, (x', HideLinear) :: ctx')) 110 | | (x', hyp) :: ctx' when x = x' -> 111 | (match hyp with 112 | | LHyp(tp,i,Fresh) when hide_linear -> 113 | error "unbound linear variable '%a' -- G(-) hides linear variables" fmt_id x 114 | | LHyp(tp,i,Fresh) -> 115 | return (hyp, (x', LHyp(tp, i, Used)) :: ctx') 116 | | LHyp(tp,i,Used) -> 117 | error "repeated use of linear variable '%a'" fmt_id x 118 | | Hyp(Dyn, _, _) when hide_dynamic -> 119 | error "unbound variable '%a' -- ! hides dynamic variables" fmt_id x 120 | | _ -> return (hyp, (x, hyp) :: ctx')) 121 | | (x', hyp) :: ctx' -> 122 | lookup hide_linear hide_dynamic ctx' >>= (fun (result, ctx') -> 123 | return (result, (x',hyp) :: ctx')) 124 | in 125 | get >>= (fun ctx -> print_var x; print_ids "lookup" ctx; lookup false false ctx) >>= (fun (v, ctx') -> set ctx' >> return v) 126 | 127 | let update_eqn x input = 128 | let rec update = function 129 | | [] -> error "Unbound variable '%a'" fmt_id x 130 | | (y, Type(Exist, Int, Some _)) :: ctx when x = y -> error "Evar '%a' already set" fmt_id x 131 | | (y, Type(Exist, Int, None)) :: ctx when x = y -> return (List.rev input @ ctx) 132 | | (y, Kind(Exist, None)) :: ctx when x = y -> return (List.rev input @ ctx) 133 | | (y, Kind(Exist, Some _)) :: ctx when x = y -> error "Existential kind var '%a' already set" fmt_id x 134 | | hyp :: ctx -> update ctx >>= (fun ctx' -> return (hyp :: ctx')) 135 | in 136 | get >>= update >>= set 137 | 138 | let rec kind_subst k kvar = function 139 | | Int -> Int 140 | | Lin -> Lin 141 | | KArrow(k1, k2) -> KArrow(kind_subst k kvar k1, 142 | kind_subst k kvar k2) 143 | | KVar kvar' -> (if kvar = kvar' then k else KVar kvar') 144 | 145 | let rec kvar_in_tp_subst k kvar = function 146 | | TVar a -> return (TVar a) 147 | | Forall(a', None, tp_body) -> 148 | newid a' >>= (fun a'' -> 149 | let tp_body = rename_tp a' a'' tp_body in 150 | kvar_in_tp_subst k kvar tp_body >>= (fun tp_result -> 151 | return (Forall(a'', None, tp_result)))) 152 | | Exists(a', None, tp_body) -> 153 | newid a' >>= (fun a'' -> 154 | let tp_body = rename_tp a' a'' tp_body in 155 | kvar_in_tp_subst k kvar tp_body >>= (fun tp_result -> 156 | return (Exists(a'', None, tp_result)))) 157 | | Forall(a', Some kbody, tp_body) -> 158 | newid a' >>= (fun a'' -> 159 | let tp_body = rename_tp a' a'' tp_body in 160 | kvar_in_tp_subst k kvar tp_body >>= (fun tp_result -> 161 | return (Forall(a'', Some(kind_subst k kvar kbody), tp_result)))) 162 | | Exists(a', Some kbody, tp_body) -> 163 | newid a' >>= (fun a'' -> 164 | let tp_body = rename_tp a' a'' tp_body in 165 | kvar_in_tp_subst k kvar tp_body >>= (fun tp_result -> 166 | return (Exists(a'', Some(kind_subst k kvar kbody), tp_result)))) 167 | | Num -> return Num 168 | | Bool -> return Bool 169 | | String -> return String 170 | | Pure tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (Pure tbody')) 171 | | Next tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (Next tbody')) 172 | | Stream tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (Stream tbody')) 173 | | G tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (G tbody')) 174 | | F tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (F tbody')) 175 | | Dom tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (Dom tbody')) 176 | | Frame tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (Frame tbody')) 177 | | Svg tbody -> kvar_in_tp_subst k kvar tbody >>= (fun tbody' -> return (Svg tbody')) 178 | | Arrow(tp1, tp2) -> 179 | kvar_in_tp_subst k kvar tp1 >>= (fun tp1' -> 180 | kvar_in_tp_subst k kvar tp2 >>= (fun tp2' -> 181 | return (Arrow(tp1', tp2')))) 182 | | Lolli(tp1, tp2) -> 183 | kvar_in_tp_subst k kvar tp1 >>= (fun tp1' -> 184 | kvar_in_tp_subst k kvar tp2 >>= (fun tp2' -> 185 | return (Lolli(tp1', tp2')))) 186 | | Product tbodies -> 187 | seq (map (kvar_in_tp_subst k kvar) tbodies) >>= (fun tbodies -> 188 | return (Product tbodies)) 189 | | Tensor tbodies -> 190 | seq (map (kvar_in_tp_subst k kvar) tbodies) >>= (fun tbodies -> 191 | return (Tensor tbodies)) 192 | | TApp(tp, tbodies) -> 193 | kvar_in_tp_subst k kvar tp >>= (fun tp -> 194 | seq (map (kvar_in_tp_subst k kvar) tbodies) >>= (fun tbodies -> 195 | return (TApp(tp, tbodies)))) 196 | | TLam(b, tbody) -> 197 | fresh rename_tp b tbody >>= (fun (b, tbody) -> 198 | kvar_in_tp_subst k kvar tbody >>= (fun tbody -> 199 | return (TLam(b, tbody)))) 200 | | TLet(b, tp1, tp2) -> 201 | fresh rename_tp b tp2 >>= (fun (b, tp2) -> 202 | kvar_in_tp_subst k kvar tp1 >>= (fun tp1 -> 203 | kvar_in_tp_subst k kvar tp2 >>= (fun tp2 -> 204 | return (TLet(b, tp1, tp2))))) 205 | | TAnnot(tp1, k1) -> 206 | let k1 = kind_subst k kvar k1 in 207 | kvar_in_tp_subst k kvar tp1 >>= (fun tp1 -> 208 | return (TAnnot(tp1, k1))) 209 | 210 | 211 | let rec tp_subst (tp : tp) a = function 212 | | TVar a' -> if a = a' then return tp else return (TVar a') 213 | | Forall(a', kopt, tp_body) -> 214 | newid a' >>= (fun a'' -> 215 | let tp_body = rename_tp a' a'' tp_body in 216 | tp_subst tp a tp_body >>= (fun tp_result -> 217 | return (Forall(a'', kopt, tp_result)))) 218 | | Exists(a', kopt, tp_body) -> 219 | newid a' >>= (fun a'' -> 220 | let tp_body = rename_tp a' a'' tp_body in 221 | tp_subst tp a tp_body >>= (fun tp_result -> 222 | return (Exists(a'', kopt, tp_result)))) 223 | | Num -> return Num 224 | | Bool -> return Bool 225 | | String -> return String 226 | | Pure tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (Pure tbody')) 227 | | Next tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (Next tbody')) 228 | | Stream tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (Stream tbody')) 229 | | G tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (G tbody')) 230 | | F tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (F tbody')) 231 | | Dom tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (Dom tbody')) 232 | | Frame tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (Frame tbody')) 233 | | Svg tbody -> tp_subst tp a tbody >>= (fun tbody' -> return (Svg tbody')) 234 | | Arrow(tp1, tp2) -> 235 | tp_subst tp a tp1 >>= (fun tp1' -> 236 | tp_subst tp a tp2 >>= (fun tp2' -> 237 | return (Arrow(tp1', tp2')))) 238 | | Lolli(tp1, tp2) -> 239 | tp_subst tp a tp1 >>= (fun tp1' -> 240 | tp_subst tp a tp2 >>= (fun tp2' -> 241 | return (Lolli(tp1', tp2')))) 242 | | Product tbodies -> 243 | seq (map (tp_subst tp a) tbodies) >>= (fun tbodies -> 244 | return (Product tbodies)) 245 | | Tensor tbodies -> 246 | seq (map (tp_subst tp a) tbodies) >>= (fun tbodies -> 247 | return (Tensor tbodies)) 248 | | TApp(d, tbodies) -> 249 | seq (map (tp_subst tp a) tbodies) >>= (fun tbodies -> 250 | return (TApp(d, tbodies))) 251 | | TLet(b, tp1, tp2) -> 252 | fresh rename_tp b tp2 >>= (fun (b, tp2) -> 253 | tp_subst tp a tp1 >>= (fun tp1 -> 254 | tp_subst tp a tp2 >>= (fun tp2 -> 255 | return (TLet(b, tp1, tp2))))) 256 | | TLam(b, tp1) -> 257 | fresh rename_tp b tp1 >>= (fun (b, tp1) -> 258 | tp_subst tp a tp1 >>= (fun tp1 -> 259 | return (TLam(b, tp1)))) 260 | | TAnnot(tp1, k1) -> 261 | tp_subst tp a tp1 >>= (fun tp1 -> 262 | return (TAnnot(tp1, k1))) 263 | 264 | let rec subst_ctx_tp ctx tp = 265 | match ctx with 266 | | [] -> return tp 267 | | (a, Type(sort, k, Some tycon)) :: ctx -> tp_subst tycon a tp >>= (fun tp -> subst_ctx_tp ctx tp) 268 | | _ :: ctx -> subst_ctx_tp ctx tp 269 | 270 | let subst tp = get >>= (fun ctx -> subst_ctx_tp ctx tp) 271 | 272 | 273 | let rec subst_kind_ctx ctx kind = 274 | match ctx with 275 | | [] -> kind 276 | | (a, Kind(sort, Some k)) :: ctx -> subst_kind_ctx ctx (kind_subst k a kind) 277 | | _ :: ctx -> subst_kind_ctx ctx kind 278 | 279 | let subst_kind k = get >>= (fun ctx -> return (subst_kind_ctx ctx k)) 280 | 281 | 282 | let lookup_datatype (d, tpargs) = 283 | lookup d >>= (function 284 | | Data(k, vars, cenv) when length tpargs = length vars -> 285 | seq (map 286 | (fun (c, tp) -> 287 | foldr2 (fun tparg (a,k') acc -> acc >>= (tp_subst tparg a)) tpargs vars (return tp) >>= (fun tp -> 288 | return (c, tp))) 289 | cenv) 290 | | Data(k, vars, _) -> error "datatype constructor '%s' has wrong number of arguments" d 291 | | _ -> error "variable '%s' not bound to datatype declaration" d) 292 | 293 | let lookup_datatype_by_con c = 294 | let rec loop = function 295 | | [] -> error "unbound datatype constructor '%s'" c 296 | | (x, Data(k, bs, cenv)) :: _ when List.mem_assoc c cenv -> return (x, map fst bs) 297 | | _ :: env -> loop env 298 | in 299 | get >>= loop 300 | 301 | let before_ctx a = 302 | let rec before = function 303 | | [] -> [] 304 | | (a', Type(Univ, Int, None)) :: ctx when a = a' -> ctx 305 | | (a', Type(Exist, Int, _)) :: ctx when a = a' -> ctx 306 | | _ :: ctx -> before ctx 307 | in 308 | get >>= (fun ctx -> return (before ctx)) 309 | 310 | let before x cmd = 311 | get >>= (fun current -> 312 | before_ctx x >>= (fun old -> 313 | set old >> 314 | cmd >>= (fun v -> 315 | set current >> 316 | return v))) 317 | 318 | let with_pure_ctx cmd = 319 | newid "hidedynamic" >>= (fun x -> 320 | with_hyp (x, HideDynamic) cmd) 321 | 322 | let with_nonlinear cmd = 323 | newid "hidelinear" >>= (fun x -> 324 | with_hyp (x, HideLinear) cmd) 325 | 326 | let with_empty_lctx cmd = with_nonlinear cmd 327 | 328 | let rec update_info old cur = 329 | match old, cur with 330 | | [], [] -> [] 331 | | _, ((x2, (HideLinear as hyp)) :: cur') 332 | | _, ((x2, (HideDynamic as hyp)) :: cur') 333 | | _, ((x2, ((Data _) as hyp)) :: cur') 334 | | _, ((x2, (Type(_, _, _) as hyp)) :: cur') -> 335 | (x2, hyp) :: update_info old cur' 336 | | (x1, (Hyp(_, _, _) as hyp)) :: old', (x2, Hyp(_, _, _)) :: cur' -> 337 | if x1 = x2 then (x1, hyp) :: update_info old' cur' else assert false 338 | | (x1, Hyp(_, _, _)) :: old', (x2, LHyp(_, _, _)) :: cur' -> 339 | assert false 340 | | (x1, (LHyp(_, _, _) as hyp)) :: old', (x2, LHyp(_, _, _)) :: cur' -> 341 | if x1 = x2 then (x1, hyp) :: update_info old' cur' else assert false 342 | | (x1, LHyp(_, _, _)) :: old', (x2, Hyp(_, _, _)) :: cur' -> 343 | assert false 344 | | (x1, hyp) :: old', _ -> update_info old' cur 345 | | _ -> assert false 346 | 347 | let rec compatible env1 env2 = 348 | match env1, env2 with 349 | | [], [] -> None 350 | | (x1, LHyp(_, _, usage1)) :: env1', 351 | (x2, LHyp(_, _, usage2)) :: env2' -> 352 | if x1 = x2 && usage1 = usage2 then 353 | compatible env1' env2' 354 | else 355 | Some x1 356 | | ((_, LHyp(_, _, _)) :: _), ((_, _) :: env2') -> compatible env1 env2' 357 | | ((_, _) :: env1'), ((_, LHyp(_, _, _)) :: _) -> compatible env1' env2 358 | | _ :: env1', _ :: env2' -> compatible env1' env2' 359 | | _, _ -> assert false 360 | 361 | let par_seq cmd1 cmd2 = 362 | get >>= (fun old1 -> 363 | cmd1 >>= (fun v1 -> 364 | get >>= (fun cur1 -> 365 | let old2 = update_info old1 cur1 in 366 | set old2 >> 367 | cmd2 >>= (fun v2 -> 368 | get >>= (fun cur2 -> 369 | match compatible cur1 cur2 with 370 | | None -> return (v1, v2) 371 | | Some x -> error "Branches differ on use of variable '%a'" fmt_id x))))) 372 | 373 | let rec parallel = function 374 | | [] -> return [] 375 | | [c] -> c >>= (fun v -> return [v]) 376 | | c :: cs -> par_seq c (parallel cs) >>= (fun (v, vs) -> return (v :: vs)) 377 | 378 | let age x = 379 | let rec find ctx = 380 | try 381 | match List.assoc x ctx with 382 | | Hyp(_, _, i) 383 | | LHyp(_, i, _) -> return i 384 | | _ -> error "can't find age of type variable '%a'" fmt_id x 385 | with 386 | Not_found -> error "unbound variable '%a' in call to 'age'" fmt_id x 387 | in 388 | get >>= find 389 | 390 | let advance free t i = 391 | let body = 392 | Ids.fold 393 | (fun x acc -> 394 | age x >>= (fun j -> 395 | if j <= i 396 | then acc 397 | else acc >>= (fun t -> 398 | return (Lambda.Let(x, Lambda.Force(Lambda.Var x), t))))) 399 | free 400 | (return t) 401 | in 402 | body >>= (fun t -> return (Lambda.Lazy(t))) 403 | 404 | 405 | 406 | let run (Ctx cmd) ctx pos = 407 | match cmd {sym = 0; ctx = ctx; pos = pos} with 408 | | Value(v, s) -> Value(v, s.ctx) 409 | | Error msg -> Error msg 410 | -------------------------------------------------------------------------------- /context.mli: -------------------------------------------------------------------------------- 1 | type sort = Univ | Exist 2 | type usage = Used | Fresh 3 | type stability = Dyn | Stable 4 | 5 | type hyp = 6 | | Kind of sort * Ast.kind option 7 | | Type of sort * Ast.kind * Ast.tp option 8 | | Hyp of stability * Ast.tp * int 9 | | Data of Ast.datatype 10 | | LHyp of Ast.tp * int * usage 11 | | HideLinear 12 | | HideDynamic 13 | 14 | type ctx = (Base.id * hyp) list 15 | 16 | type 'a return = Value of 'a | Error of string 17 | type state = {ctx : ctx; sym : int; pos : Base.pos} 18 | type 'a t = Ctx of (state -> ('a * state) return) 19 | 20 | val return : 'a -> 'a t 21 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 22 | val ( >> ) : unit t -> 'a t -> 'a t 23 | 24 | val seq : 'a t list -> 'a list t 25 | val error : ('a, unit, string, 'b t) format4 -> 'a 26 | val orelse : 'a t -> 'a t -> 'a t 27 | val newid : Base.id -> Base.id t 28 | val push : Base.id * hyp -> unit t 29 | val pop : Base.id -> unit t 30 | val before : Base.id -> 'a t -> 'a t 31 | 32 | 33 | val get : ctx t 34 | val set : ctx -> unit t 35 | val setpos : Base.pos -> unit t 36 | val with_pure_ctx : 'a t -> 'a t 37 | val with_empty_lctx : 'a t -> 'a t 38 | val with_nonlinear : 'a t -> 'a t 39 | val parallel : 'a t list -> 'a list t 40 | val with_hyp : Base.id * hyp -> 'a t -> 'a t 41 | 42 | val lookup : Base.id -> hyp t 43 | 44 | val update_eqn : Base.id -> ctx -> unit t 45 | val tp_subst : Ast.tp -> Base.id -> Ast.tp -> Ast.tp t 46 | 47 | val subst_kind : Ast.kind -> Ast.kind t 48 | val subst : Ast.tp -> Ast.tp t 49 | 50 | val fresh : (Base.id -> Base.id -> 'a -> 'b) -> Base.id -> 'a -> (Base.id * 'b) t 51 | 52 | val compatible : ctx -> ctx -> Base.id option 53 | 54 | val lookup_datatype : 55 | Base.id * Ast.tp list -> (Base.conid * Ast.tp) list t 56 | val lookup_datatype_by_con : 57 | Base.conid -> (Base.id * Base.id list) t 58 | val advance : 59 | Base.Ids.t -> Lambda.term -> int -> Lambda.term t 60 | val run : 'a t -> ctx -> Base.pos -> ('a * ctx) return 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /cover.txt: -------------------------------------------------------------------------------- 1 | ps ⇒ e cover Γ ↝ t | ds 2 | ————————————————————————————————–— 3 | (x, ps ⇒ e) cover A, Γ ↝ t | x, ds 4 | 5 | 6 | (ps ⇒ e)⁺ cover Γ ↝ t | ds 7 | ————————————————————————————————–————————————————————————————— 8 | (⊤, ps ⇒ e)⁺ cover A, Γ ↝ let _ = u in t | u:A, ds 9 | 10 | 11 | (p, q, ps)⁺ cover A, B ↝ t | x, y, ds 12 | ————————————————————————————————–———————————————————————————— 13 | ((p, q), ps)⁺ cover A × B, Γ ↝ let (x,y) = u in t | u, ds 14 | 15 | 16 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | examples: 2 | ../adjsc -I .. -t test1 -o test1 test1.adjs 3 | ../adjsc -I .. -t test2 -o test2 test2.adjs 4 | ../adjsc -I .. -t test3 -o test3 test3.adjs 5 | ../adjsc -I .. -t test4 -o test4 test4.adjs 6 | ../adjsc -I .. -t test5 -o test5 test5.adjs 7 | ../adjsc -I .. -t test6 -o test6 test6.adjs 8 | ../adjsc -I .. -t test7 -o test7 test7.adjs 9 | ../adjsc -I .. -t test8 -o test8 test8.adjs 10 | # ../adjsc -I .. -t test8 -o test8 test8-broken.adjs 11 | # ../adjsc -I .. -t test9 -o test9 test9-broken.adjs 12 | 13 | clean: 14 | rm *.html *.js 15 | 16 | -------------------------------------------------------------------------------- /examples/test0.adjs: -------------------------------------------------------------------------------- 1 | val string_of_bool : bool -> string 2 | let string_of_bool b = 3 | if b then "true" else "false" 4 | 5 | val map : forall a b. !(a -> b) -> alloc -> stream a -> stream b 6 | let rec map (!f) u (x :: xs) = 7 | cons(u, f x, map (!f) u xs) 8 | 9 | val ones : alloc -> stream num 10 | let rec ones u = cons(u, 1, ones u) 11 | 12 | val main : alloc -> G(exists a. dom a) 13 | let main u = 14 | G(let button = run mkButton in 15 | let (button2, F bs) = (run (mouseover u)) button in 16 | let text = run (mkText (map (!string_of_bool) u bs)) in 17 | (run attach) (button2, text)) 18 | 19 | in main 20 | -------------------------------------------------------------------------------- /examples/test1.adjs: -------------------------------------------------------------------------------- 1 | type option a = 2 | | None 3 | | Some of a 4 | 5 | val omap : forall a b. (a -> b) -> option a -> option b 6 | let omap f v = 7 | match v begin 8 | | None -> None 9 | | Some x -> Some (f x) 10 | end 11 | 12 | val ojoin : forall a. option (option a) -> option a 13 | let ojoin v = 14 | match v begin 15 | | Some (Some x) -> Some x 16 | | _ -> None 17 | end 18 | 19 | val blah : G(forall a. dom a -o exists b. dom b) 20 | let blah = G(fun w -> w) 21 | 22 | val main : G(exists a. dom a) 23 | let main = 24 | G(let wroot = run (mkText "") in 25 | run blah wroot) 26 | 27 | in main 28 | -------------------------------------------------------------------------------- /examples/test2.adjs: -------------------------------------------------------------------------------- 1 | val map : ∀ a b. □(a → b) → stream a → stream b 2 | let rec map □f (x :: xs) = f x :: map (□f) xs 3 | 4 | val unfold : ∀ a b. □(a → b × •a) → a → stream b 5 | let rec unfold □f seed = 6 | let (v, •seed) = f seed in 7 | v :: unfold (□f) seed 8 | 9 | val count : stream bool → stream num 10 | let count bs = 11 | unfold 12 | (□(fun (n, (b :: bs)) → 13 | let m : num = if b then n+1 else n in 14 | (m, •(m, bs)))) 15 | (0, bs) 16 | 17 | val dynlabel : stream string → G(∃a. dom a) 18 | let dynlabel msgs = 19 | G(val update : ∀ a. F(stream string) ⊸ dom a ⊸ dom a 20 | let rec update (F(s :: ss)) w = 21 | let w = run (text s) w in 22 | let (w0 :: w1) = w in 23 | w0 :: update (F ss) w1 24 | in 25 | let w = run (mkText "") in 26 | update (F msgs) w) 27 | 28 | val main : G(∃a. dom a) 29 | let main = 30 | G(let w = run mkButton in 31 | let (w, F bs) = run clicks w in 32 | let w0 = run (dynlabel (map (□toString) (count bs))) in 33 | run attach (w, w0)) 34 | 35 | in main 36 | -------------------------------------------------------------------------------- /examples/test3.adjs: -------------------------------------------------------------------------------- 1 | val bool_to_string : bool -> string 2 | let bool_to_string b = if b then "true" else "false" 3 | 4 | val map : forall a b. !(a -> b) -> stream a -> stream b 5 | let rec map !f (x :: xs) = cons(f x, map (!f) xs) 6 | 7 | val unfold : forall a b. !(a -> b & next a) -> a -> stream b 8 | let rec unfold (!step) s1 = 9 | let (x, next s2) = step s1 in 10 | cons(x, unfold (!step) s2) 11 | 12 | val counter : stream bool -> stream num 13 | let counter bs = 14 | val step : !(num & stream bool -> num & next(num & stream bool)) 15 | let step = !(fun (n, b :: bs) -> 16 | (n, if b then next(n+1, bs) else next(n, bs))) in 17 | unfold step (0, bs) 18 | 19 | val dynlabel : stream string -> G(exists a. dom a) 20 | let dynlabel msgs = 21 | G(val update : forall a. F(stream string) -o dom a -o dom a 22 | let rec update (F(s :: ss)) w = 23 | let w = run (text s) w in 24 | let (w0, next w1) = run split w in 25 | run merge (w0, next(update (F ss) w1)) 26 | in 27 | let w = run (mkText "") in 28 | update (F msgs) w) 29 | 30 | val main : G(exists a. dom a) 31 | let main = 32 | G(let button = run mkButton in 33 | let (button, F bs) = run mouseover button in 34 | let text = run (dynlabel (map (!toString) (counter bs))) in 35 | run attach (button, text)) 36 | 37 | in main 38 | -------------------------------------------------------------------------------- /examples/test4.adjs: -------------------------------------------------------------------------------- 1 | val bool_to_string : bool -> string 2 | let bool_to_string b = if b then "true" else "false" 3 | 4 | val map : forall a b. !(a -> b) -> stream a -> stream b 5 | let rec map !f (x :: xs) = cons(f x, map (!f) xs) 6 | 7 | val unfold : forall a b. !(a -> b & next a) -> a -> stream b 8 | let rec unfold (!step) s1 = 9 | let (x, next s2) = step s1 in 10 | cons(x, unfold (!step) s2) 11 | 12 | val counter : stream bool -> stream num 13 | let counter bs = 14 | val step : !(num & stream bool -> num & next(num & stream bool)) 15 | let step = !(fun (n, b :: bs) -> 16 | (n, if b then next(n+1, bs) else next(n, bs))) in 17 | unfold step (0, bs) 18 | 19 | val dynlabel : stream string -> G(exists a. dom a) 20 | let dynlabel msgs = 21 | G(val update : forall a. F(stream string) -o dom a -o dom a 22 | let rec update (F(s :: ss)) w = 23 | let w = run (text s) w in 24 | let (w0, next w1) = run split w in 25 | run merge (w0, next(update (F ss) w1)) 26 | in 27 | let w = run (mkText "") in 28 | update (F msgs) w) 29 | 30 | val main : G(exists a. dom a) 31 | let main = 32 | G(let button = run mkButton in 33 | let (button, F bs) = run clicks button in 34 | let text = run (dynlabel (map (!toString) (counter bs))) in 35 | run attach (button, text)) 36 | 37 | in main 38 | -------------------------------------------------------------------------------- /examples/test5.adjs: -------------------------------------------------------------------------------- 1 | val bool_to_string : bool -> string 2 | let bool_to_string b = if b then "true" else "false" 3 | 4 | val map : forall a b. !(a -> b) -> stream a -> stream b 5 | let rec map !f (x :: xs) = cons(f x, map (!f) xs) 6 | 7 | val unfold : forall a b. !(a -> b & next a) -> a -> stream b 8 | let rec unfold (!step) s1 = 9 | let (x, next s2) = step s1 in 10 | cons(x, unfold (!step) s2) 11 | 12 | val counter : stream bool -> stream bool -> stream num 13 | let counter bs rs = 14 | val step : !(num & stream bool & stream bool -> num & next(num & stream bool & stream bool)) 15 | let step = !(fun (n, b :: bs, reset :: rs) -> 16 | if reset then 17 | (0, next(0, bs, rs)) 18 | else 19 | (n, if b then next(n+1, bs, rs) else next(n, bs, rs))) in 20 | unfold step (0, bs, rs) 21 | 22 | val dynlabel : stream string -> G(exists a. dom a) 23 | let dynlabel msgs = 24 | G(val update : forall a. F(stream string) -o dom a -o dom a 25 | let rec update (F(s :: ss)) w = 26 | let w = run (text s) w in 27 | let (w0, next w1) = run split w in 28 | run merge (w0, next(update (F ss) w1)) 29 | in 30 | let w = run (mkText "") in 31 | update (F msgs) w) 32 | 33 | val main : G(exists a. dom a) 34 | let main = 35 | G(let button = run mkButton in 36 | let (button, F bs) = run mouseover button in 37 | let (button, F rs) = run clicks button in 38 | let text = run (dynlabel (map (!toString) (counter bs rs))) in 39 | run attach (button, text)) 40 | 41 | in main 42 | -------------------------------------------------------------------------------- /examples/test6.adjs: -------------------------------------------------------------------------------- 1 | type option a = None | Some of a 2 | 3 | type list a = Nil | Cons of a & list a 4 | 5 | val maplist : forall a b. (a -> b) -> list a -> list b 6 | let maplist f = 7 | fun loop iter xs -> 8 | match xs begin 9 | | Nil -> Nil 10 | | Cons(y, ys) -> Cons(f y, iter ys) 11 | end 12 | 13 | type event = 14 | | Nothing 15 | | Digit of num 16 | | Clear 17 | | Push 18 | | Pop 19 | | BinOp of (num -> num -> num) 20 | | UnOp of (num -> num) 21 | 22 | val choose : event & event -> event 23 | let choose (e1, e2) = 24 | match e1 begin 25 | | Nothing -> e2 26 | | e1 -> e1 27 | end 28 | 29 | val step : event -> list num -> list num 30 | let step e stack = 31 | let pair : event & list num = (e, stack) in 32 | match pair begin 33 | | (Digit n, Cons(m, rest)) -> Cons(n + 10 * m, rest) 34 | | (Digit n, Nil) -> Cons(n, Nil) 35 | | (Clear, Cons(n, rest)) -> Cons(0, rest) 36 | | (Push, stack) -> Cons(0, stack) 37 | | (Pop, Cons(_, rest)) -> rest 38 | | (BinOp f, Cons(n, Cons(m, rest))) -> Cons(f n m, rest) 39 | | (UnOp f, Cons(n, rest)) -> Cons(f n, rest) 40 | | (_,_) -> stack 41 | end 42 | 43 | val display : list num -> string 44 | let loop display ns = 45 | match ns begin 46 | | Nil -> "--" 47 | | Cons(n, Nil) -> toString n 48 | | Cons(m, xs) -> cat(toString m, cat(" ", display xs)) 49 | end 50 | 51 | val map : forall a b. !(a -> b) -> stream a -> stream b 52 | let rec map (!f) (x :: xs) = 53 | cons(f x, map (!f) xs) 54 | 55 | val zip : forall a b. stream a -> stream b -> stream (a & b) 56 | let rec zip (a :: as) (b :: bs) = 57 | cons((a,b), zip as bs) 58 | 59 | val mux : stream event -> stream event -> stream event 60 | let mux es1 es2 = map (!choose) (zip es1 es2) 61 | 62 | val button : string -> event -> G((exists a. dom a) * F (stream event)) 63 | let button label e = 64 | G(let w = run mkButton in 65 | let w = run (text label) w in 66 | let (w, F bs) = run clicks w in 67 | (w, F (map (!(fun b -> if b then e else Nothing)) bs))) 68 | 69 | val numeric : num -> G((exists a. dom a) * F (stream event)) 70 | let numeric n = button (toString n) (Digit n) 71 | 72 | 73 | 74 | // loops 75 | val panel_test12 : G(exists (a : int). I) 76 | let panel_test12 = 77 | G(let () = ( () : exists (a : int). I) in ()) 78 | 79 | 80 | // loops 81 | val panel_test11 : G(exists (a : int). I) -> G(exists (a : int). I) 82 | let panel_test11 b1 = 83 | G(let () = run b1 in ()) 84 | 85 | // terminates 86 | val panel_test10 : G(exists (a : int). I * I) -> G(exists (a : int). I * I) 87 | let panel_test10 b1 = 88 | G(let w = run b1 in w) 89 | 90 | // terminates 91 | val panel_test10 : G(exists (a : int). I * I) -> G(exists (a : int). I * I) 92 | let panel_test10 b1 = 93 | G(run b1) 94 | 95 | // terminates 96 | val panel_test9 : G(exists (a : int). I) -> G(exists (a : int). I) 97 | let panel_test9 b1 = 98 | G(let w = run b1 in w) 99 | 100 | // loops 101 | val panel_test8 : G(exists (a : int). I * I) -> G(exists (a : int). I * I) 102 | let panel_test8 b1 = 103 | G(let (w1, fbs) = run b1 in 104 | (w1, fbs)) 105 | 106 | 107 | // terminates 108 | val panel_test7 : G((exists (a : int). dom a) * I) -> G((exists (a : int). dom a) * I) 109 | let panel_test7 b1 = 110 | G(let (w1, fbs) = run b1 in 111 | (w1, fbs)) 112 | 113 | 114 | // terminates 115 | val panel_test6 : G(I * I) -> G(I * I) 116 | let panel_test6 b1 = 117 | G(let (w1, fbs) = run b1 in 118 | (w1, fbs)) 119 | 120 | // loops 121 | val panel_test5 : G(exists a. dom a * I) -> G(exists a. dom a * I) 122 | let panel_test5 b1 = 123 | G(let (w1, fbs) = run b1 in 124 | (w1, fbs)) 125 | 126 | 127 | // loops 128 | val panel_test4 : G(exists a. dom a * F (stream (option event))) -> G(exists a. dom a * F (stream (option event))) 129 | let panel_test4 b1 = 130 | G(let (w1, fbs) = run b1 in 131 | (w1, fbs)) 132 | 133 | // terminates 134 | val panel_test3 : G(F (stream (option event))) -> G(F (stream (option event))) 135 | let panel_test3 b1 = 136 | G(let F bs = run b1 in F bs) 137 | 138 | // terminates 139 | val panel_test2 : G(exists a. dom a) -> G(exists a. dom a) 140 | let panel_test2 b = 141 | G(let w = run b in w) 142 | 143 | // loops 144 | val panel_test1 : G(exists a. dom a * F (stream (option event))) -> G(exists a. dom a * F (stream (option event))) 145 | let panel_test1 b1 = 146 | G(let (w1, F bs) = run b1 in 147 | (w1, F bs)) 148 | 149 | val panel_test0 : 150 | G(exists a. dom a) -> 151 | G(exists a. dom a) -> 152 | G(exists a. dom a) -> 153 | G(exists a. dom a) 154 | let panel_test0 mkBox mkB1 mkB2 = 155 | G(let box = run mkBox in 156 | let w1 = run mkB1 in 157 | let w2 = run mkB2 in 158 | let box = run attach (box, w1) in 159 | let box = run attach (box, w2) in 160 | box) 161 | 162 | val panel : 163 | G(exists a. dom a) -> 164 | (G((exists a. dom a) * F (stream event)) & 165 | G((exists a. dom a) * F (stream event)) & 166 | G((exists a. dom a) * F (stream event)) & 167 | G((exists a. dom a) * F (stream event))) -> 168 | G((exists a. dom a) * F (stream event)) 169 | let panel mkBox (b1, b2, b3, b4) = 170 | G(let box = run mkBox in 171 | let (w1, F es1) = run b1 in 172 | let (w2, F es2) = run b2 in 173 | let (w3, F es3) = run b3 in 174 | let (w4, F es4) = run b4 in 175 | let box = run attach (box, w1) in 176 | let box = run attach (box, w2) in 177 | let box = run attach (box, w3) in 178 | let box = run attach (box, w4) in 179 | (box, F (mux es1 (mux es2 (mux es3 es4))))) 180 | 181 | 182 | 183 | val main : G(exists a. dom a) 184 | let main = mkButton 185 | 186 | in main 187 | -------------------------------------------------------------------------------- /examples/test7.adjs: -------------------------------------------------------------------------------- 1 | type event = 2 | | Nothing 3 | | Digit of num 4 | | Clear 5 | | Push 6 | | Pop 7 | | BinOp of (num → num → num) 8 | | UnOp of (num → num) 9 | 10 | type state : int 11 | let state = list num 12 | 13 | type window : lin 14 | let window = ∃a. dom a 15 | 16 | type input : int 17 | let input = G(window ⊗ F (stream event)) 18 | 19 | val choose : event × event → event 20 | let choose (e1, e2) = 21 | match e1 begin 22 | | Nothing → e2 23 | | e1 → e1 24 | end 25 | 26 | val step : event → state → state 27 | let step e stack = 28 | let pair = (e, stack) in 29 | match pair begin 30 | | (Digit n, Cons(m, rest)) → Cons(n + (10 * m), rest) 31 | | (Digit n, Nil) → Cons(n, Nil) 32 | | (Clear, Cons(n, rest)) → Cons(0, rest) 33 | | (Push, stack) → Cons(0, stack) 34 | | (Pop, Cons(_, rest)) → rest 35 | | (BinOp f, Cons(n, Cons(m, rest))) → Cons(f n m, rest) 36 | | (UnOp f, Cons(n, rest)) → Cons(f n, rest) 37 | | (_,_) → stack 38 | end 39 | 40 | val states : state → stream event → stream state 41 | let rec states state (e :: es) = 42 | let □state = □(step e state) in 43 | state :: states state es 44 | 45 | val ints : num → stream num 46 | let rec ints n = n :: ints (n+1) 47 | 48 | val stackToString : state → string 49 | let loop stackToString ns = 50 | match ns begin 51 | | Nil → "--" 52 | | Cons(n, Nil) → toString n 53 | | Cons(m, xs) → cat(toString m, cat(" ", stackToString xs)) 54 | end 55 | 56 | val map : ∀ a b. □(a → b) → stream a → stream b 57 | let rec map (□f) (x :: xs) = 58 | f x :: map (□f) xs 59 | 60 | val zip : ∀ a b. stream a → stream b → stream (a × b) 61 | let rec zip (a :: as) (b :: bs) = (a,b) :: zip as bs 62 | 63 | val unfold : ∀ a b. □(a → b × •a) → a → stream b 64 | let rec unfold (□f) seed = 65 | let (b, •seed) = f seed in 66 | b :: unfold (□f) seed 67 | 68 | val mux : stream event → stream event → stream event 69 | let mux es1 es2 = map (□choose) (zip es1 es2) 70 | 71 | val button : string → event → input 72 | let button label e = 73 | G(let w = run mkButton in 74 | let w = run (text label) w in 75 | let w = run (width "4em") w in 76 | let (w, F bs) = run clicks w in 77 | (w, F (map (□(fun b → if b then e else Nothing)) bs))) 78 | 79 | val numeric : num → input 80 | let numeric n = button (toString n) (Digit n) 81 | 82 | val panel : G window → (input × input × input × input) → input 83 | let panel mkBox (b1, b2, b3, b4) = 84 | G(let box = run mkBox in 85 | let (w1, F es1) = run b1 in 86 | let (w2, F es2) = run b2 in 87 | let (w3, F es3) = run b3 in 88 | let (w4, F es4) = run b4 in 89 | let box = run attach (box, w1) in 90 | let box = run attach (box, w2) in 91 | let box = run attach (box, w3) in 92 | let box = run attach (box, w4) in 93 | (box, F (mux es1 (mux es2 (mux es3 es4))))) 94 | 95 | val inputPanel : input 96 | let inputPanel = 97 | panel vbox (panel hbox (numeric 7, 98 | numeric 8, 99 | numeric 9, 100 | button "x" (BinOp (fun a b → a * b))), 101 | panel hbox (numeric 4, 102 | numeric 5, 103 | numeric 6, 104 | button "+" (BinOp (fun a b → a + b))), 105 | panel hbox (numeric 1, 106 | numeric 2, 107 | numeric 3, 108 | button "Pop" (Pop)), 109 | panel hbox (button "+/-" (UnOp (fun n → 0 - n)), 110 | numeric 0, 111 | button "C" (Clear), 112 | button "Push" (Push))) 113 | 114 | val dynlabel : stream string → G window 115 | let dynlabel ss = 116 | G(val displayText : ∀ a. F (stream string) ⊸ dom a ⊸ dom a 117 | let rec displayText F(s :: ss) w = 118 | let w = run (text s) w in 119 | let w0 :: w1 = w in 120 | w0 :: displayText (F ss) w1 121 | in 122 | let w = run (mkText "") in 123 | displayText (F ss) w) 124 | 125 | val main : G window 126 | let main = 127 | G(let (wpanel, F events) = run inputPanel in 128 | let wdisplay = run ((let events : stream state = states (Nil) events in 129 | let labels : stream string = map (□stackToString) events in 130 | dynlabel labels) : G window) in 131 | let wdisplay = run (backgroundColor "rgb(60,60,60)") wdisplay in 132 | let wdisplay = run (fontFamily "monospace") wdisplay in 133 | let box = run vbox in 134 | let box = run attach (box, wdisplay) in 135 | let box = run attach (box, wpanel) in 136 | box) 137 | 138 | in main 139 | -------------------------------------------------------------------------------- /examples/test8-broken.adjs: -------------------------------------------------------------------------------- 1 | type window : int 2 | let window = G(exists a. dom a) 3 | 4 | val map : forall a b. !(a -> b) -> alloc -> stream a -> stream b 5 | let rec map (!f) u (x :: xs) = 6 | cons(u, f x, map (!f) u xs) 7 | 8 | val zip : forall a b. alloc -> stream a & stream b -> stream (a & b) 9 | let rec zip u ((x :: xs), (y :: ys)) = 10 | cons(u, (x,y), zip u (xs, ys)) 11 | 12 | val always : forall a. alloc -> !a -> stream a 13 | let rec always u (!x) = cons(u, x, always u (!x)) 14 | 15 | val dynbutton : alloc -> window 16 | let dynbutton u = 17 | G(val grow : forall a. dom a -o F(stream bool) -o dom a 18 | let rec grow w (F (b :: bs)) = 19 | if b then 20 | let w1 = run (mkText "Clicked!") in 21 | let w = run attach (w, w1) in 22 | let (f, next wrest) = run split w in 23 | run merge (f, next(grow wrest (F bs))) 24 | else 25 | let (f, next wrest) = run split w in 26 | run merge (f, next(grow wrest (F bs))) 27 | in 28 | let wroot = run vbox in 29 | let wbutton = run mkButton in 30 | let wtext = run (mkText "Click me") in 31 | let wbutton = run attach (wbutton, wtext) in 32 | // let (wbutton, fbs) = run (clicks u) wbutton in 33 | let wroot = run attach (wroot, wbutton) in 34 | grow wroot (F (always u (!false)))) 35 | 36 | 37 | 38 | in 39 | 40 | dynbutton 41 | -------------------------------------------------------------------------------- /examples/test8.adjs: -------------------------------------------------------------------------------- 1 | val map : ∀ a b. !(a → b) → stream a → stream b 2 | let rec map !f ns = 3 | let x :: xs = ns in 4 | cons(f x, map (!f) xs) 5 | 6 | val zip : ∀ a b. stream a → stream b → stream (a × b) 7 | let rec zip (a :: as) (b :: bs) = cons((a, b), zip as bs) 8 | 9 | val or : bool × bool → bool 10 | let or (b1, b2) = if b1 then true else b2 11 | 12 | val orStream : stream bool → stream bool → stream bool 13 | let orStream bs1 bs2 = map (!or) (zip bs1 bs2) 14 | 15 | val aButton : G(∃ a. dom a) 16 | let aButton = G(let b = run mkButton in 17 | let txt = run (mkText "Click me!") in 18 | run attach (b, txt)) 19 | 20 | val growButton : G(∀a. dom a ⊗ F(stream bool) ⊸ dom a) 21 | let growButton = 22 | G(val recur : ∀ a. dom a ⊗ F(stream bool) ⊸ dom a 23 | let rec recur (w, F (b :: bs)) = 24 | if b then 25 | let w2 = run aButton in 26 | let (w2, F (b2 :: bs2)) = run clicks w2 in 27 | let w = run attach (w, w2) in 28 | let w0 :: wnext = w in 29 | w0 :: recur (wnext, F (orStream bs bs2)) 30 | else 31 | let w0 :: wnext = w in 32 | w0 :: recur (wnext, F bs) 33 | in 34 | recur) 35 | 36 | val main : G(∃a. dom a) 37 | let main = G(let w = run aButton in 38 | let (w, F bs) = run clicks w in 39 | run growButton (w, F bs)) 40 | 41 | in main 42 | -------------------------------------------------------------------------------- /examples/test9-broken.adjs: -------------------------------------------------------------------------------- 1 | val simplify : option string -> string 2 | let simplify o = 3 | match o begin 4 | | None -> "" 5 | | Some s -> s 6 | end 7 | 8 | val map : forall a b. alloc -> !(a -> b) -> stream a -> stream b 9 | let rec map u (!f) (x :: xs) = cons(u, f x, map u (!f) xs) 10 | 11 | 12 | val keypressTest : alloc -> G(exists a. dom a) 13 | let keypressTest u = 14 | G(val grow : forall a. dom a -o F string -o F(stream string) -o dom a 15 | let rec grow w (F s1) (F (s2 :: ss)) = 16 | let w = run (text (cat (s1, s2))) w in 17 | let (wnow, next wnext) = run split w in 18 | run merge (wnow, next(grow wnext (F (cat (s1, s2))) (F ss))) 19 | in 20 | let w = run (mkText "Start typing here: ") in 21 | let (w, F keys) = run (keypress u) w in 22 | grow w (F "Start typing here: ") (F (map u (!simplify) keys))) 23 | 24 | in 25 | 26 | keypressTest 27 | -------------------------------------------------------------------------------- /foo.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | -------------------------------------------------------------------------------- /higher-kinds.txt: -------------------------------------------------------------------------------- 1 | How should we handle: 2 | 3 | Γ ⊢ α • S ≤ α̂ • S' : (κ¹, …, κⁿ) → κ ⊣ Γ' work? 4 | 5 | Cases: 6 | 7 | Case: Γ ⊢ α̂ • S, A ≤ β • S, B : (κ¹, …, κⁿ, κⁿ⁺¹) → κ ⊣ Γ'' 8 | if Γ ⊢ A ≡ B : κⁿ⁺¹ ⊣ Γ' 9 | & Γ' ⊢ α̂ • S ≤ β • S : (κ¹, …, κⁿ) → κⁿ⁺¹ → κ ⊣ Γ'' 10 | 11 | Case: Γ ⊢ α̂ • S, A ≤ β : (κ¹, …, κⁿ) → κ ⊣ Γ' 12 | Fail 13 | 14 | Case: Γ,α̂, Γ'' ⊢ α̂ • β¹ … βⁿ ≤ α • S : (κ¹, …, κⁿ) → κ ⊣ Γ',α̂=λβ¹ … βⁿ. α (S),Γ'' 15 | if Γ ⊢ λβ¹ … βⁿ. α (S) ≤ κ¹ → … → κⁿ → κ ⊣ Γ' 16 | 17 | Case: Γ ⊢ α̂ • · ≤ β • S, A : (κ¹, …, κⁿ) → κ ⊣ Γ' 18 | if Γ ⊢ α̂ (·) ≤ β • S, A : κ¹ → ... κⁿ → κ ⊣ Γ' 19 | 20 | Case: α (S) ≤ β (S') 21 | α = β and S ≡ S' 22 | 23 | Otherwise: 24 | fail 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | A ::= λα.A | A → B | ∀α:κ.A | R 34 | R ::= h (S) 35 | h ::= (A : κ) | α 36 | S ::= ε | S, A 37 | 38 | N ::= λα.A | A → B | ∀α:κ.A | α (S) 39 | 40 | First, weak-head reduction, in spine form. (We allow eta-short terms.) 41 | 42 | A ⇓ N 43 | N @ S : κ ⇓ N' 44 | 45 | 46 | ——————————— 47 | λα.A ⇓ λα.A 48 | 49 | 50 | ————————————— 51 | A → B ⇓ A → B 52 | 53 | 54 | ——————————————— 55 | ∀α:κ.A ⇓ ∀α:κ.A 56 | 57 | 58 | ————————————— 59 | α (S) ⇓ α (S) 60 | 61 | 62 | A ⇓ N 63 | N @ S : κ ⇓ N' 64 | ————————————————— 65 | (A : κ) (S) ⇓ N' 66 | 67 | 68 | ——————————————————————————— 69 | α (S) @ S' : κ ⇓ α (S · S') 70 | 71 | 72 | ————————————— 73 | N @ ε : κ ⇓ N 74 | 75 | 76 | [(B:κ₁)/α]A ⇓ N 77 | N @ S : κ ⇓ N' 78 | —————————————————————————————— 79 | (λα.A) @ (B, S) : κ₁ → κ ⇓ N' 80 | 81 | 82 | [(B:κ₁)/α]A ⇓ α (S') 83 | ————————————————————————————————————— 84 | (λα.A) @ (B, S) : κ₁ → κ ⇓ α (S' · S) 85 | 86 | 87 | Γ ⊢ A ≤ B : κ ⊣ Γ' 88 | 89 | 90 | 91 | A ⇓ N 92 | B ⇓ M 93 | Γ ▷ N ≤ M : κ ◁ Γ' 94 | —————————————————— 95 | Γ ⊢ A ≤ B : κ ⊣ Γ' 96 | 97 | 98 | Γ, α̂:κ=? ⊢ [α̂/α]A ≤ B ⊣ Γ' 99 | —————————————————————————— 100 | Γ ▷ ∀α:κ. A ≤ B : ∗ ◁ Γ' 101 | 102 | 103 | Γ, α:κ ⊢ A ≤ B ⊣ Γ', α:κ, Δ 104 | ——————————————————————————— 105 | Γ ▷ A ≤ ∀α:κ. B : ∗ ◁ Γ' 106 | 107 | 108 | Γ, α:κ₁ ⊢ (A : κ₁ → κ) (α) ≤ (B : : κ₁ → κ) (α) ⊣ Γ', α:κ₁, Γ'' 109 | ——————————————————————————————————————————————————————————————— 110 | Γ ▷ A ≤ B : κ₁ → κ ◁ Γ' 111 | 112 | 113 | Γ ⊢ λα¹…αⁿ.N⇐ κ ⊣ Γ' ∀i,j ∈ {1...n}. α[i] = α[j] ⇔ i = j 114 | —————————————————————————————————————————————————————————— 115 | Γ, α̂:κ=?, Δ ▷ α̂ (α¹, …, αⁿ) ≤ N : ∗ ⊣ Γ', α̂:κ=λα¹…αⁿ.A, Δ 116 | 117 | 118 | Γ ⊢ λα¹…αⁿ.N ⇐ κ ⊣ Γ' ∀i,j ∈ {1...n}. α[i] = α[j] ⇔ i = j 119 | —————————————————————————————————————————————————————————— 120 | Γ, α̂:κ=?, Δ ▷ N ≤ α̂ (α¹, …, αⁿ) : ∗ ◁ Γ', α̂:κ=λα¹…αⁿ.A, Δ 121 | 122 | 123 | Γ ⊢ A¹ ≡ B¹ : κ¹ ⊣ Γ¹ 124 | Γⁿ ⊢ Aⁿ ≡ Bⁿ : κⁿ ⊣ Γⁿ⁺¹ 125 | ————————————————————————————————————————————— 126 | Γ ▷ α (A¹, …, Aⁿ) ≤ α (B¹, …, Bⁿ) : ∗ ◁ Γⁿ⁺¹ 127 | 128 | 129 | Γ ▷ α (A¹, …, Aⁿ) ≤ β̂ (B¹, …, Bʲ) : ∗ ◁ Γⁿ⁺¹ 130 | 131 | 132 | 133 | 134 | -------------------------------------------------------------------------------- /js.ml: -------------------------------------------------------------------------------- 1 | (* Abstract Syntax for a fragment of Javascript 2 | 3 | Our goal is to translate terms of our lambda-calculus into Javascript. 4 | This is slightly complicated since Javascript has a statement/expression 5 | distinction, and the lambda calculus doesn't. Furthermore, it would be 6 | nice if we could generate reasonably natural-looking JS code. 7 | 8 | To address both of these issues, we will use a "destination-passing style" 9 | translation, which is basically a kind of baby CPS transform. 10 | 11 | *) 12 | 13 | open Base 14 | open Pp 15 | 16 | type exp = 17 | | Int of int 18 | | Num of float 19 | | Bool of bool 20 | | Fun of id option * id list * statement list 21 | | String of string 22 | | Id of id 23 | | Apply of exp * exp list 24 | | Op of op * exp * exp 25 | | Array of exp list 26 | | Deref of exp * exp 27 | | Method of exp * string * exp list 28 | | New of string * exp list 29 | 30 | and statement = 31 | | LetNull of id 32 | | LetVar of id * exp 33 | | LetDef of id * exp 34 | | Return of exp 35 | | IfThenElse of exp * statement list * statement list 36 | | Assign of id * exp 37 | | WhileTrue of statement list 38 | | Continue 39 | | Abort 40 | | Break 41 | | Switch of exp * (Base.conid * statement list) list 42 | 43 | type 'a optree = 44 | | Leaf of 'a 45 | | Node of op * 'a optree * 'a optree 46 | 47 | let rec opify = function 48 | | Op(op, e1, e2) -> Node(op, opify e1, opify e2) 49 | | e -> Leaf e 50 | 51 | let precedence = function 52 | | Or -> 1 53 | | And -> 2 54 | | Equal -> 3 55 | | Lt | Leq | Gt | Geq -> 4 56 | | Plus | Minus -> 5 57 | | Times -> 6 58 | 59 | 60 | let print_operator print_leaf optree = 61 | let rec loop prec = function (* prec is the current precedence *) 62 | | Node(op, o1, o2) -> 63 | let parenthesize printer = seq [str "("; atcol printer; str ")"] in 64 | let p = precedence op in 65 | let exp = seq [loop p o1; str " "; str (print_op op); str " "; loop p o2] in 66 | if prec > p then parenthesize exp else exp 67 | | Leaf t -> print_leaf t 68 | in loop 0 optree 69 | 70 | 71 | let rec print_exp = function 72 | | Int n -> int n 73 | | Num x -> float x 74 | | Bool b -> bool b 75 | | String s -> qstr s 76 | | Fun(None, xs, stmts) -> seq [str "function "; print_args (map str xs); print_block stmts] 77 | | Fun(Some f, xs, stmts) -> seq [str "function "; str f; print_args (map str xs); print_block stmts] 78 | | Id x -> str x 79 | | Apply(e, es) -> seq [print_exp e; print_args (map print_exp es)] 80 | | Op(_, _, _) as e -> print_operator print_exp (opify e) 81 | | New(classname, args) -> seq [str "new "; str classname; print_args (map print_exp args)] 82 | | Array es -> print_array (map print_exp es) 83 | | Deref(e, e') -> seq [print_exp e; str "["; print_exp e'; str "]"] 84 | | Method((Id _) as e, name, args) 85 | | Method((Method(_, _, _)) as e, name, args) -> 86 | seq [print_exp e; str "."; str name; print_args (map print_exp args)] 87 | | Method(e, name, args) -> seq [str "("; print_exp e; str ")."; str name; print_args (map print_exp args)] 88 | 89 | and print_sequence left right sep ps = 90 | let b = List.exists multiline ps in 91 | let rec loop = function 92 | | [] -> nil 93 | | [p] -> p 94 | | p :: ps -> seq [p; sep; break b; loop ps] 95 | in 96 | seq [left; atcol (loop ps); right] 97 | 98 | and print_args (args : Pp.printer list) = print_sequence (str "(") (str ")") (str ",") args 99 | and print_array (args : Pp.printer list) = print_sequence (str "[") (str "]") (str ",") args 100 | 101 | and print_stmt (s : statement) : Pp.printer = 102 | match s with 103 | | Abort -> seq [str "throw "; qstr "Impossible branch -- compiler error"; str ";"] 104 | | LetNull x -> seq (map str ["let "; x; "= null;"]) 105 | | LetVar(x, e) 106 | | LetDef(x, e) -> seq [str "let "; str x; str " = "; print_exp e; str ";"] 107 | | Continue -> str "continue;" 108 | | Break -> str "break;" 109 | | Return e -> seq [str "return "; print_exp e; str ";"] 110 | | IfThenElse(e, s1, s2) -> seq [str "if ("; print_exp e; str ") "; 111 | print_block s1; 112 | str " else "; 113 | print_block s2] 114 | | Assign(x, e) -> seq [str x; str " = "; print_exp e; str ";"] 115 | | WhileTrue stmts -> seq [str "while (true) "; print_block stmts] 116 | | Switch(e, cases) -> seq [str "switch ("; print_exp e; str ") "; print_cases cases] 117 | 118 | and print_block stmts = 119 | seq [str "{"; 120 | indent 2 (seq (map (fun s -> seq [nl; print_stmt s]) stmts)); 121 | nl; 122 | str "}"] 123 | 124 | and print_case (x, stmts) = 125 | seq [str "case "; qstr x; str ":"; 126 | indent 2 (seq (map (fun s -> seq [nl; print_stmt s]) stmts)); 127 | nl] 128 | 129 | and print_cases cases = 130 | seq [str "{"; 131 | indent 2 (seq (map (fun case -> seq [nl; print_case case]) cases)); 132 | str "}"] 133 | 134 | let print_stmts stmts = 135 | seq [seq (map (fun s -> seq [nl; print_stmt s]) stmts); 136 | nl] 137 | 138 | -------------------------------------------------------------------------------- /js.mli: -------------------------------------------------------------------------------- 1 | type exp = 2 | | Int of int 3 | | Num of float 4 | | Bool of bool 5 | | Fun of Base.id option * Base.id list * statement list 6 | | String of string 7 | | Id of Base.id 8 | | Apply of exp * exp list 9 | | Op of Base.op * exp * exp 10 | | Array of exp list 11 | | Deref of exp * exp 12 | | Method of exp * string * exp list 13 | | New of string * exp list 14 | 15 | and statement = 16 | | LetNull of Base.id 17 | | LetVar of Base.id * exp 18 | | LetDef of Base.id * exp 19 | | Return of exp 20 | | IfThenElse of exp * statement list * statement list 21 | | Assign of Base.id * exp 22 | | WhileTrue of statement list 23 | | Continue 24 | | Abort 25 | | Break 26 | | Switch of exp * (Base.conid * statement list) list 27 | 28 | 29 | type 'a optree = Leaf of 'a | Node of Base.op * 'a optree * 'a optree 30 | val opify : exp -> exp optree 31 | val precedence : Base.op -> int 32 | val print_operator : ('a -> Pp.printer) -> 'a optree -> Pp.printer 33 | 34 | val print_exp : exp -> Pp.printer 35 | val print_stmt : statement -> Pp.printer 36 | val print_block : statement list -> Pp.printer 37 | val print_stmts : statement list -> Pp.printer 38 | -------------------------------------------------------------------------------- /kinding.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ast 3 | open Context 4 | 5 | let rec wellsorted = function 6 | | Int -> return () 7 | | Lin -> return () 8 | | KArrow(k1, k2) -> wellsorted k1 >> wellsorted k2 9 | | KVar x -> lookup x >>= (function 10 | | Kind(_, _) -> return () 11 | | _ -> error "Variable '%s' is not a kind" x) 12 | 13 | let rec subkind k1 k2 = 14 | subst_kind k1 >>= (fun k1 -> 15 | subst_kind k2 >>= (fun k2 -> 16 | subkind' k1 k2)) 17 | 18 | and subkind' k1 k2 = 19 | match k1, k2 with 20 | | Int, Int -> return () 21 | | Lin, Lin -> return () 22 | | KArrow(k1', k1''), 23 | KArrow(k2', k2'') -> subkind k2' k1' >> subkind k1'' k2'' 24 | | KVar x, KVar y -> if x = y 25 | then return () 26 | else orelse (wellsorted_before x (KVar y)) 27 | (wellsorted_before y (KVar x)) 28 | | KVar x, k 29 | | k, KVar x -> wellsorted_before x k 30 | | _, _ -> error "kind mismatch -- %a and %a incompatible" fmt_kind k1 fmt_kind k2 31 | 32 | and wellsorted_before a k = 33 | before a (wellsorted k) >> 34 | update_eqn a [a, Kind(Exist, Some k)] 35 | 36 | 37 | let rec expand_karrow kvar = 38 | lookup kvar >>= (function 39 | | Kind(Exist, None) -> 40 | newid "k1" >>= (fun k1 -> 41 | newid "k2" >>= (fun k2 -> 42 | update_eqn kvar [k1, Kind(Exist, None); 43 | k2, Kind(Exist, None); 44 | kvar, Kind(Exist, Some (KArrow(KVar k1, KVar k2)))])) 45 | | Kind(Exist, Some _) -> assert false 46 | | _ -> assert false) 47 | 48 | let rec checkable_tycon = function 49 | | TLam(_, _) -> true 50 | | TLet(_, _, tp) -> checkable_tycon tp 51 | | _ -> false 52 | 53 | let rec tapp hd args = 54 | match hd, args with 55 | | TApp(hd', args'), _ -> tapp hd' (args' @ args) 56 | | _, _ -> TApp(hd, args) 57 | 58 | let rec synth_kind tp = 59 | match tp with 60 | | String 61 | | Num 62 | | Bool -> return (tp, Int) 63 | | Pure tp -> check_kind tp Int >>= (fun tp -> return (Pure tp, Int)) 64 | | Stream tp -> check_kind tp Int >>= (fun tp -> return (Stream tp, Int)) 65 | | Next tp -> synth_kind tp >>= (fun (tp, k) -> return (Next tp, k)) 66 | | G tp -> check_kind tp Lin >>= (fun tp -> return (G tp, Int)) 67 | | Arrow(tp1, tp2) -> check_kind tp1 Int >>= (fun tp1 -> 68 | check_kind tp2 Int >>= (fun tp2 -> 69 | return (Arrow(tp1, tp2), Int))) 70 | | Product tps -> seq (map (fun tp -> check_kind tp Int) tps) >>= (fun tps -> 71 | return (Product tps, Int)) 72 | | Forall(a, Some k0, tp) -> 73 | wellsorted k0 >> 74 | fresh rename_tp a tp >>= (fun (a, tp) -> 75 | with_hyp (a, Type(Univ, k0, None)) 76 | (synth_kind tp >>= (fun (tp, k) -> 77 | return (Forall(a, Some k0, tp), k)))) 78 | | Forall(a, None, tp) -> 79 | fresh rename_tp a tp >>= (fun (a, tp) -> 80 | newid "k" >>= (fun kvar -> 81 | (with_hyp (kvar, Kind(Exist, None)) 82 | (with_hyp (a, Type(Univ, KVar kvar, None)) 83 | (synth_kind tp >>= (fun (tp, k) -> 84 | subst_kind (KVar kvar) >>= (fun karg -> 85 | (orelse (before kvar (wellsorted karg)) 86 | (error "Could not infer kind for '%s'" a)) >> 87 | return (Forall(a, Some karg, tp), k)))))))) 88 | | Exists(a, Some k0, tp) -> 89 | wellsorted k0 >> 90 | fresh rename_tp a tp >>= (fun (a, tp) -> 91 | with_hyp (a, Type(Univ, k0, None)) 92 | (synth_kind tp >>= (fun (tp, k) -> 93 | return (Exists(a, Some k0, tp), k)))) 94 | | Exists(a, None, tp) -> 95 | fresh rename_tp a tp >>= (fun (a, tp) -> 96 | newid "k" >>= (fun kvar -> 97 | (with_hyp (kvar, Kind(Exist, None)) 98 | (with_hyp (a, Type(Univ, KVar kvar, None)) 99 | (synth_kind tp >>= (fun (tp, k) -> 100 | subst_kind (KVar kvar) >>= (fun karg -> 101 | (orelse (before kvar (wellsorted karg)) 102 | (error "Could not infer kind for '%s'" a)) >> 103 | return (Exists(a, Some karg, tp), k)))))))) 104 | | F tp -> check_kind tp Int >>= (fun tp -> return (F tp, Lin)) 105 | | Dom tp -> check_kind tp Int >>= (fun tp -> return (Dom tp, Lin)) 106 | | Frame tp -> check_kind tp Int >>= (fun tp -> return (Frame tp, Lin)) 107 | | Svg tp -> check_kind tp Int >>= (fun tp -> return (Svg tp, Lin)) 108 | | Tensor tps -> seq (map (fun tp -> check_kind tp Lin) tps) >>= (fun tps -> 109 | return (Tensor tps, Lin)) 110 | | Lolli(tp1, tp2) -> check_kind tp1 Lin >>= (fun tp1 -> 111 | check_kind tp2 Lin >>= (fun tp2 -> 112 | return (Lolli(tp1, tp2), Lin))) 113 | | TVar a -> lookup a >>= (function 114 | | Type(_, k, _) -> subst_kind k >>= (fun k -> return (TVar a, k)) 115 | | Data(k, _, _) -> subst_kind k >>= (fun k -> return (tapp (TVar a) [], k)) 116 | | _ -> error "variable '%a' not a type variable" fmt_id a) 117 | | TApp(tp0, tps) -> synth_kind tp0 >>= (fun (tp0, k0) -> 118 | synth_spine k0 tps >>= (fun (tps, k) -> 119 | return (tapp tp0 tps, k))) 120 | | TAnnot(tp1, k1) -> wellsorted k1 >> 121 | check_kind tp1 k1 >>= (fun tp1 -> 122 | subst_kind k1 >>= (fun k1 -> 123 | return (tp1, k1))) 124 | | tp -> error "Cannot synthesize kind for type expression" 125 | 126 | and synth_spine kin tps = 127 | match (kin, tps) with 128 | | (k, []) -> return ([], k) 129 | | (KArrow(k, kin'), tp0 :: tps') -> 130 | check_kind tp0 k >>= (fun tp0 -> 131 | synth_spine kin' tps' >>= (fun (tps', kresult) -> 132 | return (tp0 :: tps', kresult))) 133 | | (k, tp :: tps) -> error "Expected type-level function, got %a" fmt_kind k 134 | 135 | and check_kind tp k = 136 | subst_kind k >>= check_kind' tp 137 | 138 | and check_kind' tp k = 139 | match tp, k with 140 | | TLam(a, tp2), KArrow(k1, k2)-> 141 | fresh rename_tp a tp2 >>= (fun (a, tp2) -> 142 | with_hyp (a, Type(Univ, k1, None)) 143 | (check_kind tp2 k2 >>= (fun tp2 -> 144 | return (TLam(a, tp2))))) 145 | | TLam(a, tp2), KVar kvar -> 146 | fresh rename_tp a tp2 >>= (fun (a, tp2) -> 147 | expand_karrow kvar >> 148 | check_kind tp k >>= (fun tp -> 149 | subst_kind k >>= (fun k -> 150 | return (TAnnot(tp, k))))) 151 | | TLam(_, _), _ -> error "Kind mismatch, expected function kind, got %a" fmt_kind k 152 | | TLet(a, tp1, tp2), k when checkable_tycon tp1 -> 153 | fresh rename_tp a tp2 >>= (fun (a, tp2) -> 154 | newid "k" >>= (fun kvar -> 155 | (with_hyp (kvar, Kind(Exist, None)) 156 | (with_hyp (a, Type(Univ, KVar kvar, None)) 157 | (check_kind tp1 (KVar kvar) >>= (fun tp1 -> 158 | subst_kind (KVar kvar) >>= (fun karg -> 159 | (orelse (wellsorted_before kvar karg) 160 | (error "Could not infer kind for '%s'" a)) >> 161 | check_kind tp2 k >>= (fun tp2 -> 162 | return (TLet(a, TAnnot(tp1, karg), tp2)))))))))) 163 | | TLet(a, tp1, tp2), k -> 164 | synth_kind tp1 >>= (fun (tp1, k1) -> 165 | fresh rename_tp a tp2 >>= (fun (a, tp2) -> 166 | with_hyp (a, Type(Univ, k1, None)) 167 | (check_kind tp2 k >>= (fun tp2 -> 168 | return (TLet(a, tp1, tp2)))))) 169 | | _, _ -> synth_kind tp >>= (fun (tp, k') -> 170 | subkind k' k >> 171 | return tp) 172 | 173 | let rec atomic = function 174 | | TVar _ 175 | | TAnnot(_, _) -> true 176 | | TApp(tp, ts) -> atomic tp 177 | | _ -> false 178 | 179 | 180 | 181 | let rec whnf tp = 182 | subst tp >>= whnf' 183 | 184 | and whnf' tp = 185 | match tp with 186 | | Num 187 | | Bool 188 | | String 189 | | Pure _ 190 | | Next _ 191 | | Stream _ 192 | | G _ 193 | | Product _ 194 | | Arrow (_, _) 195 | | Forall (_, _, _) 196 | | Exists (_, _, _) 197 | | F _ 198 | | Tensor _ 199 | | Lolli (_, _) 200 | | Dom _ 201 | | Frame _ 202 | | Svg _ 203 | | TLam (_, _) 204 | | TVar _ -> return (TApp(tp, [])) 205 | | TLet (a, tp1, tp2) -> tp_subst tp1 a tp2 >>= whnf 206 | | TAnnot(tp, k) -> whnf tp >>= (fun tp -> 207 | return(if atomic tp then tp else TAnnot(tp, k))) 208 | | TApp(tp, []) -> whnf tp 209 | | TApp(tp, tps) -> 210 | whnf tp >>= (fun tp -> 211 | match tp with 212 | | TAnnot(tp, k) -> reduce_spine k tp tps 213 | | TVar _ -> return (TApp(tp, tps)) 214 | | TApp(tp', tps') -> return (TApp(tp', tps' @ tps)) 215 | | _ -> assert false) 216 | 217 | 218 | and reduce_spine k hd args = 219 | match k, hd, args with 220 | | _, _, [] -> return hd 221 | | _, TAnnot(hd', k'), _ -> reduce_spine k' hd' args 222 | | KArrow(k1, k2), TLam(a, tbody), arg :: args' -> 223 | tp_subst (TAnnot(arg, k1)) a tbody >>= whnf >>= (fun tbody' -> 224 | if atomic tbody' then 225 | return (tapp tbody' args') 226 | else 227 | reduce_spine k2 tbody' args') 228 | | _ -> assert false 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | -------------------------------------------------------------------------------- /kinding.mli: -------------------------------------------------------------------------------- 1 | val wellsorted : Ast.kind -> unit Context.t 2 | val subkind : Ast.kind -> Ast.kind -> unit Context.t 3 | 4 | val synth_kind : Ast.tp -> (Ast.tp * Ast.kind) Context.t 5 | val check_kind : Ast.tp -> Ast.kind -> Ast.tp Context.t 6 | 7 | val atomic : Ast.tp -> bool 8 | val whnf : Ast.tp -> Ast.tp Context.t 9 | val reduce_spine : Ast.kind -> Ast.tp -> Ast.tp list -> Ast.tp Context.t 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /lambda.ml: -------------------------------------------------------------------------------- 1 | (* Lambda Calculus 2 | 3 | This module contains a simple dynamically-typed lambda calculus a la Scheme, which 4 | is the intermediate language for our compiler. The compiler workflow is the usual 5 | story of "typecheck the program with fancy types, throw away the types, and generate code". 6 | 7 | In this case, the purpose of the IR is to paper over the general insanity involved in 8 | anything touching Javascript (bizarre scoping, variable semantics, statement/expression 9 | distinctions, etc). 10 | 11 | *) 12 | 13 | open Base 14 | 15 | type term = 16 | | Var of id 17 | | Lam of id * term 18 | | LitNum of float 19 | | LitBool of bool 20 | | LitString of string 21 | | App of term * term 22 | | Oper of op * term * term 23 | | If of term * term * term 24 | | Tuple of term list 25 | | Project of int * term 26 | | Let of id * term * term 27 | | Fix of id * id * term 28 | | Lazyfix of id * term 29 | | Cons of term * term 30 | | Head of term 31 | | Tail of term 32 | | Lazy of term 33 | | Force of term 34 | | Thunk of term 35 | | Run of term 36 | | Con of conid * term 37 | | Merge of term * term 38 | | Case of term * (conid * id * term) list 39 | 40 | let atom = function 41 | | Var _ 42 | | LitString _ 43 | | LitNum _ 44 | | LitBool _ 45 | | Tuple _ -> true 46 | | _ -> false 47 | 48 | let sameop op = function 49 | | Oper(op', _, _) -> op = op' 50 | | _ -> false 51 | 52 | let let_tuple xs x e = 53 | let rec loop i = function 54 | | [] -> e 55 | | y :: ys -> Let(y, Project(i, Var x), loop (i+1) ys) 56 | in 57 | loop 0 xs 58 | 59 | let let_stream (h,t) x e = 60 | Let(h, Head(Var x), Let(t, Tail(Var x), e)) 61 | 62 | (* Not sure this is good sw-eng practice -- 63 | split in the runtime should be reified in the lam type, 64 | just like Merge *) 65 | 66 | let frame w = Var w 67 | let future w = Lazy (Var w) 68 | 69 | let let_dom (h,t) x e = 70 | Let(h, frame x, Let(t, future x, e)) 71 | 72 | let let_lazy_tuple xs x e = 73 | let lazy_project i x = Lazy(Let(x, Force(Var x), Project(i, Var x))) in 74 | let rec loop i = function 75 | | [] -> e 76 | | y :: ys -> Let(y, lazy_project i x, loop (i+1) ys) 77 | in 78 | loop 0 xs 79 | 80 | let rename_term x x' term = 81 | let rec loop = function 82 | | Var y -> if x = y then Var x' else Var y 83 | | Lam(y, t) -> if x = y then Lam(y, t) else Lam(y, loop t) 84 | | LitNum n -> LitNum n 85 | | LitBool b -> LitBool b 86 | | LitString s -> LitString s 87 | | App(t1, t2) -> App(loop t1, loop t2) 88 | | Merge(t1, t2) -> Merge(loop t1, loop t2) 89 | | If(t1, t2, t3) -> If(loop t1, loop t2, loop t3) 90 | | Oper(op, t1, t2) -> Oper(op, loop t1, loop t2) 91 | | Tuple ts -> Tuple (map loop ts) 92 | | Con(c, t) -> Con(c, loop t) 93 | | Project(i, t) -> Project(i, loop t) 94 | | Let(y, t1, t2) -> Let(y, loop t1, if x = y then t2 else loop t2) 95 | | Fix(f, y, t) -> if x = f || x = y then Fix(f, y, t) else Fix(f, y, loop t) 96 | | Lazyfix(y, t) -> if x = y then Lazyfix(y, t) else Lazyfix(y, loop t) 97 | | Cons(t1, t2) -> Cons(loop t1, loop t2) 98 | | Head t -> Head (loop t) 99 | | Tail t -> Tail (loop t) 100 | | Lazy t -> Lazy (loop t) 101 | | Force t -> Force (loop t) 102 | | Thunk t -> Thunk (loop t) 103 | | Run t -> Run (loop t) 104 | | Case(t, branches) -> Case(loop t, map (fun (c, y, t) -> if x = y then (c, y, t) else (c, y, loop t)) branches) 105 | in 106 | loop term 107 | 108 | let print = Format.fprintf 109 | 110 | let rec print_term out = function 111 | | Var x -> print out "%s" x 112 | | Lam(x, t) -> print out "\\%s. @[%a@]@," x print_term t 113 | | LitNum n -> print out "%f" n 114 | | LitBool b -> if b then print out "true" else print out "false" 115 | | LitString s -> print out "\"%s\"" (String.escaped s) 116 | | App(t1, t2) -> print out "%a@ %a" print_term t1 print_atom t2 117 | | If(t1, t2, t3) -> print out "@[if@ %a@ then@\n@ @ @[%a@]@\nelse@\n@ @ @[%a@]@]" print_term t1 print_term t2 print_term t3 118 | | Oper(op, t1, t2) -> print out "(%a@ %s@ %a)" print_term t1 (print_op op) print_atom t2 119 | | Tuple ts -> print out "(%a)" print_seq ts 120 | | Con(c, t) -> print out "%s(%a)" c print_term t 121 | | Project(i, t) -> print out "%a[%d]" print_atom t i 122 | | Let(x, t1, t2) -> print out "@[let@ %s@ =@;<1 2>@[%a@]@ in@\n@[%a@]@]" x print_term t1 print_term t2 123 | | Fix(f, x, t) -> print out "@[loop@ %s@ %s. @[%a@]@]" f x print_term t 124 | | Lazyfix(x, t) -> print out "@[fix@ %s. @[%a@]@]" x print_term t 125 | | Cons(t1, t2) -> print out "%a@ ::@ %a" print_atom t1 print_atom t2 126 | | Head t -> print out "head@ %a" print_atom t 127 | | Tail t -> print out "tail@ %a" print_atom t 128 | | Lazy t -> print out "lazy@ %a" print_atom t 129 | | Force t -> print out "force@ %a" print_atom t 130 | | Thunk t -> print out "thunk@ %a" print_atom t 131 | | Run t -> print out "run@ %a" print_atom t 132 | | Merge(t1, t2) -> print out "%a@ ::@ %a" print_term t1 print_atom t2 133 | | Case(t, branches) -> print out "case(%a, @[%a@])" print_term t print_branches branches 134 | 135 | and print_atom out t = 136 | if atom t then print_term out t else print out "(%a)" print_term t 137 | 138 | and print_seq out = function 139 | | [] -> () 140 | | [t] -> print_term out t 141 | | t :: ts -> print out "%a,@ %a" print_term t print_seq ts 142 | 143 | and print_branch out (c, x, t) = print out "%s(%s) -> %a" c x print_term t 144 | 145 | and print_branches out = function 146 | | [] -> () 147 | | [b] -> print_branch out b 148 | | t :: ts -> print out "%a,@ %a" print_branch t print_branches ts 149 | 150 | 151 | 152 | let fact = 153 | Let("fact", 154 | Fix("fact", "n", 155 | If(Oper(Equal, Var "n", LitNum 0.0), 156 | LitNum 1.0, 157 | Let("v", App(Var "fact", Oper(Minus, Var "n", LitNum 1.0)), 158 | Oper(Times, Var "n", Var "v")))), 159 | App(Var "fact", LitNum 5.0)) 160 | 161 | let fact_tr = 162 | Let("fact_tr", 163 | Fix("fact_tr", "nacc", 164 | Let("n", Project(0, Var "nacc"), 165 | Let("acc", Project(1, Var "nacc"), 166 | If(Oper(Equal, Var "n", LitNum 0.0), 167 | LitNum 1.0, 168 | Let("m", Oper(Minus, Var "n", LitNum 1.0), 169 | Let("acc", Oper(Times, Var "n", Var "acc"), 170 | App(Var "fact_tr", 171 | Tuple [Var "m"; Var "acc"]))))))), 172 | Let("fact", Lam("n", App(Var "fact_tr", Tuple [Var "n"; LitNum 1.0])), 173 | App(Var "fact", LitNum 5.0))) 174 | 175 | let countdown = 176 | Let("countdown", Fix("countdown", "n", 177 | If(Oper(Equal, Var "n", LitNum 0.0), 178 | LitNum 0.0, 179 | Let("m", Oper(Minus, Var "n", LitNum 1.0), 180 | App(Var "countdown", Var "m")))), 181 | App(Var "countdown", LitNum 5.0)) 182 | 183 | 184 | 185 | 186 | -------------------------------------------------------------------------------- /lambda.mli: -------------------------------------------------------------------------------- 1 | type term = 2 | | Var of Base.id 3 | | Lam of Base.id * term 4 | | LitNum of float 5 | | LitBool of bool 6 | | LitString of string 7 | | App of term * term 8 | | Oper of Base.op * term * term 9 | | If of term * term * term 10 | | Tuple of term list 11 | | Project of int * term 12 | | Let of Base.id * term * term 13 | | Fix of Base.id * Base.id * term 14 | | Lazyfix of Base.id * term 15 | | Cons of term * term 16 | | Head of term 17 | | Tail of term 18 | | Lazy of term 19 | | Force of term 20 | | Thunk of term 21 | | Run of term 22 | | Con of Base.conid * term 23 | | Merge of term * term 24 | | Case of term * (Base.conid * Base.id * term) list 25 | 26 | val let_tuple : Base.id list -> Base.id -> term -> term 27 | val let_lazy_tuple : Base.id list -> Base.id -> term -> term 28 | val let_stream : Base.id * Base.id -> Base.id -> term -> term 29 | val let_dom : Base.id * Base.id -> Base.id -> term -> term 30 | val rename_term : Base.id -> Base.id -> term -> term 31 | 32 | val print_term : Format.formatter -> term -> unit 33 | 34 | val fact : term 35 | val fact_tr : term 36 | val countdown : term 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /lexer.mli: -------------------------------------------------------------------------------- 1 | val token : Lexing.lexbuf -> Parser.token 2 | 3 | -------------------------------------------------------------------------------- /lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | 4 | let stringfold f init s = 5 | let n = String.length s in 6 | let r = ref init in 7 | for i = 0 to n-1 do r := f s.[i] (!r) done; 8 | !r 9 | 10 | let count_newlines s = 11 | stringfold (fun c n -> if c = '\n' then n+1 else n) 0 s 12 | 13 | let repeat n thunk = for i = 0 to n-1 do thunk() done 14 | } 15 | let comment = "//" [^'\n']* "\n" 16 | let digit = ['0'-'9'] 17 | let number = '-'? digit+ ('.' digit*)? 18 | let lident = ['a' - 'z']['a'-'z' 'A'-'Z' '0'-'9' '_' ]* 19 | let uident = ['A' - 'Z']['a'-'z' 'A'-'Z' '0'-'9' '_' ]* 20 | let whitespace = ['\t' ' ']+ 21 | let new_line = '\n' | '\r' | '\r' '\n' 22 | let string_literal = ([^'\\' '\"' '\n'] | "\\n" | "\\t" | "\\\\" |"\\\"" )* 23 | 24 | rule token = parse 25 | | "type" {TYPE} 26 | | "int" {INT} 27 | | "lin" {LIN} 28 | | "next" {NEXT} 29 | | "•" {NEXT} 30 | | "cons" {CONS} 31 | | "forall" {FORALL} 32 | | "∀" {FORALL} 33 | | "exists" {EXISTS} 34 | | "∃" {EXISTS} 35 | | "of" {OF} 36 | | "." {DOT} 37 | | "(" {LPAREN} 38 | | ")" {RPAREN} 39 | | "," {COMMA} 40 | | "!" {BANG} 41 | | "□" {BANG} 42 | | "F" {F} 43 | | "fun" {FUN} 44 | | "λ" {FUN} 45 | | "->" {TO} 46 | | "→" {TO} 47 | | "+" {PLUS} 48 | | "-" {MINUS} 49 | | "<" {LT} 50 | | "<=" {LEQ} 51 | | ">=" {GEQ} 52 | | ">" {GT} 53 | | "*" {AST} 54 | | "⊗" {AST} 55 | | "&" {AND} 56 | | "×" {AND} 57 | | "&&" {ANDAND} 58 | | "||" {OR} 59 | | "let" {LET} 60 | | "::" {DOUBLECOLON} 61 | | ":" {COLON} 62 | | "cons" {CONS} 63 | | "=" {EQUAL} 64 | | "in" {IN} 65 | | "G" {G} 66 | | "fix" {FIX} 67 | | "loop" {LOOP} 68 | | "true" {TRUE} 69 | | "false" {FALSE} 70 | | "if" {IF} 71 | | "then" {THEN} 72 | | "else" {ELSE} 73 | | "val" {VAL} 74 | | "rec" {REC} 75 | | "match" {MATCH} 76 | | "with" {WITH} 77 | | "|" {BAR} 78 | | "_" {UNDERSCORE} 79 | | number as n {NUM(float_of_string n)} 80 | | '\"' (string_literal as s) '\"' {repeat (count_newlines s) (fun () -> Lexing.new_line lexbuf); STRING s} 81 | | "run" {RUN} 82 | | "num" {NUMTYPE} 83 | | "stream" {STREAMTYPE} 84 | | "string" {STRINGTYPE} 85 | | "bool" {BOOLTYPE} 86 | | "-o" {LOLLI} 87 | | "⊸" {LOLLI} 88 | | "dom" {DOM} 89 | | "frame" {FRAME} 90 | | "svg" {SVG} 91 | | "unit" {UNITTYPE} 92 | | "I" {I} 93 | | "begin" {BEGIN} 94 | | "end" {END} 95 | | lident as s {IDENT s} 96 | | uident as s {CONID s} 97 | | comment {Lexing.new_line lexbuf; token lexbuf} 98 | | whitespace {token lexbuf} 99 | | new_line {Lexing.new_line lexbuf; token lexbuf} 100 | | eof {EOF} 101 | 102 | -------------------------------------------------------------------------------- /lin.txt: -------------------------------------------------------------------------------- 1 | Δ ::= · | Δ, x÷A | Δ, x:A+ | Δ, x:A- | Δ, a:κ | Δ, â:κ=τ | Δ, a:! | Δ, a:♠ 2 | 3 | 4 | Δ/Δ' 5 | 6 | (Δ, x:A+)/(Δ', x:A-) = (Δ/Δ'), x:A+ 7 | (Δ, x:A-)/(Δ', x:A-) = (Δ/Δ'), x:A- 8 | (Δ, y÷A-)/(Δ', y÷A-) = (Δ/Δ'), y÷A 9 | (Δ, a:κ)/(Δ', a:κ) = (Δ/Δ'), a:κ 10 | (Δ, y:κ=τ₀)/(Δ', y:κ=τ) = (Δ,x:H/Δ'), y:κ=τ 11 | (Δ, x:H)/(Δ', y:κ=τ) = (Δ,x:H/Δ'), y:κ=τ 12 | 13 | 14 | 15 | 16 | ————————————————————————————————— 17 | Δ, x:A+ ⊢ x : A ⊣ Δ, x:A- 18 | 19 | 20 | Δ, x:A+, Δ', y:H ⊢ x : A ⊣ Δ, x:A-, Δ', y:H H ≠ ! 21 | ————————————————————————————————————————————————————— 22 | Δ, x:A+, Δ' ⊢ x : A ⊣ Δ, x:A-, Δ' 23 | 24 | 25 | 26 | Δ, x:A+ ⊢ e : B ⊣ Δ', x:A-, Δ- 27 | —————————————————————————————— 28 | Δ ⊢ λx.e : A ⊸ B ⊣ Δ' 29 | 30 | 31 | Δ, a:! ⊢ t : A ⊣ Δ', a:!, Δ- 32 | ———————————————————————————— 33 | Δ ⊢ G(t) : G(A) ⊣ Δ' 34 | 35 | 36 | Δ, a:♠ ⊢ t₁ : A ⊣ Δ', a:♠, Δ₁- 37 | Δ/Δ', a:♠ ⊢ t₂ : B ⊣ Δ'', a:♠, Δ₂- 38 | ————————————————————————————— 39 | Δ ⊢ [t₁, t₂] : A & B 40 | -------------------------------------------------------------------------------- /linearity.txt: -------------------------------------------------------------------------------- 1 | 2 | Γ ⊢ e : A ⊣ Γ' 3 | Γ' ⇓ Γ ↝ Γ'' 4 | Γ'' ⊢ e' : A ⊣ Δ 5 | ———————————————————— 6 | Γ ⊢ e || e' : A ⊣ Δ 7 | 8 | 9 | Δ ⊢ e : A+B ⊣ Γ₀ 10 | Γ₀, x:A ⊢ e₁ : C ⊣ Γ₁, x:A, Γ' 11 | Γ₀ ⇓ Γ₁ ↝ Γ₂ 12 | Γ₂, y:B ⊢ e₂ : C ⊣ Δ', y:B, Γ'' 13 | Δ' ∼ Γ₁ 14 | ———————————————————————————————— 15 | Δ ⊢ case(e, x.e₁, y.e₂) : C ⊢ Δ' 16 | 17 | 18 | 19 | Γ ::= · | Γ, α̂ | Γ, α̂=A | Γ, x:A | Γ, x∼A[+] | Γ, x∼A[-] 20 | 21 | The judgment's invariant is that the set of term variables is the 22 | same, but (1) more type variables may be introduced, and (2) evars may 23 | get values, and (3) linear variables may go from + to - 24 | 25 | 26 | Γ, β̂, γ̂, α̂ =̱ β̂ → γ̂, Γ', x:α̂ ⊢ e ⇐ β̂ ⊣ Γ'', x:α̂, Γ''' 27 | ———————————————————————————————————————————————————— 28 | Γ, α̂, Γ' ⊢ λx.e ⇐ α̂ ⊣ Γ'' 29 | 30 | To merge contexts: 31 | 32 | Γ ⇓ Γ' ↝ Γ'' 33 | ——————————————————————————————————— 34 | Γ, x∼A[±] ⇓ Γ', x∼A[_] ↝ Γ'', x∼A[±] 35 | 36 | 37 | Γ ⇓ Γ' ↝ Γ'' 38 | ——————————————————————————— 39 | Γ, x:A ⇓ Γ', x:A ↝ Γ'', x:A 40 | 41 | 42 | Γ ⇓ Γ' ↝ Γ'' 43 | ——————————————— 44 | Γ, α̂ ⇓ Γ' ↝ Γ'' 45 | 46 | 47 | Γ ⇓ Γ' ↝ Γ'' 48 | ——————————————————— 49 | Γ ⇓ Γ', α̂ ↝ Γ'', α̂ 50 | 51 | 52 | Γ ⇓ Γ' ↝ Γ'' 53 | ——————————————— 54 | Γ, α̂ ⇓ Γ' ↝ Γ'' 55 | 56 | 57 | Γ ⇓ Γ' ↝ Γ'' 58 | ————————————————— 59 | Γ, α̂=A ⇓ Γ' ↝ Γ'' 60 | 61 | 62 | Γ ⇓ Γ' ↝ Γ'' 63 | —————————————————————— 64 | Γ ⇓ Γ', α̂=A ↝ Γ'', α̂=A 65 | 66 | 67 | When two contexts are resource-compatible? 68 | 69 | Γ ∼ Δ 70 | 71 | 72 | Γ ∼ Δ 73 | ————————————————————— 74 | Γ, x∼A[+] ∼ Δ, x∼A[+] 75 | 76 | 77 | Γ ∼ Δ 78 | ————————————————————— 79 | Γ, x∼A[-] ∼ Δ, x∼A[-] 80 | 81 | 82 | Γ ∼ Δ 83 | ——————————————— 84 | Γ, x:A ∼ Δ, x:A 85 | 86 | 87 | Γ ∼ Δ 88 | ————————— 89 | Γ, α̂ ∼ Δ 90 | 91 | 92 | Γ ∼ Δ 93 | ———————— 94 | Γ ∼ Δ, α̂ 95 | 96 | 97 | Γ ∼ Δ 98 | ———————— 99 | Γ, α̂ ∼ Δ 100 | 101 | 102 | Γ ∼ Δ 103 | —————————— 104 | Γ, α̂=A ∼ Δ 105 | 106 | 107 | Γ ∼ Δ 108 | —————————— 109 | Γ ∼ Δ, α̂=A 110 | -------------------------------------------------------------------------------- /parseloc.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Lexing 3 | 4 | type 'a parse = (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> 'a 5 | 6 | let wrap p tokenize buf = 7 | try 8 | p tokenize buf 9 | with 10 | | Failure msg -> raise (SyntaxError((buf.lex_start_p, buf.lex_curr_p), msg)) 11 | | Parsing.Parse_error -> raise (SyntaxError((buf.lex_start_p, buf.lex_curr_p), "Parse error")) 12 | 13 | let string p s = wrap p Lexer.token (Lexing.from_string s) 14 | 15 | -------------------------------------------------------------------------------- /parseloc.mli: -------------------------------------------------------------------------------- 1 | type 'a parse = (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> 'a 2 | 3 | val wrap : 'a parse -> 'a parse 4 | 5 | val string : 'a parse -> string -> 'a 6 | 7 | -------------------------------------------------------------------------------- /parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Base 3 | open Ast 4 | 5 | let getpos () = (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ()) 6 | let rangepos n m = (Parsing.rhs_start_pos n, Parsing.rhs_end_pos m) 7 | 8 | let pos (p, _) = p 9 | 10 | let rec make_forall xs tp = 11 | match xs with 12 | | [] -> tp 13 | | (b, k) :: bs -> Forall(b, k, make_forall bs tp) 14 | 15 | let rec make_exists xs tp = 16 | match xs with 17 | | [] -> tp 18 | | (b,k) :: bs -> Exists(b, k, make_exists bs tp) 19 | 20 | 21 | let rec make_fun(pos, ps, e) = 22 | match ps with 23 | | [] -> e 24 | | p :: ps -> (pos, ELam(p, make_fun(pos, ps, e))) 25 | 26 | let rec make_app(f, args) = 27 | match args with 28 | | [] -> f 29 | | e :: es -> (merge(pos f, pos e), EApp(make_app(f, es), e)) 30 | 31 | let make_decl_list decls body = 32 | List.fold_left 33 | (fun acc (loc, x, term, tp) -> (pos term, ELet((loc, PVar x), (pos term, EAnnot(term, tp)), acc))) 34 | body 35 | decls 36 | 37 | let make_pure_decl_list decls body = 38 | List.fold_left 39 | (fun acc (ppos, x, term, tp) -> 40 | let annot (e, tp) = (pos term, EAnnot(e, tp)) in 41 | let elet(p, e1, e2) = (pos term, ELet(p, e1, e2)) in 42 | let bang e = (pos term, EBang e) in 43 | let pbang x = (ppos, PBang x) in 44 | elet(pbang x, annot(bang term, Pure tp), acc)) 45 | body 46 | decls 47 | 48 | %} 49 | %token TYPE 50 | %token FORALL 51 | %token EXISTS 52 | %token OF 53 | %token DOT 54 | %token VAL 55 | %token REC 56 | %token NEXT 57 | %token CONS 58 | %token RPAREN 59 | %token LPAREN 60 | %token COMMA 61 | %token UNDERSCORE 62 | %token BANG 63 | %token F 64 | %token FUN 65 | %token TO 66 | %token PLUS 67 | %token MINUS 68 | %token AST 69 | %token ANDAND 70 | %token OR 71 | %token LET 72 | %token COLON 73 | %token EQUAL 74 | %token LT 75 | %token LEQ 76 | %token GT 77 | %token GEQ 78 | %token IN 79 | %token G 80 | %token FIX 81 | %token LOOP 82 | %token TRUE 83 | %token FALSE 84 | %token IF 85 | %token THEN 86 | %token ELSE 87 | %token RUN 88 | %token INT 89 | %token LIN 90 | %token STREAMTYPE 91 | %token AND 92 | %token STRINGTYPE 93 | %token NUMTYPE 94 | %token BOOLTYPE 95 | %token LOLLI 96 | %token DOM 97 | %token FRAME 98 | %token SVG 99 | %token UNITTYPE 100 | %token MATCH 101 | %token WITH 102 | %token BEGIN 103 | %token END 104 | %token BAR 105 | %token DOUBLECOLON 106 | %token CONID 107 | %token I 108 | %token NUM 109 | %token STRING 110 | %token IDENT 111 | %token EOF 112 | 113 | %nonassoc below_TO 114 | %right TO LOLLI 115 | %nonassoc below_AND 116 | %right AND AST 117 | %nonassoc NEXT BANG STREAMTYPE G F 118 | 119 | 120 | %nonassoc IN 121 | %nonassoc THEN ELSE 122 | %nonassoc IF 123 | %nonassoc LET 124 | %right CONS 125 | %left COLON 126 | %right DOUBLECOLON 127 | %right OR 128 | %right ANDAND 129 | %left EQUAL LT LEQ GEQ GT 130 | %left PLUS MINUS 131 | %left TIMES 132 | 133 | 134 | 135 | 136 | %type tp 137 | %type pat 138 | %type exp 139 | %type toplevel_decl 140 | %type program 141 | %type signature 142 | %type signature_decl 143 | 144 | %type test_tp 145 | %type test_pat 146 | %type test_exp 147 | %type test_toplevel_decl 148 | %type test_program 149 | %type test_signature 150 | %type test_signature_decl 151 | 152 | 153 | %start test_tp test_pat test_exp test_toplevel_decl test_program test_signature test_signature_decl tp pat exp toplevel_decl program signature signature_decl 154 | 155 | 156 | %% 157 | 158 | /* Syntax of kinds */ 159 | 160 | kind : 161 | LIN {Lin} 162 | | INT {Int} 163 | 164 | 165 | /* Syntax of types */ 166 | 167 | tp_atom : 168 | I { Tensor [] } 169 | | NUMTYPE { Num } 170 | | BOOLTYPE { Bool } 171 | | STRINGTYPE { String } 172 | | UNITTYPE { Product [] } 173 | | IDENT { TVar $1 } 174 | | LPAREN tp RPAREN { $2 } 175 | ; 176 | 177 | tp_atom_list : 178 | tp_atom { [$1] } 179 | | tp_atom tp_atom_list { $1 :: $2 } 180 | ; 181 | 182 | tp_app : 183 | | tp_atom { $1 } 184 | | tp_atom tp_atom_list { TApp($1, $2) } 185 | | DOM tp_atom { Dom $2 } 186 | | SVG tp_atom { Svg $2 } 187 | | FRAME tp_atom { Frame $2 } 188 | | G tp_atom { G $2 } 189 | | F tp_atom { F $2 } 190 | | NEXT tp_atom { Next $2 } 191 | | BANG tp_atom { Pure $2 } 192 | | STREAMTYPE tp_atom { Stream $2 } 193 | ; 194 | 195 | product_tp : 196 | tp_app %prec below_AND { $1 } 197 | | tp_app and_tps { Product ($1 :: $2) } 198 | | tp_app star_tps { Tensor ($1 :: $2) } 199 | ; 200 | 201 | and_tps : 202 | AND tp_app and_tps { $2 :: $3 } 203 | | AND tp_app { [$2] } 204 | ; 205 | 206 | star_tps : 207 | AST tp_app star_tps { $2 :: $3 } 208 | | AST tp_app { [$2] } 209 | ; 210 | 211 | mono_tp : 212 | | product_tp %prec below_TO { $1 } 213 | | product_tp TO tp { Arrow($1, $3) } 214 | | product_tp LOLLI tp { Lolli($1, $3) } 215 | ; 216 | 217 | 218 | ident_list : 219 | { [] } 220 | | IDENT ident_list { ($1, None) :: $2 } 221 | | LPAREN IDENT COLON kind RPAREN ident_list { ($2, Some $4) :: $6 } 222 | ; 223 | 224 | tp : 225 | FORALL ident_list DOT tp { make_forall $2 $4 } 226 | | EXISTS ident_list DOT tp { make_exists $2 $4 } 227 | | mono_tp { $1 } 228 | | error { failwith "type" } 229 | ; 230 | 231 | 232 | /* pattern test */ 233 | 234 | 235 | 236 | /* Syntax of expressions */ 237 | 238 | pat_atom : 239 | IDENT { (getpos(), PVar $1) } 240 | | UNDERSCORE { (getpos(), PTop) } 241 | | LPAREN RPAREN { (getpos(), PTuple []) } 242 | | LPAREN pattern RPAREN { $2 } 243 | | LPAREN comma_pats RPAREN { (getpos(), PTuple $2) } 244 | | BANG pat_atom { (getpos(), PBang $2) } 245 | | NEXT pat_atom { (getpos(), PNext $2) } 246 | | F pat_atom { (getpos(), PF $2) } 247 | | CONID { let pos = getpos() in (pos, PCon($1, (pos, PTuple []))) } 248 | ; 249 | 250 | pattern : 251 | pat_atom { $1 } 252 | | pat_atom DOUBLECOLON pat_atom { (getpos(), PCons($1, $3)) } 253 | | CONID pat_atom { (getpos(), PCon($1, $2)) } 254 | ; 255 | 256 | comma_pats : 257 | pattern COMMA pattern { [$1; $3] } 258 | | pattern COMMA comma_pats { $1 :: $3 } 259 | ; 260 | 261 | pat : 262 | pattern { $1 } 263 | | error { failwith "pattern" } 264 | 265 | 266 | pat_list : 267 | pat_atom { [$1] } 268 | | pat_atom pat_list { $1 :: $2 } 269 | ; 270 | 271 | 272 | 273 | exp_atom : 274 | | IDENT { (getpos(), EVar $1) } 275 | | TRUE { (getpos(), EBool true) } 276 | | FALSE { (getpos(), EBool false) } 277 | | NUM { (getpos(), ENum $1) } 278 | | STRING { (getpos(), EString $1) } 279 | | exp_tuple_or_paren { $1 } 280 | ; 281 | 282 | exp_tuple_or_paren : 283 | | LPAREN RPAREN { (getpos(), ETuple []) } 284 | | LPAREN exp RPAREN { (getpos(), snd($2)) } 285 | | LPAREN exp exp_comma_list RPAREN { (getpos(), ETuple ($2 :: $3)) } 286 | ; 287 | 288 | exp_comma_list : 289 | | COMMA exp { [$2] } 290 | | COMMA exp exp_comma_list { $2 :: $3 } 291 | ; 292 | 293 | exp_app : 294 | | BANG exp_atom { (getpos(), EBang $2) } 295 | | RUN exp_atom exp_atom_list { make_app((getpos(), ERun $2), $3) } 296 | | CONS LPAREN exp COMMA 297 | exp RPAREN { (getpos(), ECons($3, $5)) } 298 | | G exp_atom { (getpos(), EG $2) } 299 | | F exp_atom { (getpos(), EF $2) } 300 | | NEXT exp_atom { (getpos(), ENext $2) } 301 | | exp_atom exp_atom_list { make_app($1, $2) } 302 | | CONID exp_atom_list { match $2 with 303 | | [] -> (getpos(), ECon($1, (getpos(), ETuple []))) 304 | | [e] -> (getpos(), ECon($1, e)) 305 | | _ :: _ -> raise (SyntaxError(getpos(), "Constructor has multiple arguments")) } 306 | ; 307 | 308 | exp_atom_list : 309 | | { [] } 310 | | exp_atom_list exp_atom { $2 :: $1 } 311 | ; 312 | 313 | exp : 314 | | exp_app { $1 } 315 | | block_decl IN exp { let (pos, x, e, tp) = $1 in 316 | (getpos(), ELet((pos, PVar x), 317 | (exp_pos e, EAnnot(e, tp)), $3)) } 318 | | LET pat EQUAL exp IN exp { (getpos(), ELet($2, $4, $6)) } 319 | | LET pat COLON tp EQUAL exp IN exp { (getpos(), ELet($2, (fst $6, EAnnot($6, $4)), $8))} 320 | | IF exp THEN exp ELSE exp { (getpos(), EIf($2, $4, $6)) } 321 | | FUN pat_list TO exp { make_fun(getpos(), $2, $4) } 322 | | FIX IDENT pat_list TO exp { (getpos(), EFix($2, make_fun(getpos(), $3, $5))) } 323 | | FUN LOOP IDENT pat TO exp { (getpos(), ELoop($3, $4, $6)) } 324 | | exp PLUS exp { (getpos(), EOp(Plus, $1, $3)) } 325 | | exp MINUS exp { (getpos(), EOp(Minus, $1, $3)) } 326 | | exp AST exp %prec TIMES { (getpos(), EOp(Times, $1, $3)) } 327 | | exp LT exp { (getpos(), EOp(Lt, $1, $3)) } 328 | | exp LEQ exp { (getpos(), EOp(Leq, $1, $3)) } 329 | | exp GT exp { (getpos(), EOp(Gt, $1, $3)) } 330 | | exp GEQ exp { (getpos(), EOp(Geq, $1, $3)) } 331 | | exp EQUAL exp { (getpos(), EOp(Equal, $1, $3)) } 332 | | exp ANDAND exp { (getpos(), EOp(And, $1, $3)) } 333 | | exp OR exp { (getpos(), EOp(Or, $1, $3)) } 334 | | exp DOUBLECOLON exp { (getpos(), ECons($1, $3)) } 335 | | exp COLON tp { (getpos(), EAnnot($1, $3)) } 336 | | MATCH exp 337 | BEGIN branches END { (getpos(), ECase($2, $4)) } 338 | | error { failwith "syntax error" } 339 | | LPAREN error RPAREN { failwith "syntax error" } 340 | | LPAREN error { failwith "missing close paren" } 341 | | error RPAREN { failwith "missing open paren" } 342 | ; 343 | 344 | 345 | branch : 346 | pat TO exp { ($1, $3) } 347 | ; 348 | 349 | bar_opt : 350 | { () } 351 | | BAR { () } 352 | ; 353 | 354 | branch_list : 355 | | branch { [$1] } 356 | | branch BAR branch_list { $1 :: $3 } 357 | ; 358 | 359 | branches : bar_opt branch_list { $2 }; 360 | 361 | value_decl : 362 | | VAL IDENT COLON tp { (rangepos 2 2, $2, $4) } 363 | ; 364 | 365 | value_bind : 366 | | LET IDENT EQUAL exp { ($2, $4) } 367 | | LET IDENT pat_list EQUAL exp { ($2, make_fun(getpos(), $3, $5)) } 368 | | LET REC IDENT pat_list EQUAL exp { ($3, (getpos(), EFix($3, make_fun(getpos(), $4, $6)))) } 369 | | LET LOOP IDENT pat EQUAL exp { ($3, (getpos(), ELoop($3, $4, $6))) } 370 | ; 371 | 372 | block_decl : 373 | | value_decl value_bind { let (pos, x, tp) = $1 in 374 | let (x', e) = $2 in 375 | if x = x' then 376 | (pos, x, e, tp) 377 | else 378 | raise (SyntaxError(pos, 379 | "Declaration and binding identifiers don't match")) } 380 | ; 381 | 382 | 383 | idents : 384 | { [] } 385 | | IDENT idents { $1 :: $2 } 386 | ; 387 | 388 | constructor_decl : 389 | CONID OF tp { ($1, $3) } 390 | | CONID { ($1, Product []) } 391 | ; 392 | 393 | 394 | constructors : 395 | constructor_decl { [$1] } 396 | | constructor_decl BAR constructors { $1 :: $3 } 397 | ; 398 | 399 | constructor_decl_list : bar_opt constructors { $2 }; 400 | 401 | datatype_decl : 402 | TYPE IDENT idents EQUAL constructor_decl_list { 403 | let rec mkarrow = function 404 | | [] -> Int 405 | | _ :: ids -> KArrow(Int, mkarrow ids) 406 | in 407 | (getpos(), $2, (mkarrow $3, List.map (fun a -> (a, Int)) $3, $5)) } 408 | 409 | type_decl : 410 | | TYPE IDENT COLON kind { (rangepos 2 2, $2, $4) } 411 | ; 412 | 413 | type_bind : 414 | | LET IDENT EQUAL tp { (rangepos 4 4, $2, $4) } 415 | ; 416 | 417 | 418 | type_def : 419 | | type_decl type_bind 420 | { let (pos, a, kind) = $1 in 421 | let (pos', a', tp) = $2 in 422 | if a = a' then 423 | TypeBind(pos', a, tp, kind) 424 | else 425 | raise (SyntaxError(pos, "Type declaration and definition identifiers don't match")) } 426 | ; 427 | 428 | toplevel_decl : 429 | block_decl { ValueBind ($1) } 430 | | value_decl { let (pos, id, tp) = $1 in ValueDecl(pos, id, tp) } 431 | | type_decl { let (pos, id, kind) = $1 in TypeDecl(pos, id, kind) } 432 | | type_def { $1 } 433 | | datatype_decl { let (pos, id, data) = $1 in DataBind(pos, id, data) } 434 | ; 435 | 436 | toplevel_decl_list : 437 | { [] } 438 | | toplevel_decl toplevel_decl_list { $1 :: $2 } 439 | ; 440 | 441 | signature_decl : 442 | value_decl { let (pos, id, tp) = $1 in SigTypeDecl(pos, id, tp) } 443 | | datatype_decl { let (pos, id, data) = $1 in DataDecl(pos, id, data) } 444 | ; 445 | 446 | signature : 447 | { [] } 448 | | signature_decl signature { $1 :: $2 } 449 | ; 450 | 451 | program : 452 | toplevel_decl_list IN exp { ($1, $3) } 453 | ; 454 | 455 | test_tp : tp EOF {$1}; 456 | test_pat : pat EOF {$1}; 457 | test_exp : exp EOF {$1}; 458 | test_toplevel_decl : toplevel_decl EOF {$1}; 459 | test_program : program EOF {$1}; 460 | test_signature : signature EOF {$1}; 461 | test_signature_decl : signature_decl EOF {$1}; 462 | 463 | -------------------------------------------------------------------------------- /poly.mli: -------------------------------------------------------------------------------- 1 | val specialize : Ast.pat -> Ast.tp -> unit Context.t 2 | val lspecialize : Ast.pat -> Ast.tp -> unit Context.t 3 | val specialize_set : Ast.pat list -> Ast.tp -> Ast.tp Context.t 4 | 5 | val check : Ast.exp -> Ast.tp -> int -> Lambda.term Context.t 6 | val lcheck : Ast.exp -> Ast.tp -> int -> Lambda.term Context.t 7 | 8 | val synth : Ast.exp -> int -> (Ast.tp * Lambda.term) Context.t 9 | val lsynth : Ast.exp -> int -> (Ast.tp * Lambda.term) Context.t 10 | 11 | val cover : (Ast.exp -> Ast.tp -> int -> Lambda.term Context.t) -> 12 | (Ast.pat list * Ast.exp) list -> 13 | Ast.tp -> 14 | int -> 15 | Context.hyp list -> 16 | (Lambda.term * Base.id list) Context.t 17 | 18 | 19 | -------------------------------------------------------------------------------- /pp.ml: -------------------------------------------------------------------------------- 1 | type printer' = int -> int -> out_channel -> int 2 | 3 | let p = Printf.fprintf 4 | let len = String.length 5 | 6 | let spaces n out = for i = 0 to n-1 do p out " " done 7 | 8 | let nl' n col out = (p out "\n"; spaces n out; n) 9 | let nil' n col out = col 10 | let str' s = if String.contains s '\n' 11 | then assert false 12 | else fun n col out -> (p out "%s" s; col + len s) 13 | let int' x = str' (string_of_int x) 14 | let float' x = str' (string_of_float x) 15 | let bool' b = str' (string_of_bool b) 16 | let qstr' s = str' (Printf.sprintf "\"%s\"" (String.escaped s)) 17 | let atcol' p _ col out = p col col out 18 | let indent' k p n col out = p (n+k) col out 19 | let sequence p1 p2 n col out = p2 n (p1 n col out) out 20 | let seq' ps = List.fold_right sequence ps nil' 21 | 22 | type printer = bool * printer' 23 | 24 | let nl = (true, nl') 25 | let nil = (false, nil') 26 | let str s = (false, str' s) 27 | let int x = (false, int' x) 28 | let float x = (false, float' x) 29 | let bool b = (false, bool' b) 30 | let qstr s = (false, qstr' s) 31 | let atcol (b, p) = (b, atcol' p) 32 | let indent k (b, p) = (b, indent' k p) 33 | let (>>) (b1,p1) (b2,p2) = (b1 || b2, sequence p1 p2) 34 | let seq bps = List.fold_right (>>) bps nil 35 | let break b = if b then nl else str " " 36 | 37 | let multiline (b, p) = b 38 | 39 | let print (_, p) out = let _ = p 0 0 out in () 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /pp.mli: -------------------------------------------------------------------------------- 1 | type printer 2 | 3 | val nl : printer 4 | val nil : printer 5 | val str : string -> printer 6 | val int : int -> printer 7 | val float : float -> printer 8 | val bool : bool -> printer 9 | val qstr : string -> printer 10 | val atcol : printer -> printer 11 | val indent : int -> printer -> printer 12 | val seq : printer list -> printer 13 | val break : bool -> printer 14 | val multiline : printer -> bool 15 | 16 | val print : printer -> out_channel -> unit 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /runtime.js: -------------------------------------------------------------------------------- 1 | // Thunks to implement lazy evaluation 2 | // 3 | // We memoize this, so the G modality can't use this 4 | // implementation of thunks -- it just uses nullary 5 | // functions since it needs call-by-name behavior for 6 | // correctness. 7 | // 8 | function Lazy(fn) { 9 | this.code = fn; 10 | this.value = null; 11 | this.evaluated = false; 12 | } 13 | Lazy.prototype.force = function () { 14 | if (this.evaluated) { 15 | return this.value; 16 | } else { 17 | let f = this.code; 18 | this.value = f(); // avoids passing the thunk as 'this' 19 | return this.value; 20 | } 21 | } 22 | 23 | // The Thunk operator 24 | // 25 | // This does nothing. 26 | 27 | function Thunk(thunk) { 28 | return thunk; 29 | } 30 | 31 | //////////////// 32 | 33 | // 34 | // interface Cons a = { 35 | // head : () -> a; 36 | // tail : () -> Lazy (Cons a) 37 | // } 38 | 39 | // The naive implementation. 40 | // 41 | function Cons(h, t) { 42 | this.hd = h; 43 | this.tl = t; 44 | } 45 | Cons.prototype.head = function () { 46 | return this.hd; 47 | } 48 | Cons.prototype.tail = function () { 49 | return this.tl; 50 | } 51 | 52 | // Turn async events into synchronous streams 53 | // 54 | // The idea behind is that we have an event which periodically 55 | // evaluates its event handlers at unknown times. We want to turn the 56 | // event into a data stream, so we create a new piece of memory 57 | // this.buffer, and attach an event handler which updates this.buffer. 58 | // 59 | // When we force the tail of the stream, we copy the value of this.buffer 60 | // into this.head, giving us the new value of the stream for this tick. 61 | // So if the event handler is called multiple times during a tick, the 62 | // last value wins. 63 | // 64 | // Furthermore, we only want to copy the buffer once per tick, but we can 65 | // create multiple aliases to the tail of the stream. So we also have a flag 66 | // variable, which tail checks before doing the move. This ensures that the 67 | // copy is dones at most once. 68 | // 69 | // Furthermore, if the copy is never done, that's fine! This means no one 70 | // will ever look at the stream in the future, so there's no need to update 71 | // the event stream. 72 | 73 | function EventStream(noEvent, onEvent) { 74 | let stream = this; 75 | stream.noEvent = noEvent; 76 | stream.hd = noEvent; 77 | // 78 | stream.buffer = noEvent; 79 | stream.tick = false; 80 | // 81 | onEvent(function (v) { stream.buffer = v; }); 82 | } 83 | EventStream.prototype.head = function () { 84 | return this.hd; 85 | } 86 | EventStream.prototype.tail = function () { 87 | let stream = this; 88 | let old_tick = this.tick; 89 | function thunk () { 90 | if (stream.tick === old_tick) { 91 | stream.tick = !stream.tick; 92 | stream.hd = stream.buffer; 93 | stream.buffer = stream.noEvent; 94 | } 95 | return stream; 96 | } 97 | return (new Lazy(thunk)); 98 | } 99 | 100 | // Take a nullary event like onClick and generate a stream of booleans 101 | // saying whether the event happened this tick. 102 | 103 | function booleanEventStream(onEvent) { 104 | return new EventStream(false, 105 | function (f) { 106 | onEvent(function () { f(true); }); 107 | }); 108 | } 109 | 110 | // Take a stream of keyboard events and generate a stream of option string 111 | // saying whether the event happened, and what the string was. 112 | 113 | function keyboardEventStream(onEvent) { 114 | let none = ["None", []]; 115 | let some = function(v) { return ["Some", v]; }; 116 | return new EventStream(none, 117 | function(f) { 118 | onEvent(function(evt) { f(some(String.fromCharCode(evt.charCode))); }); 119 | }); 120 | } 121 | 122 | 123 | //////////////// 124 | 125 | function lazyfix(f) { 126 | return f(new Lazy(function () { return lazyfix(f); })); 127 | } 128 | 129 | function toString (n) { 130 | return n.toString(); 131 | } 132 | 133 | function cat (pair) { 134 | return pair[0] + pair[1]; 135 | } 136 | 137 | //////////////// Widgets //////////////// 138 | // 139 | // Widgets are basically DOM nodes, plus two extra properties. 140 | // First, we add a tickQueue property, which queues the actions to 141 | // perform on the node at the end of a timestep. 142 | // 143 | // Second, we have a maybeText property, which is either false (if the 144 | // DOM node does not have a text node as a direct subchild), or is a 145 | // text node (if the DOM node has that text node as a direct subchild). 146 | // 147 | // We use maybeText to give a simpler API for updating the 148 | 149 | // The step function executes all of the queued actions on each widget, 150 | // when a tick happens. It does this bottom-up, updating all the children 151 | // of a DOM node before updating the node. 152 | 153 | function isWidget(node) { 154 | return node.hasOwnProperty('tickQueue'); 155 | } 156 | 157 | function $step(widget) { 158 | let children = widget.childNodes; 159 | let i = 0; 160 | let len = children.length; 161 | while (i < len) { 162 | if (isWidget(children.item(i))) { 163 | $step(children.item(i)); 164 | } 165 | i = i + 1; 166 | } 167 | // 168 | let todo = widget.tickQueue; 169 | widget.tickQueue = []; 170 | todo.forEach(function(thunk) { thunk.force(); }); 171 | } 172 | 173 | // Now, here are the operations to build and modify widgets 174 | 175 | function mkText(label) { 176 | return (function () { 177 | let text = document.createTextNode(label); 178 | let span = document.createElement("span"); 179 | span.appendChild(text); 180 | span.tickQueue = []; 181 | span.maybeText = text; 182 | return span; 183 | }); 184 | } 185 | 186 | function mkButton() { 187 | let b = document.createElement("button"); 188 | b.tickQueue = []; 189 | b.maybeText = false; 190 | return b; 191 | } 192 | 193 | 194 | function hbox() { 195 | let elt = document.createElement("div"); 196 | elt.style.display="block"; 197 | elt.maybeText = false; 198 | elt.tickQueue = []; 199 | return elt; 200 | } 201 | 202 | function vbox() { 203 | let elt = document.createElement("div"); 204 | elt.style.display='inline'; 205 | elt.maybeText = false; 206 | elt.tickQueue = []; 207 | return elt; 208 | } 209 | 210 | function attachOp(args) { 211 | let w1 = args[0]; 212 | let w2 = args[1]; 213 | w1.appendChild(w2); 214 | return w1; 215 | } 216 | 217 | function attach() { 218 | return attachOp; 219 | } 220 | 221 | 222 | //////////////// Splitting and merging widgets //////////////// 223 | // 224 | // Both the frame type and the widget type are represented by DOM 225 | // nodes. However, when we join a frame and its future thunk, we 226 | // push that thunk onto the list of actions for the widget. This 227 | // lets us update the node when a tick happens. 228 | 229 | function splitOp(widget) { 230 | return [widget, new Lazy(function () { return widget; })]; 231 | } 232 | 233 | function split() { 234 | return splitOp; 235 | } 236 | 237 | function mergePrim(w0, wlazy) { 238 | w0.tickQueue.push(wlazy); 239 | return w0; 240 | } 241 | 242 | function mergeOp(args) { 243 | let w0 = args[0]; 244 | let wlazy = args[1]; 245 | w0.tickQueue.push(wlazy); 246 | return w0; 247 | } 248 | 249 | function merge() { 250 | return mergeOp; 251 | } 252 | 253 | function dropOp(w) { 254 | return new Lazy(function () { return widget; }); 255 | } 256 | 257 | 258 | 259 | //////////////// Operations to modify widgets //////////////// 260 | 261 | function text(txt) { 262 | return (function () { 263 | return (function (widget) { 264 | let new_text = document.createTextNode(txt); 265 | if (widget.maybeText) { 266 | widget.replaceChild(new_text, widget.maybeText); 267 | } else { 268 | widget.appendChild(new_text); 269 | } 270 | widget.maybeText = new_text; 271 | return widget; 272 | }); 273 | }); 274 | } 275 | 276 | function color(colorname) { 277 | return (function () { 278 | return (function (widget) { 279 | widget.style.color = colorname; 280 | return widget; 281 | }); 282 | }); 283 | } 284 | 285 | function backgroundColor(colorname) { 286 | return (function () { 287 | return (function (widget) { 288 | widget.style.color = colorname; 289 | return widget; 290 | }); 291 | }); 292 | } 293 | 294 | 295 | function font(fontname) { 296 | return (function () { 297 | return (function (widget) { 298 | widget.style.font = fontname; 299 | return widget; 300 | }); 301 | }); 302 | } 303 | 304 | function fontFamily(family) { 305 | return (function () { 306 | return (function (widget) { 307 | widget.style.fontFamily = family; 308 | return widget; 309 | }); 310 | }); 311 | } 312 | 313 | function width(w) { 314 | return (function () { 315 | return (function (widget) { 316 | widget.style.width = w; 317 | return widget; 318 | }); 319 | }); 320 | } 321 | 322 | 323 | //////////////// Events 324 | // 325 | // Events work by taking a widget, and attaching a listener for an event 326 | // to it. For linearity's sake we return the argument as well. 327 | 328 | function clicksOp (elt) { 329 | let bs = booleanEventStream(function(f) { elt.addEventListener("click", f, false); }); 330 | return [elt, bs]; 331 | } 332 | 333 | function clicks() { 334 | return clicksOp; 335 | } 336 | 337 | function mouseOverOp (elt) { 338 | let bs = booleanEventStream(function(f) { elt.addEventListener("mouseover", f, false); }); 339 | return [elt, bs]; 340 | } 341 | 342 | function mouseover() { 343 | return mouseOverOp; 344 | } 345 | 346 | function keypressOp (elt) { 347 | let ks = keyboardEventStream(function (f) { elt.addEventListener("keypress", f, false); }); 348 | return [elt, ks]; 349 | } 350 | 351 | function keypress() { 352 | return keypressOp; 353 | } 354 | 355 | 356 | //////////////// 357 | 358 | function repeat(thunk, n) { 359 | function repeater() { 360 | thunk(); 361 | window.setTimeout(repeater, n); 362 | } 363 | window.setTimeout(repeater, n); 364 | } 365 | 366 | function $start(app_root, app) { 367 | let widget = app(); 368 | document.getElementById(app_root).appendChild(widget); 369 | repeat(function () { $step(widget); }, 25); 370 | } 371 | -------------------------------------------------------------------------------- /stdlib.old: -------------------------------------------------------------------------------- 1 | val toString : num -> string 2 | 3 | val mkText : G(F(stream string) -o window) 4 | val mkButton : G(window) 5 | val attach : G((window * window) -o window) 6 | 7 | val cat : string & string -> string 8 | 9 | val div : G(window) 10 | 11 | val color : string -> G(window -o window) 12 | val font : string & num -> G(window -o window) 13 | val width : string -> G(window -o window) 14 | 15 | val vbox : G(window) 16 | val hbox : G(window) 17 | 18 | val clicks : G(window -o window * F (stream bool)) 19 | val mouseover : G(window -o window * F (stream bool)) 20 | 21 | val dynamic : stream (G(window -o window)) -> G(window -o window) 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /stdlib.sig: -------------------------------------------------------------------------------- 1 | // types 2 | 3 | type option a = None | Some of a 4 | type list a = Nil | Cons of a × list a 5 | 6 | // utility functions 7 | 8 | val toString : num → string 9 | val cat : string × string → string 10 | 11 | // Widget construction 12 | 13 | val mkText : string → G(∃ a. dom a) 14 | val mkButton : G(∃ a. dom a) 15 | val vbox : G(∃ a. dom a) 16 | val hbox : G(∃ a. dom a) 17 | 18 | val attach : G(∀ a b. dom a ⊗ dom b ⊸ dom a) 19 | 20 | // Widget modification 21 | 22 | val backgroundColor : string → G(∀ a. dom a ⊸ dom a) 23 | val color : string → G(∀ a. dom a ⊸ dom a) 24 | val font : string → G(∀ a. dom a ⊸ dom a) 25 | val fontFamily : string → G(∀ a. dom a ⊸ dom a) 26 | val width : string → G(∀ a. dom a ⊸ dom a) 27 | val text : string → G(∀ a. dom a ⊸ dom a) 28 | val width : string → G(∀ a. dom a ⊸ dom a) 29 | 30 | // Widget dynamics 31 | 32 | val split : G(∀ a. dom a ⊸ frame a ⊗ next(dom a)) 33 | val merge : G(∀ a. frame a ⊗ next(dom a) ⊸ dom a) 34 | 35 | // Event processing 36 | 37 | val mouseover : G(∀ a. dom a ⊸ dom a ⊗ F (stream bool)) 38 | val clicks : G(∀ a. dom a ⊸ dom a ⊗ F (stream bool)) 39 | val keypress : G(∀ a. dom a ⊸ dom a ⊗ F (stream (option string))) 40 | 41 | // val doubleclicks : G(∀ a. dom a ⊸ dom a ⊗ F (stream bool)) 42 | 43 | -------------------------------------------------------------------------------- /subtype.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ast 3 | open Context 4 | open Kinding 5 | 6 | let fmt_tp () tp = string_of_tp tp 7 | 8 | let rec with_hyps hyps cmd = 9 | match hyps with 10 | | [] -> cmd 11 | | h :: hs -> with_hyp h (with_hyps hs cmd) 12 | 13 | let swizzle h1 h2 cmd = 14 | orelse (with_hyps [h1; h2] cmd) 15 | (with_hyps [h2; h1] cmd) 16 | 17 | let rec subtype s t k = 18 | subst_kind k >>= subtype' s t 19 | 20 | and subtype' s t = function 21 | | KArrow(k1, k2) -> 22 | newid "a" >>= (fun a -> 23 | with_hyp (a, Type(Univ, k1, None)) 24 | (subtype (TApp(s, [TVar a])) (TApp(t, [TVar a])) k2)) 25 | | (Int as k) | (Lin as k) -> base_subtype s t k 26 | | KVar _ -> assert false 27 | 28 | and base_subtype s t k = 29 | whnf s >>= (fun s -> 30 | whnf t >>= (fun t -> 31 | base_subtype' s t k)) 32 | 33 | and base_subtype' s t k = 34 | match k, s, t with 35 | | KArrow(_, _), _, _ -> assert false 36 | | KVar _, _, _ -> assert false 37 | | Int, Num, Num 38 | | Int, Bool, Bool 39 | | Int, String, String -> return () 40 | | Int, Pure s1, Pure t1 -> base_subtype s1 t1 Int 41 | | Lin, F s1, F t1 -> base_subtype s1 t1 Int 42 | | Int, G s1, G t1 -> base_subtype s1 t1 Lin 43 | | k, Next s1, Next t1 -> base_subtype s1 t1 k 44 | | Int, Arrow(s1, s2), Arrow(t1, t2) -> base_subtype t1 s1 Int >> 45 | base_subtype s2 t2 Int 46 | | Lin, Lolli(s1, s2), Lolli(t1, t2) -> base_subtype t1 s1 Lin >> 47 | base_subtype s2 t2 Lin 48 | | Lin, Frame s, Svg t 49 | | Lin, Svg s, Svg t 50 | | Lin, Dom s, Dom t -> base_subtype s t Int 51 | | Int, Product ss, Product ts -> 52 | seq (map2 (fun s1 t1 -> base_subtype s1 t1 Int) ss ts) >>= (fun (_ : unit list) -> return ()) 53 | | Lin, Tensor ss, Tensor ts -> 54 | seq (map2 (fun s1 t1 -> base_subtype s1 t1 Lin) ss ts) >>= (fun (_ : unit list) -> return ()) 55 | | k, s, Forall(b, Some k2, t) -> 56 | fresh rename_tp b t >>= (fun (b, t) -> 57 | with_hyp (b, Type(Univ, k2, None)) (base_subtype s t k)) 58 | | k, Exists(a, Some k1, s), t -> 59 | fresh rename_tp a s >>= (fun (a, s) -> 60 | with_hyp (a, Type(Univ, k1, None)) (base_subtype s t k)) 61 | | k, Forall(a, Some k1, s), Exists(b, Some k2, t) -> 62 | subkind k1 k2 >> 63 | fresh rename_tp a s >>= (fun (a, s) -> 64 | fresh rename_tp b t >>= (fun (b, t) -> 65 | let h1 = (a, Type(Exist, k1, None)) in 66 | let h2 = (b, Type(Exist, k1, None)) in 67 | swizzle h1 h2 (base_subtype s t k))) 68 | | k, Forall(a, Some k1, s), t -> 69 | fresh rename_tp a s >>= (fun (a, s) -> 70 | with_hyp (a, Type(Exist, k1, None)) (base_subtype s t k)) 71 | | k, s, Exists(b, Some k2, t) -> 72 | fresh rename_tp b t >>= (fun (b, t) -> 73 | with_hyp (b, Type(Exist, k2, None)) (base_subtype s t k)) 74 | 75 | 76 | 77 | 78 | let expand_kind tp k kexpect = 79 | orelse 80 | (subkind k kexpect >> subst_kind k) 81 | (error "Expected type of kind %a, got type %a of kind %a" fmt_kind kexpect fmt_tp tp fmt_kind k) 82 | 83 | let expand_const kexpect f a = 84 | let (tp, k) = f() in 85 | expand_kind tp k kexpect >>= (fun k' -> 86 | update_eqn a [a, Type(Exist, k', Some tp)]) 87 | 88 | let expand_one kexpect f a = 89 | newid "b" >>= (fun b -> 90 | let (tp, k, k') = f b in 91 | expand_kind tp k kexpect >>= (fun k0 -> 92 | update_eqn a [b, Type(Exist, k', None); a, Type(Exist, k0, Some tp)])) 93 | 94 | let expand_two kexpect f a = 95 | newid "b" >>= (fun b -> 96 | newid "c" >>= (fun c -> 97 | let (tp, k, (kb, kc)) = f b c in 98 | expand_kind tp k kexpect >>= (fun k' -> 99 | update_eqn a [b, Type(Exist, kb, None); 100 | c, Type(Exist, kc, None); 101 | a, Type(Exist, k', Some tp)]))) 102 | 103 | let expand_list kexpect f xs a = 104 | seq (map (fun _ -> newid "x") xs) >>= (fun bs -> 105 | let (tp, k, ks) = f bs in 106 | let decls = map2 (fun b k -> (b, Type(Exist, k, None))) bs ks in 107 | expand_kind tp k kexpect >>= (fun k' -> 108 | let tp' = Type(Exist, k', Some tp) in 109 | update_eqn a (decls @ [a, tp']))) 110 | 111 | 112 | let expand_num k = expand_const k (fun a -> (Num, Int)) 113 | let expand_string k = expand_const k (fun a -> (String, Int)) 114 | let expand_bool k = expand_const k (fun a -> (Bool, Int)) 115 | let expand_pure k = expand_one k (fun a -> (Pure(TVar a), Int, Int)) 116 | let expand_next k = expand_one k (fun a -> (Next(TVar a), Int, Int)) 117 | let expand_nextlin k = expand_one k (fun a -> (Next(TVar a), Lin, Lin)) 118 | let expand_f k = expand_one k (fun a -> (F(TVar a), Lin, Int)) 119 | let expand_g k = expand_one k (fun a -> (G(TVar a), Int, Lin)) 120 | let expand_dom k = expand_one k (fun a -> (Dom(TVar a), Lin, Int)) 121 | let expand_frame k = expand_one k (fun a -> (Frame(TVar a), Lin, Int)) 122 | let expand_svg k = expand_one k (fun a -> (Svg(TVar a), Lin, Int)) 123 | let expand_stream k = expand_one k (fun a -> (Stream(TVar a), Int, Int)) 124 | let expand_arrow k = expand_two k (fun a b -> (Arrow(TVar a, TVar b), Int, (Int, Int))) 125 | let expand_lolli k = expand_two k (fun a b -> (Lolli(TVar a, TVar b), Lin, (Lin, Lin))) 126 | let expand_product ts k a = expand_list k (fun bs -> (Product (map (fun a -> TVar a) bs), Int, map (fun _ -> Int) bs)) ts a 127 | let expand_tensor ts k a = expand_list k (fun bs -> (Tensor (map (fun a -> TVar a) bs), Lin, map (fun _ -> Lin) bs)) ts a 128 | let expand_app d xs k a = expand_list k (fun bs -> (TApp(TVar d, map (fun a -> TVar a) bs), Int, map (fun _ -> Int) bs)) xs a 129 | 130 | let rec expand a tp = 131 | synth_kind tp >>= (fun (_, k) -> 132 | match tp with 133 | | Num -> expand_num k a 134 | | String -> expand_string k a 135 | | Bool -> expand_bool k a 136 | | Pure _ -> expand_pure k a 137 | | Next _ -> expand_next k a 138 | | F t -> expand_f k a 139 | | G t -> expand_g k a 140 | | Dom t -> expand_dom k a 141 | | Frame t -> expand_frame k a 142 | | Svg t -> expand_svg k a 143 | | Stream t -> expand_stream k a 144 | | Arrow(_, _) -> expand_arrow k a 145 | | Lolli(_, _) -> expand_lolli k a 146 | | Product ts -> expand_product ts k a 147 | | Tensor ts -> expand_tensor ts k a 148 | | TApp(TVar d, ts) -> expand_app d ts k a 149 | | TApp(_, ts) -> assert false 150 | | TVar b -> before a (synth_kind (TVar b)) >>= (fun (tp, k') -> 151 | expand_kind tp k' k >>= (fun k'' -> 152 | update_eqn a [a, Type(Exist, k'', Some (TVar b))])) 153 | | TAnnot(tp, k) -> expand a tp 154 | | Forall(_, _, _) -> assert false 155 | | Exists(_, _, _) -> assert false 156 | | TLet(_, _, _) -> assert false 157 | | TLam(_, _) -> assert false) 158 | 159 | let mismatch msg tp = 160 | subst tp >>= (fun tp -> error "expected %s type, got %a" msg fmt_tp tp) 161 | 162 | let expand_evar a error_type expander = 163 | lookup a >>= (function 164 | | Type(Exist, k, None) -> expander k a 165 | | Type(_, k, Some _) -> assert false 166 | | Type(Univ, k, _) -> mismatch error_type (TVar a) 167 | | _ -> error "'%a' is not a type variable" fmt_id a) 168 | 169 | let rec (<==) s t = 170 | subst s >>= (fun s' -> 171 | subst t >>= (fun t' -> 172 | sub s' t')) 173 | 174 | and sub s t = 175 | match s, t with 176 | | Num, Num 177 | | Bool, Bool 178 | | String, String -> return () 179 | | Stream s', Stream t' 180 | | Frame s', Frame t' 181 | | Dom s', Dom t' 182 | | Svg s', Svg t' 183 | | Pure s', Pure t' 184 | | Next s', Next t' 185 | | G s', G t' 186 | | F s', F t' -> (s' <== t') 187 | | Arrow(s1, s2), Arrow(t1, t2) 188 | | Lolli(s1, s2), Lolli(t1, t2) -> (t1 <== s1) >> (s2 <== s2) 189 | | Product ss, Product ts when length ss = length ts -> 190 | seq (map2 (fun s t -> (s <== t)) ss ts) >>= (fun _ -> return ()) 191 | | Tensor ss, Tensor ts when length ss = length ts -> 192 | seq (map2 (fun s t -> (s <== t )) ss ts) >>= (fun _ -> return ()) 193 | | TApp(TVar d, ss), TApp(TVar d', ts) when d = d' && length ss = length ts -> 194 | seq (map2 (fun s t -> (s <== t)) ss ts) >>= (fun _ -> return ()) 195 | | Forall(a, Some k, s), Exists(b, Some k', t) -> 196 | expand_kind s k k' >>= (fun k'' -> 197 | fresh rename_tp a s >>= (fun (a,s) -> 198 | fresh rename_tp b t >>= (fun (b,t) -> 199 | let cmd1 = with_hyp (a, Type(Exist, k'', None)) 200 | (with_hyp (b, Type(Exist, k'', None)) 201 | ((s <== t))) in 202 | let cmd2 = with_hyp (b, Type(Exist, k'', None)) 203 | (with_hyp (a, Type(Exist, k'', None)) 204 | ((s <== t))) in 205 | orelse cmd1 cmd2))) 206 | | Forall(a, _, s), Exists(b, _, t) -> assert false 207 | | Exists(a, Some k, s), Exists(b, Some k', t) -> 208 | expand_kind s k k' >>= (fun k'' -> 209 | fresh rename_tp a s >>= (fun (a,s) -> 210 | fresh rename_tp b t >>= (fun (b,t) -> 211 | let cmd1 = with_hyp (a, Type(Univ, k'', None)) 212 | (with_hyp (b, Type(Exist, k'', None)) 213 | ((s <== t))) in 214 | let cmd2 = with_hyp (b, Type(Exist, k'', None)) 215 | (with_hyp (a, Type(Univ, k'', None)) 216 | ((s <== t))) in 217 | orelse cmd1 cmd2))) 218 | | Exists(a, _, s), Exists(b, _, t) -> assert false 219 | | Forall(a, Some k, s), Forall(b, Some k', t) -> 220 | expand_kind s k k' >>= (fun k'' -> 221 | fresh rename_tp a s >>= (fun (a,s) -> 222 | fresh rename_tp b t >>= (fun (b,t) -> 223 | let cmd1 = with_hyp (a, Type(Exist, k'', None)) 224 | (with_hyp (b, Type(Univ, k'', None)) 225 | ((s <== t))) in 226 | let cmd2 = with_hyp (b, Type(Univ, k'', None)) 227 | (with_hyp (a, Type(Exist, k'', None)) 228 | ((s <== t))) in 229 | orelse cmd1 cmd2))) 230 | | Forall(a, _, s), Forall(b, _, t) -> assert false 231 | | Exists(a, Some k, s), Forall(b, Some k', t) -> 232 | expand_kind s k k' >>= (fun k'' -> 233 | fresh rename_tp a s >>= (fun (a,s) -> 234 | fresh rename_tp b t >>= (fun (b,t) -> 235 | let cmd1 = with_hyp (a, Type(Univ, k'', None)) 236 | (with_hyp (b, Type(Univ, k'', None)) 237 | ((s <== t))) in 238 | let cmd2 = with_hyp (b, Type(Univ, k'', None)) 239 | (with_hyp (a, Type(Univ, k'', None)) 240 | ((s <== t))) in 241 | orelse cmd1 cmd2))) 242 | | Exists(a, _, s), Forall(b, _, t) -> assert false 243 | | s, Forall(a, Some k, t) -> 244 | fresh rename_tp a t >>= (fun (a, t) -> 245 | with_hyp (a, Type(Univ, k, None)) ((s <== t))) 246 | | s, Forall(a, None, t) -> assert false 247 | | Exists(a, Some k, s), t -> 248 | fresh rename_tp a s >>= (fun (a, s) -> 249 | with_hyp (a, Type(Univ, k, None)) ((s <== t))) 250 | | Exists(a, None, s), t -> assert false 251 | | Forall(a, Some k, s), t -> 252 | fresh rename_tp a s >>= (fun (a, s) -> 253 | push (a, Type(Exist, k, None)) >> (* Change to with_hyp? *) 254 | (s <== t)) 255 | | Forall(a, None, s), t -> assert false 256 | | s, Exists(a, Some k, t) -> 257 | fresh rename_tp a t >>= (fun (a, t) -> 258 | push (a, Type(Exist, k, None)) >> (* Change to with_hyp? *) 259 | (s <== t)) 260 | | s, Exists(a, None, t) -> assert false 261 | | TVar a, u 262 | | u, TVar a -> 263 | lookup a >>= (function 264 | | Type(_, _, Some _) -> assert false 265 | | Type(Univ, k, None) -> 266 | (match u with 267 | | TVar b when a = b -> return () 268 | | TVar b -> 269 | lookup b >>= (function 270 | | Type(Univ, _, _) -> 271 | error "'%a' is not an instance of '%a'" fmt_id a fmt_id b 272 | | Type(Exist, _, Some _) -> assert false 273 | | Type(Exist, k', None) -> 274 | expand_kind u k k' >>= (fun k'' -> 275 | before b (check_kind (TVar a) k'') >>= (fun tpa -> 276 | update_eqn b [b, Type(Exist, k'', Some tpa)])) 277 | | _ -> error "variable '%a' is not a type variable" fmt_id b) 278 | | _ -> error "'%a' is not an instance of '%a'" fmt_id a fmt_tp u) 279 | | Type(Exist, k, None) -> 280 | (match u with 281 | | TVar b when a = b -> return () 282 | | TVar b -> 283 | lookup b >>= (function 284 | | Type(_, _, Some _) -> assert false 285 | | Type(Exist, k', None) -> 286 | expand_kind u k k' >>= (fun k'' -> 287 | let cmd1 = before b (check_kind (TVar a) k'') >>= (fun tpa -> 288 | update_eqn b [b, Type(Exist, k'', Some tpa)]) in 289 | let cmd2 = before a (check_kind (TVar b) k'') >>= (fun tpb -> 290 | update_eqn a [a, Type(Exist, k'', Some tpb)]) in 291 | orelse cmd1 cmd2) 292 | | Type(Univ, k', None) -> 293 | expand_kind u k k' >>= (fun k'' -> 294 | before a (synth_kind (TVar b)) >>= (fun _ -> 295 | update_eqn a [a, Type(Exist, k'', Some(TVar b))])) 296 | | _ -> error "variable '%a' is not a type variable" fmt_id b) 297 | | _ -> 298 | before a (synth_kind u) >>= (fun _ -> 299 | expand a u >> 300 | (s <== t))) 301 | | _ -> error "variable '%a' is not a type variable" fmt_id a) 302 | | _, _ -> error "'%a' is not an instance of '%a'" fmt_tp s fmt_tp t 303 | 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | -------------------------------------------------------------------------------- /subtype.mli: -------------------------------------------------------------------------------- 1 | val expand_const : 2 | Ast.kind -> 3 | (unit -> Ast.tp * Ast.kind) -> Base.id -> unit Context.t 4 | val expand_one : 5 | Ast.kind -> 6 | (Base.id -> Ast.tp * Ast.kind * Ast.kind) -> 7 | Base.id -> unit Context.t 8 | val expand_two : 9 | Ast.kind -> 10 | (Base.id -> 11 | Base.id -> Ast.tp * Ast.kind * (Ast.kind * Ast.kind)) -> 12 | Base.id -> unit Context.t 13 | val expand_list : 14 | Ast.kind -> 15 | (Base.id list -> Ast.tp * Ast.kind * Ast.kind list) -> 16 | 'a list -> Base.id -> unit Context.t 17 | val expand_num : Ast.kind -> Base.id -> unit Context.t 18 | val expand_string : Ast.kind -> Base.id -> unit Context.t 19 | val expand_bool : Ast.kind -> Base.id -> unit Context.t 20 | val expand_pure : Ast.kind -> Base.id -> unit Context.t 21 | val expand_next : Ast.kind -> Base.id -> unit Context.t 22 | val expand_nextlin : Ast.kind -> Base.id -> unit Context.t 23 | val expand_f : Ast.kind -> Base.id -> unit Context.t 24 | val expand_g : Ast.kind -> Base.id -> unit Context.t 25 | val expand_dom : Ast.kind -> Base.id -> unit Context.t 26 | val expand_frame : Ast.kind -> Base.id -> unit Context.t 27 | val expand_svg : Ast.kind -> Base.id -> unit Context.t 28 | val expand_stream : Ast.kind -> Base.id -> unit Context.t 29 | val expand_arrow : Ast.kind -> Base.id -> unit Context.t 30 | val expand_lolli : Ast.kind -> Base.id -> unit Context.t 31 | val expand_product : 'a list -> Ast.kind -> Base.id -> unit Context.t 32 | val expand_tensor : 'a list -> Ast.kind -> Base.id -> unit Context.t 33 | val expand_app : 34 | Base.id -> 'a list -> Ast.kind -> Base.id -> unit Context.t 35 | val expand : Base.id -> Ast.tp -> unit Context.t 36 | val mismatch : string -> Ast.tp -> 'a Context.t 37 | val expand_evar : 38 | Base.id -> 39 | string -> (Ast.kind -> Base.id -> 'a Context.t) -> 'a Context.t 40 | val ( <== ) : Ast.tp -> Ast.tp -> unit Context.t 41 | val sub : Ast.tp -> Ast.tp -> unit Context.t 42 | -------------------------------------------------------------------------------- /subtype.txt: -------------------------------------------------------------------------------- 1 | k ::= ∗ | k → k 2 | A ::= ∀α:k.A | ∃α:k.A | A → B | α | A B | λα:k.A | α̂ 3 | 4 | Γ ⊢ A ≤ B : k ⊣ Γ 5 | 6 | 7 | Γ, α:k₁ ⊢ A α ≤ B α ⊣ Γ', α:k₁, Γ'' 8 | ——————————————————————————————————— 9 | Γ ⊢ A ≤ B : k₁ → k₂ ⊣ Γ' 10 | 11 | 12 | Γ, α:k ⊢ A ≤ B ⊣ Γ', α:k, Δ 13 | ———————————————————————————— 14 | Γ ⊢ A ≤ ∀α:k.B ⊣ Γ' 15 | 16 | Γ ⊢ A ⇓ A' : ∗ 17 | Γ ⊢ B ⇓ B' : ∗ 18 | Γ ▷ A' ≤ B' ◁ ⊣ Γ' 19 | —————————————————— 20 | Γ ⊢ A ≤ B : ∗ ⊣ Γ' 21 | 22 | 23 | Γ, ▸[α̂], α̂:k ⊢ [α̂/α]A ≤ B ⊣ Γ', ▸[α̂], Δ 24 | ——————————————————————————————————————— 25 | Γ ▷ ∀α:k.A ≤ B : ∗ ◁ Γ' 26 | 27 | 28 | Γ, ▸[α̂], α̂:k ⊢ A ≤ [α̂/α]B ⊣ Γ', ▸[α̂], Δ 29 | ——————————————————————————————————————— 30 | Γ ▷ A ≤ ∃α:k.B : ∗ ◁ Γ' 31 | 32 | 33 | Γ, α:k ⊢ A ≤ B ⊣ Γ', α:k, Δ 34 | ———————————————————————————— 35 | Γ ▷ ∃α:k.A ≤ B ◁ Γ' 36 | 37 | 38 | Γ ⊢ B₁ ≤ A₁ : ∗ ⊣ Γ' 39 | Γ' ⊢ A₂ ≤ B₂ : ∗ ⊣ Γ'' 40 | ——————————————————————————————— 41 | Γ ▷ A₁ → A₂ ≤ B₁ → B₂ : ∗ ◁ Γ'' 42 | 43 | 44 | Γ, α̂:k, Γ' ⊣ α̂ · x_1 ... x_n := B : k ⊣ Δ 45 | ————————————————————————————————————— 46 | Γ, α̂:k, Γ' ▷ α̂ x₁ ... x_n ≤ B : k' ◁ Δ 47 | 48 | 49 | Γ, α̂:k, Γ' ⊣ α̂ · x_1 ... x_n := B ⊣ Δ 50 | ————————————————————————————————————— 51 | Γ, α̂:k, Γ' ▷ B ≤ α̂ x₁ ... x_n : k' ◁ Δ 52 | 53 | 54 | α̂:k[1] → ... k[n] → ∗ ∈ Γ[1] 55 | ∀i ∈ [1..n]. Γ[i] ⊢ A_i ≡ B_i : k[i] ⊣ Γ[i+1] 56 | ———————————————————————————————————————–——————— 57 | Γ[1] ▷ α̂ A₁ ... A_n ≤ α̂ B₁ .. B_n : ∗ ◁ Γ[n+1] 58 | 59 | 60 | α:k[1] → ... k[n] → ∗ ∈ Γ[1] 61 | ∀i ∈ [1..n]. Γ[i] ⊢ A_i ≡ B_i : k[i] ⊣ Γ[i+1] 62 | ———————————————————————————————————————–——————— 63 | Γ[1] ▷ α A₁ ... A_n ≤ α B₁ .. B_n : ∗ ◁ Γ[n+1] 64 | 65 | 66 | 67 | Γ, β̂₁:k, β̂₂:k, α̂:k=(λx_1...x_n. β̂₁ x₁ ... x_n → β̂₂ x₁ ... x_n), Γ' ⊢ β̂₁ · x_1 ... x_n := B₁ ⊣ Δ 68 | Δ ⊢ β̂₂ · x_1 ... x_n := B₂ ⊣ Δ' 69 | ———————————————————————————————————————————————————————————————————————————————————————————————— 70 | Γ, α̂:k, Δ ⊢ α̂ · x_1 ... x_n := B₁ → B₂ ⊣ Γ', α̂:k=(λx_1 ... x_n. B), Γ' ⊣ Δ' 71 | 72 | 73 | Γ ⊢ λx_1 ... x_n. B ⇐ k ⊣ Γ' B neutral 74 | ——————————————————————————————————————————————————————————————— 75 | Γ, α̂:k, Δ ⊢ α̂ · x_1 ... x_n := B ⊣ Γ', α̂:k=(λx_1 ... x_n. B), Δ 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | -------------------------------------------------------------------------------- /testing.ml: -------------------------------------------------------------------------------- 1 | #load "jscomp.cma";; 2 | #install_printer Base.print_pos;; 3 | 4 | module Test = struct 5 | open Ast 6 | open Context 7 | open Subtype 8 | open Poly 9 | 10 | 11 | let exp = Parseloc.string Parser.test_exp 12 | let tp = Parseloc.string Parser.test_tp 13 | let pat = Parseloc.string Parser.test_pat 14 | let prog = Parseloc.string Parser.test_program 15 | let signature = Parseloc.string Parser.test_signature 16 | let signature_decl = Parseloc.string Parser.test_signature_decl 17 | let program = Parseloc.string Parser.test_program 18 | 19 | let pos = (Lexing.dummy_pos, Lexing.dummy_pos) 20 | 21 | let check0 e t ctx = 22 | let cmd = Kinding.check_kind (tp t) Int >>= (fun t -> 23 | (check (exp e) t 0)) in 24 | run cmd ctx Base.dummy_pos 25 | let synth0 e ctx = run (synth (exp e) 0) ctx Base.dummy_pos 26 | 27 | let check (e, t) = check0 e t [] 28 | let synth e = synth0 e [] 29 | 30 | let infer_kind t = run (Kinding.synth_kind (tp t)) [] pos 31 | let subtype t t' = run (Subtype.(<==) (tp t) (tp t')) [] pos 32 | 33 | let ctx = ["x$1", Hyp(Dyn, TVar "a$0", 0); ("a$0", Type (Exist, Int, Some Ast.Num))] 34 | let ctx_u = ["u$2", Hyp(Dyn, tp "num & num", 0)] 35 | 36 | let tests0 = [| "let x = 3 in x", "num"; 37 | "fun x -> x", "num -> num"; 38 | "fun x -> x", "forall a. a -> a"; 39 | "fun x -> x", "exists a. a -> a"; 40 | "3", "exists a. a"; 41 | ("val fact : num -> num 42 | let loop fact n = 43 | if n = 0 then 1 else n * fact (n - 1) in 44 | fact 5", 45 | "num"); 46 | ("val fact_iter : num & num -> num 47 | let loop fact_iter (n, acc) = 48 | if n = 0 then acc else fact_iter(1, 1) 49 | in 50 | fact_iter(5, 1)", 51 | "num"); 52 | ("val fact_iter : num & num -> num 53 | let loop fact_iter (n, acc) = 54 | if n = 0 then acc else fact_iter(1, 1) 55 | in 56 | fact_iter(5, 1)", 57 | "num"); 58 | ("val ones : alloc -> stream num 59 | let rec ones x = cons(x, 1, ones x) in ones", 60 | "alloc -> stream num"); 61 | ("fun x -> (x, x)", 62 | "forall a. a -> (a & a)"); 63 | ("fun loop f x -> f x", 64 | "forall a b. a -> b"); 65 | |] 66 | let r0() = Array.map check tests0 67 | 68 | let print_result r i = 69 | match r.(i) with 70 | | Value (t, _) -> let (stmts, exp) = Translate.translate t in 71 | Pp.print (Js.print_stmts stmts) stdout; 72 | Printf.fprintf stdout "---\n"; 73 | Pp.print (Js.print_exp exp) stdout; 74 | Printf.fprintf stdout "\n" 75 | | Error msg -> Printf.fprintf stdout "%s" msg 76 | 77 | 78 | 79 | let ctx_d = ["list", Data(["a"], ["Nil", tp "unit"; 80 | "Cons", tp "a & list a"])] 81 | 82 | let checkd (e, t) = check0 e t ctx_d 83 | let ds = [|"Nil()", "forall a. list a"; 84 | "val is_empty : forall a. list a -> bool 85 | let is_empty xs = 86 | match xs begin 87 | Nil _-> true 88 | | Cons _ -> false 89 | end 90 | in 91 | is_empty (Nil())", 92 | "bool"; 93 | 94 | "val is_one : forall a. list a -> bool 95 | let is_one xs = 96 | match xs begin 97 | Nil _ -> false 98 | | Cons(_, Nil _) -> false 99 | | Cons(_, Cons _) -> true 100 | end 101 | in is_one(Cons(1, Nil()))", 102 | "bool"; 103 | 104 | "fun loop length xs -> 105 | match xs begin 106 | Nil() -> 0 107 | | Cons(x, xs) -> 1 + length xs 108 | end", 109 | "forall a. list a -> num"; 110 | 111 | ("fix map (!f) u (x :: xs) -> cons(u, f x, map (!f) u xs)", 112 | "forall a b. !(a -> b) -> alloc -> stream a -> stream b"); 113 | 114 | ("fix zip u (x :: xs) (y :: ys) -> cons(u, (x,y), zip u xs ys)", 115 | "forall a b. alloc -> stream a -> stream b -> stream (a & b)"); 116 | 117 | ("fun (next(x,y)) -> (next x, next y)", 118 | "forall a b. next(a & b) -> next a & next b"); 119 | 120 | ("fun (next x, next y) -> next(x, y)", 121 | "forall a b. next a & next b -> next(a & b)"); 122 | 123 | ("fix delay_stream u (d :: ds) -> 124 | let next x = d in 125 | next(let next xs = delay_stream u ds in cons(u, x, xs))", 126 | "forall a. alloc -> stream (next a) -> next (stream a)"); 127 | 128 | ("G(let () = ( () : (exists a. I)) in ())", 129 | "G(exists a. I)") 130 | 131 | 132 | |] 133 | let r1() = Array.map checkd ds 134 | 135 | let lctx = 136 | [("mkButton", Hyp(Stable, tp "G(exists a. dom a)", 0)); 137 | ("mkLabel", Hyp(Stable, tp "string -> G(exists a. dom a)", 0)); 138 | ("vstack", Hyp(Stable, tp "G(forall a b. dom a -o dom b -o dom a)", 0)); 139 | ("split", Hyp(Stable, tp "G(forall a. dom a -o frame a * next(dom a))", 0)); 140 | ("merge", Hyp(Stable, tp "G(forall a. frame a * next(dom a) -o dom a)", 0)); 141 | ] 142 | 143 | let lcheck0 e t ctx = run (lcheck (exp e) (tp t) 0) ctx Base.dummy_pos 144 | let checkl (e, t) = lcheck0 e t lctx 145 | let lsynth0 e ctx = run (lsynth (exp e) 0) ctx Base.dummy_pos 146 | let synthl e = lsynth0 e lctx 147 | 148 | let ls = [| ("()", "I"); 149 | ("((), ())", "I * I"); 150 | ("fun x -> x", "I -o I"); 151 | ("fun (x, y) -> (y, x)", 152 | "forall a b. a * b -o b * a"); 153 | ("run mkButton", 154 | "exists a. dom a"); 155 | ("run (mkLabel \"hi\")", 156 | "exists a. dom a"); 157 | ("run vstack", 158 | "forall a b. dom a -o dom b -o dom a"); 159 | ("let b = run mkButton in b", 160 | "exists a. dom a"); 161 | ("let b1 = run mkButton in 162 | let b2 = run mkButton in 163 | (b1, b2)", 164 | "(exists a1. dom a1) * (exists a2. dom a2)"); 165 | ("let b1 = run mkButton in 166 | let b2 = run mkButton in 167 | (b1, b2)", 168 | "(exists a1 a2. dom a1 * dom a2)"); 169 | ("let b = run mkButton in 170 | let l = run (mkLabel \"hi\") in 171 | (run vstack) b l", 172 | "exists a. dom a"); 173 | ("fun error -> (error, error)", 174 | "F(num) -o F(num) * F(num)"); 175 | ("fix foo w -> 176 | let (f, next w1) = (run split) w in 177 | (run merge) (f, next(foo w1))", 178 | "forall a. dom a -o dom a"); 179 | |] 180 | let lr1() = Array.map checkl ls 181 | 182 | let sig0 = "val toString : num -> string 183 | 184 | val mkText : stream string -> G(exists a. dom a) 185 | val mkButton : G(exists a. dom a) 186 | val vbox : G(exists a. dom a) 187 | val hbox : G(exists a. dom a) 188 | 189 | val attach : G(forall a b. dom a * dom b -o dom a) 190 | val cat : string & string -> string 191 | 192 | val div : G(exists a. dom a) 193 | 194 | val color : string -> G(forall a. dom a -o dom a) 195 | val font : string & num -> G(forall a. dom a -o dom a) 196 | val width : string -> G(forall a. dom a -o dom a) 197 | val setText : string -> G(forall a. dom a -o dom a) 198 | 199 | val clicks : alloc -> G(forall a. dom a -o dom a * F (stream bool)) 200 | val mouseover : alloc -> G(forall a. dom a -o dom a * F (stream bool)) 201 | val split : G(forall a. dom a -o frame a * next(dom a)) 202 | val merge : G(forall a. frame a * next(dom a) -o dom a) 203 | type list a = 204 | | Nil of unit 205 | | Cons of a & list a 206 | type option a = None of unit | Some of a 207 | type event = Foo | Bar 208 | val event_to_bool : event -> bool " 209 | 210 | let runsig string = 211 | let s = signature string in 212 | run (Toplevel.process_signature s) [] Base.dummy_pos 213 | 214 | let programs = [| 215 | "val map : forall a b. (a -> b) -> list a -> list b 216 | let map f = 217 | fun loop recur xs -> 218 | match xs begin 219 | | Nil() -> Nil() 220 | | Cons(y, ys) -> Cons(f y, recur ys) 221 | end 222 | 223 | val main : alloc -> G(exists a. dom a) 224 | let main u = mkButton 225 | 226 | in main"; 227 | 228 | "val ints : alloc -> num -> stream num 229 | let rec ints u n = cons(u, n, ints u (n+1)) 230 | 231 | val map : forall a b. !(a -> b) -> alloc -> stream a -> stream b 232 | let rec map (!f) u ns = 233 | let x :: xs = ns in 234 | cons(u, f x, map (!f) u xs) 235 | 236 | val main : alloc -> G(exists a. dom a) 237 | let main u = 238 | let labels : stream string = map (!toString) u (ints u 0) in 239 | G(let w1 = run (mkText labels) in w1) 240 | 241 | in main"; 242 | 243 | 244 | "val toBool : event -> bool 245 | let toBool e = 246 | match e begin 247 | Foo -> true 248 | | Bar -> false 249 | end 250 | 251 | val main : alloc -> G(exists a. dom a) 252 | let main u = mkButton 253 | 254 | in main"; 255 | 256 | "type window : int 257 | let window = G(exists a. dom a) 258 | 259 | val mkText : string -> G(exists a. dom a) 260 | 261 | val map : forall a b. !(a -> b) -> alloc -> stream a -> stream b 262 | let rec map (!f) u (x :: xs) = 263 | cons(u, f x, map (!f) u xs) 264 | 265 | val zip : forall a b. alloc -> stream a & stream b -> stream (a & b) 266 | let rec zip u ((x :: xs), (y :: ys)) = 267 | cons(u, (x,y), zip u (xs, ys)) 268 | 269 | val always : forall a. alloc -> !a -> stream a 270 | let rec always u (!x) = cons(u, x, always u (!x)) 271 | 272 | val join : alloc -> stream bool -> stream bool -> stream bool 273 | let join u bs1 bs2 = map (!(fun (b1, b2) -> b1 || b2)) u (zip u (bs1, bs2)) 274 | 275 | val dynbutton : alloc -> window 276 | let dynbutton acap = 277 | G(val grow : forall a. dom a -o F(stream bool) -o dom a 278 | let rec grow w0 (F (b :: bs1)) = 279 | if b then 280 | let wbutton = run mkButton in 281 | let wlabel = run (mkText \"Click me\") in 282 | let (wlabel, F (_ :: bs2)) = run (clicks acap) wlabel in 283 | let wbutton = run attach (wbutton, wlabel) in 284 | let wjoin = run attach (w0, wbutton) in 285 | let (wnow, next wrest) = run split wjoin in 286 | run merge (wnow, next (grow wrest (F (join acap bs1 bs2)))) 287 | else 288 | let (wnow, next wrest) = run split w0 in 289 | run merge (wnow, next (grow wrest (F bs1))) 290 | in 291 | let w = run vbox in 292 | grow w (F(always acap (!false)))) 293 | 294 | in 295 | 296 | dynbutton" ; 297 | 298 | "// val blah : G(forall a. dom a -o exists b. dom b) 299 | // let blah = G(fun w -> w) 300 | 301 | val mkText : string -> G(exists a. dom a) 302 | 303 | val main : alloc -> G(exists a. dom a) 304 | let main u = 305 | G(val blah : forall a. dom a -o exists b. dom b 306 | let blah w = w in 307 | let wroot = run (mkText \"\") in 308 | blah wroot) 309 | 310 | in main"; 311 | 312 | |] 313 | 314 | let run_program' s p = 315 | run (Toplevel.process_signature (signature s) >> 316 | Toplevel.elaborate (program p)) [] Base.dummy_pos 317 | 318 | 319 | let run_program string = 320 | run_program' sig0 string 321 | end 322 | 323 | -------------------------------------------------------------------------------- /tests.ml: -------------------------------------------------------------------------------- 1 | let ftype s = Parser.test_ftype Lexer.token (Lexing.from_string s) 2 | let ltype s = Parser.test_ltype Lexer.token (Lexing.from_string s) 3 | let fexp s = Parser.test_fexp Lexer.token (Lexing.from_string s) 4 | let lexp s = Parser.test_lexp Lexer.token (Lexing.from_string s) 5 | let toplevel s = Parser.toplevel Lexer.token (Lexing.from_string s) 6 | let sig_list s = Parser.sig_list Lexer.token (Lexing.from_string s) 7 | let pat s = Parser.pat Lexer.token (Lexing.from_string s) 8 | 9 | let run = Unittest.run Format.std_formatter 10 | 11 | 12 | let ftype_tests = 13 | let open Unittest in 14 | let open Ast in 15 | group 16 | "Nonlinear types" 17 | [ test "bool" (fun () -> 18 | Bool = ftype "bool"); 19 | test "unit" (fun () -> 20 | Product [] = ftype "unit"); 21 | test "string" (fun () -> 22 | String = ftype "string"); 23 | test "num" (fun () -> 24 | Num = ftype "num"); 25 | test "(bool)" (fun () -> 26 | Bool = ftype "(bool)"); 27 | test "bool & bool" (fun () -> 28 | Product [Bool; Bool] = ftype "bool & bool"); 29 | test "(bool & bool)" (fun () -> 30 | Product [Bool; Bool] = ftype "(bool & bool)"); 31 | test "next bool" (fun () -> NextType Bool = ftype "next bool"); 32 | test "next bool & next bool" (fun () -> 33 | Product [NextType Bool; NextType Bool] = ftype "next bool & next bool"); 34 | test "!bool" (fun () -> 35 | Pure Bool = ftype "!bool"); 36 | test "!bool & !bool" (fun () -> 37 | Product [Pure Bool; Pure Bool] = ftype "!bool & !bool"); 38 | test "!next bool" (fun () -> 39 | Pure (NextType Bool) = ftype "!next bool"); 40 | test "next !bool" (fun () -> 41 | NextType (Pure Bool) = ftype "next !bool"); 42 | test "num -> num" (fun () -> 43 | Arrow(Num, Num) = ftype "num -> num"); 44 | test "num -> num -> num" (fun () -> 45 | Arrow(Num, Arrow(Num, Num)) = ftype "num -> num -> num"); 46 | test "num & num -> num" (fun () -> 47 | Arrow(Product[Num; Num], Num) = ftype "num & num -> num"); 48 | test "num -> num & num" (fun () -> 49 | Arrow(Num, Product[Num; Num]) = ftype "num -> num & num"); 50 | test "num -> stream num & num -> num" (fun () -> 51 | Arrow(Num, Arrow(Product [Stream Num; Num], Num)) = ftype "num -> stream num & num -> num"); 52 | test "alloc" (fun () -> Alloc = ftype "alloc") 53 | ] 54 | 55 | let ltype_tests = 56 | let open Unittest in 57 | let open Ast in 58 | group 59 | "Linear types" 60 | [ test "I" (fun () -> 61 | Tensor [] = ltype "I"); 62 | test "window" (fun () -> 63 | Dom = ltype "window"); 64 | test "(window)" (fun () -> 65 | Dom = ltype "(window)"); 66 | test "window * window" (fun () -> 67 | Tensor [Dom; Dom] = ltype "window * window"); 68 | test "(window * window)" (fun () -> 69 | Tensor [Dom; Dom] = ltype "(window * window)"); 70 | test "window -o window" (fun () -> 71 | Lolli(Dom, Dom) = ltype "window -o window"); 72 | test "window * window -o window" (fun () -> 73 | Lolli(Tensor [Dom; Dom], Dom) = ltype "window * window -o window"); 74 | test "window -o window * window" (fun () -> 75 | Lolli(Dom, Tensor [Dom; Dom]) = ltype "window -o window * window"); 76 | ] 77 | 78 | let adjoint_tests = 79 | let open Unittest in 80 | let open Ast in 81 | let open Base in 82 | group 83 | "Adjoint types" 84 | [ test "G I" (fun () -> 85 | G (Tensor []) = ftype "G I"); 86 | test "G window" (fun () -> 87 | G Dom = ftype "G window"); 88 | test "G (window)" (fun () -> 89 | G Dom = ftype "G (window)"); 90 | test "G (window -o window)" (fun () -> 91 | (G(Lolli(Dom, Dom))) = ftype "G (window -o window)"); 92 | crashtest "G window * window [parse error]" 93 | (fun () -> ftype "G window * window") 94 | (function SyntaxError(_, "nonlinear type") -> true | _ -> false); 95 | test "(G F G window) -> G window" (fun () -> 96 | Arrow(G(F(G Dom)), G Dom) = ftype "(G F G window) -> G window"); 97 | test "F unit" (fun () -> 98 | F (Product []) = ltype "F unit"); 99 | test "F num" (fun () -> 100 | F Num = ltype "F num"); 101 | test "F(num)" (fun () -> 102 | F Num = ltype "F(num)"); 103 | test "F(num -> num)" (fun () -> 104 | F (Arrow(Num, Num)) = ltype "F(num -> num)"); 105 | ] 106 | 107 | let parsing_types = 108 | let open Unittest in 109 | group "Types" 110 | [ ftype_tests; 111 | ltype_tests; 112 | adjoint_tests 113 | ] 114 | 115 | let fexp_tests = 116 | let open Unittest in 117 | let open Ast in 118 | let open Base in 119 | let eq s1 s2 = fexp_eq (fexp s1) (fexp s2) in 120 | let eqse s e = fexp_eq (fexp s) e in 121 | let d = (Lexing.dummy_pos, Lexing.dummy_pos) in 122 | let var x = (d, FVar x) in 123 | let u = var "u" in 124 | let v = var "v" in 125 | let w = var "w" in 126 | let x = var "x" in 127 | let y = var "y" in 128 | let z = var "z" in 129 | let num n = (d, FNum n) in 130 | let (+) e1 e2 = (d, FOp(Plus, e1, e2)) in 131 | let ( * ) e1 e2 = (d, FOp(Times, e1, e2)) in 132 | let tuple es = (d, FTuple es) in 133 | let app e1 e2 = (d, FApp(e1, e2)) in 134 | let pvar x = (d, PVar x) in 135 | let px = pvar "x" in 136 | let py = pvar "y" in 137 | let pz = pvar "z" in 138 | let ptuple ps = (d, PTuple ps) in 139 | let letvar p e1 e2 = (d, FLet(p, e1, e2)) in 140 | let fn p e = (d, FLam(p, e)) in 141 | let true' = (d, FTrue) in 142 | let false' = (d, FFalse) in 143 | let ifte(e1, e2, e3) = (d, FIf(e1, e2, e3)) in 144 | let cons e0 e e' = (d, FCons(e0, e, e')) in 145 | let pcons e e' = (d, PCons(e, e')) in 146 | let pure e = (d, FBang e) in 147 | let annot e tp = (d, FAnnot(e, tp)) in 148 | let test s v = test s (fun () -> eqse s v) in 149 | group "Nonlinear expressions" 150 | [ Unittest.test "x = (x)" (fun () -> 151 | eq "x" "(x)"); 152 | Unittest.test "x != y" (fun () -> 153 | not (eq "x" "y")); 154 | test "x = FVar x" x; 155 | test "num 1" (num 1.); 156 | test "x y" (app x y); 157 | test "x y z" (app (app x y) z); 158 | test "x (y z)" (app x (app y z)); 159 | test "x + y" (x + y); 160 | test "x + y + z" ((x + y) + z); 161 | test "x + (y + z)" (x + (y + z)); 162 | test "x + y * z" (x + (y * z)); 163 | test "y * z + x" ((y * z) + x); 164 | test "y z + x" ((app y z) + x); 165 | test "x + y z" (x + (app y z)); 166 | test "()" (tuple []); 167 | test "(x, y)" (tuple [x; y]); 168 | test "(u, v, w)" (tuple [u; v; w]); 169 | test "fun () -> ()" (fn (ptuple []) (tuple [])); 170 | test "fun x -> x" (fn px x); 171 | test "fun (x,y) -> (u,v)" (fn (ptuple [px;py]) (tuple [u;v])); 172 | test "fun ((x, y)) -> (u,v)" (fn (ptuple [px;py]) (tuple [u;v])); 173 | test "fun x y z -> (x,y,z)" (fn px (fn py (fn pz (tuple [x;y;z])))); 174 | test "let x = 1 in x" (letvar px (num 1.) x); 175 | test "let (x,y) = (u,v) in x+y" (letvar (ptuple [px; py]) (tuple [u; v]) (x + y)); 176 | test "let (x,y) = (u,v) in x y" (letvar (ptuple [px; py]) (tuple [u; v]) (app x y)); 177 | test "true" true'; 178 | test "false" false'; 179 | test "if u then v else w" (ifte(u, v, w)); 180 | test "if u then v else if x then y else z" (ifte(u, v, ifte(x,y,z))); 181 | test "1 + if u then v else if x then y else z" ((num 1.) + ifte(u, v, ifte(x,y,z))); 182 | test "if u then v else w + 1" (ifte(u, v, (w + num 1.))); 183 | test "x (if u then v else w + 1)" (app x (ifte(u, v, (w + num 1.)))); 184 | test "cons(w, x, u)" (cons w x u); 185 | test "let x :: y = v in w" (letvar (pcons px "y") v w); 186 | test "!w" (pure w); 187 | test "x (!w)" (app x (pure w)); 188 | test "x : num" (annot x Num); 189 | test "let x : num = y in z" (letvar px (annot y Num) z); 190 | test "let (x :: y) : stream num = v in w" (letvar (pcons px "y") (annot v (Stream Num)) w); 191 | ] 192 | 193 | let lexp_tests = 194 | let open Unittest in 195 | let open Ast in 196 | let open Base in 197 | let eqse s e = lexp_eq (lexp s) e in 198 | let d = (Lexing.dummy_pos, Lexing.dummy_pos) in 199 | let var x = (d, LVar x) in 200 | let u = var "u" in 201 | let v = var "v" in 202 | let w = var "w" in 203 | let x = var "x" in 204 | let y = var "y" in 205 | let z = var "z" in 206 | let tuple es = (d, LTuple es) in 207 | let app e1 e2 = (d, LApp(e1, e2)) in 208 | let pvar x = (d, PVar x) in 209 | let px = pvar "x" in 210 | let py = pvar "y" in 211 | let pz = pvar "z" in 212 | let ptuple ps = (d, PTuple ps) in 213 | let letvar p e1 e2 = (d, LLet(p, e1, e2)) in 214 | let fn p e = (d, LLam(p, e)) in 215 | let annot e tp = (d, LAnnot(e, tp)) in 216 | let test s v = test s (fun () -> eqse s v) in 217 | group "Nonlinear expressions" 218 | [ test "x" x; 219 | test "x y" (app x y); 220 | test "x y z" (app (app x y) z); 221 | test "x (y z)" (app x (app y z)); 222 | test "()" (tuple []); 223 | test "(x, y)" (tuple [x; y]); 224 | test "(u, v, w)" (tuple [u; v; w]); 225 | test "fun () -> ()" (fn (ptuple []) (tuple [])); 226 | test "fun x -> x" (fn px x); 227 | test "fun (x,y) -> (u,v)" (fn (ptuple [px;py]) (tuple [u;v])); 228 | test "fun ((x, y)) -> (u,v)" (fn (ptuple [px;py]) (tuple [u;v])); 229 | test "fun x y z -> (x,y,z)" (fn px (fn py (fn pz (tuple [x;y;z])))); 230 | test "let (x,y) = (u,v) in x y" (letvar (ptuple [px; py]) (tuple [u; v]) (app x y)); 231 | test "let x : F num = y in z" (letvar px (annot y (F Num)) z); 232 | ] 233 | 234 | let parser_tests = 235 | let open Unittest in 236 | group "Parsing" [parsing_types; group "Expressions" [fexp_tests; lexp_tests]] 237 | 238 | 239 | let ftyping_tests = 240 | let open Unittest in 241 | let open Ast in 242 | let open Typing in 243 | let ctx1 = [ ("x", (Num, Dynamic, 0)); 244 | ("y", (Bool, Dynamic, 1)); 245 | ("z", (Arrow(String, Num), Dynamic, 0)); 246 | ("xs", (Stream Num, Dynamic, 1)); 247 | ("u", (Num, Stable, 0)); 248 | ("v", (Arrow(Stream Num, String), Stable, 0)); 249 | ("x", (String, Dynamic, 0)); ] in 250 | let check succ name ctx i stp se = 251 | test name (fun () -> 252 | try 253 | let _ = check_fexp ctx i (ftype stp) (fexp se) in succ 254 | with 255 | TypeError(_, _) -> not succ) 256 | in 257 | let noerr exp i tp = check true (Printf.sprintf "%s : %s [%d]" exp tp i) ctx1 i tp exp in 258 | let error exp i tp = check false (Printf.sprintf "%s : %s [%d]" exp tp i) ctx1 i tp exp in 259 | let variables = 260 | group "Variables" 261 | [ noerr "x" 0 "num"; 262 | noerr "x" 1 "num"; 263 | noerr "xs" 1 "stream num"; 264 | error "xs" 2 "stream num"; 265 | noerr "y" 1 "bool"; 266 | error "y" 0 "bool"; 267 | error "x" 0 "string"; 268 | noerr "u" 0 "num"; 269 | noerr "u" 1 "num"; 270 | noerr "u" 2 "num"; 271 | ] in 272 | let expressions = 273 | group "Expressions" 274 | [ noerr "fun a -> a" 0 "bool -> bool"; 275 | noerr "fun a -> a" 1 "bool -> bool"; 276 | noerr "fun a -> a" 2 "bool -> bool"; 277 | noerr "!(fun a -> a)" 2 "!(bool -> bool)"; 278 | noerr "next y" 0 "next bool"; 279 | noerr "5." 1 "num"; 280 | noerr "y && true" 1 "bool"; 281 | noerr "(5, true)" 0 "num & bool"; 282 | noerr "let y = x in x + y" 0 "num"; 283 | noerr "let (x,y) : num & num = (3,4) in x + y" 0 "num"; 284 | noerr "let x : num = if true then 3 else 4 in x + x" 0 "num"; 285 | noerr "let f : num -> bool = fun n -> n > 0 in f 15" 0 "bool"; 286 | error "let f = fun n -> n > 0 in f 15" 0 "bool"; 287 | noerr "let f : num & num -> num = fun (x,y) -> x + y in f (3,4)" 0 "num"; 288 | noerr "!x" 0 "!num"; 289 | noerr "let next z : next bool = next y in next (y && z)" 0 "next bool"; 290 | noerr "let next z : next bool = next y in next (u > 5 || (y && z))" 0 "next bool"; 291 | ] in 292 | let recursive = 293 | group "Recursive" 294 | [ noerr "fix xs u -> cons(u, 0, xs u)" 0 "alloc -> stream num"; 295 | noerr "fix ints u n -> cons(u, n, ints u (n+1))" 0 "alloc -> num -> stream num"; 296 | error "fun xs -> fix xss us -> cons(u, xs, xss u)" 0 "stream num -> alloc -> stream stream num"; 297 | noerr "fun !n -> fix ns u -> cons(u, n, ns u)" 0 "!num -> alloc -> stream num"; 298 | noerr "fix unzip u xys -> let (x,y) :: xys = xys in let next dxys = next (unzip u xys) in let next xs = next (let (xs, ys) = dxys in xs) in let next ys = next (let (xs, ys) = dxys in ys) in (cons(u, x, xs), cons(u, y, ys))" 0 "alloc -> stream (num & num) -> stream num & stream num"; 299 | ] 300 | in 301 | group "Nonlinear" [variables; expressions; recursive] 302 | 303 | 304 | let ltyping_tests = 305 | let open Unittest in 306 | let open Ast in 307 | let open Typing in 308 | let ctx = [ ("x", (Num, Dynamic, 0)); 309 | ("y", (Bool, Dynamic, 1)); 310 | ("z", (Arrow(String, Num), Dynamic, 0)); 311 | ("xs", (Stream Num, Dynamic, 1)); 312 | ("stack", (G(Lolli(Tensor [Dom;Dom], Dom)), Stable, 0)); 313 | ("v", (Arrow(Stream Num, String), Stable, 0)); 314 | ("x", (String, Dynamic, 0)); ] in 315 | let a_hyp = ("a", (F Num, false, 0)) in 316 | let v0_hyp = ("v0", (Dom, false, 0)) in 317 | let w0_hyp = ("w0", (Dom, false, 0)) in 318 | let w1_hyp = ("w1", (Dom, false, 1)) in 319 | let w_nohyp = ("w_no", (Dom, true, 0)) in 320 | let b = ("b", (ltype "F num -o window", false, 0)) in 321 | let check succ name lctx i stp se = 322 | let no_exn = if succ then Success else Failure "No exception!" in 323 | let exn s = if succ then Failure s else Success in 324 | fulltest name (fun () -> 325 | try 326 | let _ = check_lexp ctx lctx i (ltype stp) (lexp se) in no_exn 327 | with 328 | TypeError(_, msg) -> exn msg) 329 | in 330 | let noerr exp lctx i tp = check true (Printf.sprintf "%s : %s [%d]" exp tp i) lctx i tp exp in 331 | let error exp lctx i tp = check false (Printf.sprintf "%s : %s [%d]" exp tp i) lctx i tp exp in 332 | let vars = 333 | group "Variables" 334 | [ noerr "a" [a_hyp] 0 "F num"; 335 | noerr "a" [a_hyp; w0_hyp] 0 "F num"; 336 | error "w_nohyp" [a_hyp; w0_hyp; w_nohyp] 0 "window"; 337 | noerr "w1" [a_hyp; w1_hyp; w_nohyp] 1 "window"; 338 | error "w1" [a_hyp; w1_hyp; w_nohyp] 0 "window"; 339 | ] in 340 | let exps = 341 | group "Expressions" 342 | [ error "(a, a)" [a_hyp] 0 "F num * F num"; 343 | noerr "(v0, w0)" [w0_hyp; v0_hyp] 0 "window * window"; 344 | error "(v0, v0)" [v0_hyp] 0 "window * window"; 345 | noerr "(run stack) (v0, w0)" [w0_hyp; v0_hyp] 0 "window"; 346 | noerr "fun w -> w" [] 0 "window -o window"; 347 | noerr "F 4" [] 0 "F num"; 348 | noerr "b (F 5)" [b] 0 "window"; 349 | noerr "let F n = a in b (F n)" [b; a_hyp] 0 "window"; 350 | noerr "let F f : F (G (window -o window)) = F (G (fun w -> w)) in (run f) ((run f) v0)" [v0_hyp] 0 "window"; 351 | noerr "F (G (fun w -> w))" [] 0 "F (G (window -o window))"; 352 | noerr "let a = v0 in a" [v0_hyp] 0 "window"; 353 | error "fun a -> (a,a)" [] 0 "window -o window * window"; 354 | noerr "let (a,b) : window * window = (v0, w0) in (b,a)" [v0_hyp; w0_hyp] 0 "window * window"; 355 | noerr "let a = v0 in (let b = w0 in (b,a))" [v0_hyp; w0_hyp] 0 "window * window"; 356 | noerr "let b = w0 in (v0,b)" [v0_hyp; w0_hyp] 0 "window * window"; 357 | noerr "let (a,b) : window * window = (v0, w0) in (a,b)" [v0_hyp; w0_hyp] 0 "window * window"; 358 | ] 359 | in 360 | group "Linear Expressions" [vars; exps] 361 | 362 | -------------------------------------------------------------------------------- /token.ml: -------------------------------------------------------------------------------- 1 | type tok = 2 | | Next 3 | | Cons 4 | | RParen 5 | | LParen 6 | | Comma 7 | | Bang 8 | | F 9 | | Fun 10 | | To 11 | | Plus 12 | | Minus 13 | | Ast 14 | | AndAnd 15 | | Or 16 | | Let 17 | | Colon 18 | | Equal 19 | | In 20 | | G 21 | | Fix 22 | | Loop 23 | | True 24 | | False 25 | | If 26 | | Then 27 | | Else 28 | | Num of float 29 | | String of string 30 | | Ident of string 31 | | Run 32 | | StreamType 33 | | And 34 | | StringType 35 | | NumType 36 | | BoolType 37 | | Lolli 38 | | Window 39 | -------------------------------------------------------------------------------- /toplevel.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ast 3 | open Poly 4 | open Context 5 | open Kinding 6 | open Subtype 7 | 8 | let map = List.map 9 | let mapM f xs = seq (map f xs) 10 | 11 | let rec iterM f = function 12 | | [] -> return () 13 | | v :: vs -> f v >> iterM f vs 14 | 15 | 16 | exception CompileError of string 17 | 18 | let rec ofilter = function 19 | | [] -> [] 20 | | None :: xs -> ofilter xs 21 | | (Some x) :: xs -> x :: (ofilter xs) 22 | 23 | let process_binding = function 24 | | ValueBind(pos, x, e, tp) -> 25 | setpos pos >> 26 | check_kind tp Int >>= (fun tp -> 27 | check e tp 0 >>= (fun t -> 28 | push (x, Hyp(Stable, tp, 0)) >> 29 | return (Some(x, t)))) 30 | | ValueDecl (pos, x, tp) -> 31 | setpos pos >> 32 | check_kind tp Int >>= (fun tp -> 33 | push (x, Hyp(Stable, tp, 0)) >> 34 | return None) 35 | | TypeBind(pos, a, tp, kind) -> 36 | setpos pos >> 37 | check_kind tp kind >>= (fun tp -> 38 | push (a, Type(Univ, kind, Some tp)) >> 39 | return None) 40 | | TypeDecl(pos, a, kind) -> 41 | setpos pos >> 42 | push (a, Type(Univ, kind, None)) >> 43 | return None 44 | | DataBind (pos, d, (k, bs, cenv)) -> 45 | setpos pos >> 46 | mapM (fun (b, k) -> newid b >>= (fun b' -> return (b,k))) bs >>= (fun bs' -> 47 | push (d, Data(k, bs, cenv)) >> 48 | let cenv = map (fun (c, tp) -> (c, List.fold_right2 rename_tp (map fst bs) (map fst bs') tp)) cenv in 49 | iterM (fun (b, k) -> push (b, Type(Univ, k, None))) bs' >> 50 | mapM (fun (c, tp) -> check_kind tp Int >>= (fun tp -> return (c,tp))) cenv >>= (fun cenv -> 51 | pop d >> 52 | push (d, Data(k, bs', cenv)) >> 53 | return None)) 54 | 55 | 56 | let rec process_bindings = function 57 | | [] -> return [] 58 | | b :: bs -> process_binding b >>= (function 59 | | None -> process_bindings bs 60 | | Some r -> process_bindings bs >>= (fun rs -> 61 | return (r :: rs))) 62 | 63 | let elaborate (bs, e) = 64 | process_bindings bs >>= (fun tenv -> 65 | newid "a" >>= (fun a -> 66 | check e (G(Exists(a, Some Int, Dom (TVar a)))) 0 >>= (fun main -> 67 | return (tenv, main)))) 68 | 69 | let translate_binding (x, t) = 70 | let (s, e) = Translate.translate t in 71 | s @ [Js.LetDef(x, e)] 72 | 73 | let translate_program (bs, e) = 74 | let s = List.concat (map translate_binding bs) in 75 | let (mains, mainexp) = Translate.translate e in 76 | let main_stmt = 77 | Js.LetDef("$main", Js.Fun(None, [], [Js.Return (Js.Apply(mainexp, []))])) 78 | in 79 | s @ mains @ [main_stmt] 80 | 81 | let process_signature_elt = function 82 | | DataDecl (pos, d, (k, bs, cenv)) -> 83 | setpos pos >> 84 | mapM (fun (b, k) -> newid b >>= (fun b' -> return (b,k))) bs >>= (fun bs' -> 85 | push (d, Data(k, bs, cenv)) >> 86 | let cenv = map (fun (c, tp) -> (c, List.fold_right2 rename_tp (map fst bs) (map fst bs') tp)) cenv in 87 | iterM (fun (b, k) -> push (b, Type(Univ, k, None))) bs' >> 88 | mapM (fun (c, tp) -> check_kind tp Int >>= (fun tp -> return (c,tp))) cenv >>= (fun cenv -> 89 | pop d >> 90 | push (d, Data(k, bs', cenv)))) 91 | 92 | | SigTypeDecl(pos, x, tp) -> 93 | setpos pos >> 94 | check_kind tp Int >>= (fun tp -> 95 | push (x, Hyp(Stable, tp, 0))) 96 | 97 | let process_signature sigs = 98 | iterM process_signature_elt sigs 99 | 100 | let signature_environment sigs = 101 | match run (process_signature sigs) [] Base.dummy_pos with 102 | | Error msg -> raise (CompileError msg) 103 | | Value((), ctx) -> ctx 104 | 105 | let compile out env program = 106 | match run (elaborate program) env Base.dummy_pos with 107 | | Error msg -> raise (CompileError msg) 108 | | Value(result, _) -> 109 | Pp.print (Js.print_stmts (translate_program result)) out 110 | -------------------------------------------------------------------------------- /toplevel.mli: -------------------------------------------------------------------------------- 1 | exception CompileError of string 2 | 3 | val process_signature_elt : Ast.signature_elt -> unit Context.t 4 | val process_signature : Ast.signature_elt list -> unit Context.t 5 | 6 | val process_binding : 7 | Ast.decl -> (Base.id * Lambda.term) option Context.t 8 | val process_bindings : 9 | Ast.decl list -> (Base.id * Lambda.term) list Context.t 10 | 11 | val elaborate : 12 | Ast.decl list * Ast.exp -> 13 | ((Base.id * Lambda.term) list * Lambda.term) Context.t 14 | 15 | val translate_binding : Base.id * Lambda.term -> Js.statement list 16 | val translate_program : 17 | (Base.id * Lambda.term) list * Lambda.term -> Js.statement list 18 | 19 | val signature_environment : Ast.signature_elt list -> Context.ctx 20 | val compile : out_channel -> Context.ctx -> Ast.program -> unit 21 | -------------------------------------------------------------------------------- /translate.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Js 3 | open Lambda 4 | 5 | type dest = CallReturn | Ident of id 6 | type tailcall = Nontail | TailCall of id * id 7 | 8 | let option d = function None -> d | Some e -> e 9 | let return tgt r = 10 | match tgt, r with 11 | | _, None -> [] 12 | | CallReturn, Some e -> [Return e] 13 | | Ident x, Some e -> [Assign(x, e)] 14 | 15 | let rec translate term = 16 | let increment = let r = ref 0 in fun () -> (incr r; !r) in 17 | let newdest () = Printf.sprintf "$d_%d" (increment ()) in 18 | let freshen x = Printf.sprintf "%s_%d" x (increment()) in 19 | let extend x x' rho y = if x = y then x' else rho y in 20 | let expify f x = 21 | let d = newdest() in 22 | let (s, r) = f (Ident d) x in 23 | (s, option (Id d) r) 24 | in 25 | let apply tail e1 e2 = 26 | match tail, e1 with 27 | | TailCall(f,x), Id f' when f = f' -> 28 | ([Assign(x, e2); Continue], None) 29 | | _, _ -> ([], Some (Apply(e1, [e2]))) 30 | in 31 | let initialize = function 32 | | CallReturn -> [] 33 | | Ident x -> [LetNull x] 34 | in 35 | let rec loop rho tail d = function 36 | | Var x -> ([], Some (Id (rho x))) 37 | | LitString s -> ([], Some (String s)) 38 | | LitNum n -> ([], Some (Num n)) 39 | | LitBool b -> ([], Some (Bool b)) 40 | | App(t1, t2) -> 41 | let (s1, e1) = expify (loop rho Nontail) t1 in 42 | let (s2, e2) = expify (loop rho Nontail) t2 in 43 | let (s3, r3) = apply tail e1 e2 in 44 | (s1 @ s2 @ s3, r3) 45 | | Oper(op, t1, t2) -> 46 | let (s1, e1) = expify (loop rho Nontail) t1 in 47 | let (s2, e2) = expify (loop rho Nontail) t2 in 48 | (s1 @ s2, Some(Op(op, e1, e2))) 49 | | Merge(t1, t2) -> 50 | let (s1, e1) = expify (loop rho Nontail) t1 in 51 | let (s2, e2) = expify (loop rho Nontail) t2 in 52 | (s1 @ s2, Some (Apply(Id "mergePrim", [e1; e2]))) 53 | | Tuple ts -> 54 | let (stmts, es) = List.split (List.map (expify (loop rho Nontail)) ts) in 55 | (List.concat stmts, Some(Array es)) 56 | | Project(i, t) -> 57 | let (s, e) = expify (loop rho Nontail) t in 58 | (s, Some(Deref(e, Int i))) 59 | | If(t1, t2, t3) -> 60 | let (s1, e1) = expify (loop rho Nontail) t1 in 61 | let (s2, r2) = loop rho tail d t2 in 62 | let (s3, r3) = loop rho tail d t3 in 63 | (s1 @ initialize d @ [IfThenElse(e1, s2 @ return d r2, s3 @ return d r3)], None) 64 | | Lam(x, t) -> 65 | let x' = freshen x in 66 | let rho = extend x x' rho in 67 | let (s, r) = loop rho Nontail CallReturn t in 68 | ([], Some (Fun(None, [x'], s @ return CallReturn r))) 69 | | Let(x, t1, t2) -> 70 | let x' = freshen x in 71 | let (s1, r1) = loop rho Nontail (Ident x') t1 in 72 | let rho = extend x x' rho in 73 | let (s2, r2) = loop rho tail d t2 in 74 | (match r1 with 75 | | None -> (s1 @ s2, r2) 76 | | Some e -> (s1 @ [LetVar(x',e)] @ s2, r2)) 77 | | Lazy t -> 78 | let (s, r) = loop rho Nontail CallReturn t in 79 | ([], Some (New("Lazy", [Fun(None, [], s @ return CallReturn r)]))) 80 | | Force t -> 81 | let (s, e) = expify (loop rho Nontail) t in 82 | (s, Some(Method(e, "force", []))) 83 | | Thunk t -> 84 | let (s, r) = loop rho Nontail CallReturn t in 85 | ([], Some (Fun(None, [], s @ return CallReturn r))) 86 | | Run t -> 87 | let (s, e) = expify (loop rho Nontail) t in 88 | (s, Some(Apply(e, []))) 89 | | Fix(f, x, t) -> 90 | let f' = freshen f in 91 | let outer = freshen x in 92 | let inner = freshen x in 93 | let rho = extend f f' rho in 94 | let rho = extend x inner rho in 95 | let rho = extend f f' rho in 96 | let (s, r) = loop rho (TailCall(f',outer)) CallReturn t in 97 | let s = [WhileTrue ([LetVar(inner, Id outer)] @ s @ return CallReturn r)] in 98 | ([], Some (Fun(Some f', [outer], s))) 99 | | Lazyfix(x, t) -> 100 | let x' = freshen x in 101 | let rho = extend x x' rho in 102 | let (s, r) = loop rho Nontail CallReturn t in 103 | ([], Some (Apply(Id "lazyfix", [Fun(None, [x'], s @ return CallReturn r)]))) 104 | | Head t -> 105 | let (s, e) = expify (loop rho Nontail) t in 106 | (s, Some(Method(e, "head", []))) 107 | | Tail t -> 108 | let (s, e) = expify (loop rho Nontail) t in 109 | (s, Some(Method(e, "tail", []))) 110 | | Cons(t1, t2) -> 111 | let (s1, e1) = expify (loop rho Nontail) t1 in 112 | let (s2, e2) = expify (loop rho Nontail) t2 in 113 | (s1 @ s2, Some(New("Cons", [e1; e2]))) 114 | | Con(c, t1) -> 115 | let (s1, e1) = expify (loop rho Nontail) t1 in 116 | (s1, Some(Array[String c; e1])) 117 | | Case(t0, arms) -> 118 | let (s0, e0) = expify (loop rho Nontail) t0 in 119 | let con = Deref(e0, Int 0) in 120 | let value = Deref(e0, Int 1) in 121 | let break d = match d with CallReturn -> [] | Ident _ -> [Break] in 122 | let branch (c, x, t) = 123 | let x' = freshen x in 124 | let rho = extend x x' rho in 125 | let (s, r) = loop rho tail d t in 126 | (c, [LetVar(x', value)] @ s @ return d r @ break d) 127 | in 128 | (s0 @ initialize d @ [Switch(con, map branch arms)], None) 129 | in 130 | expify (loop (fun x -> x) Nontail) term 131 | 132 | 133 | -------------------------------------------------------------------------------- /translate.mli: -------------------------------------------------------------------------------- 1 | type dest = CallReturn | Ident of Base.id 2 | type tailcall = Nontail | TailCall of Base.id * Base.id 3 | val option : 'a -> 'a option -> 'a 4 | val return : dest -> Js.exp option -> Js.statement list 5 | val translate : Lambda.term -> Js.statement list * Js.exp 6 | -------------------------------------------------------------------------------- /typing.txt: -------------------------------------------------------------------------------- 1 | A ::= α | α' | A B | ∀α. A | ∃α. A || ∀α. A | ∃α. A | A → B | •A | S(A) | bool | G(X) 2 | X ::= I | X ⊗ ... ⊗ Y | X ⊸ Y | •X | F(X) | Window 3 | 4 | Γ ::= · | Γ, x:A[i] 5 | | Γ, x::A[i] 6 | | Γ, α 7 | | Γ, α=λα…. μβ.[C A | ... | C A'] 8 | | Γ, α'=? | Γ, α'=A | ▪[x] 9 | 10 | 11 | Term Typing 12 | 13 | x::A[i] ∈ Γ 14 | i ≤ j 15 | ————————————————— 16 | Γ ▷ x ⇒ A[j] ◁ Γ 17 | 18 | 19 | x:A[i] ∈ Γ 20 | ————————————————— 21 | Γ ▷ x ⇒ A[i] ◁ Γ 22 | 23 | 24 | Γ₀ ⊢ e ⇒ A[i] ⊣ Γ₁ 25 | Γ₁ ⊢ A ≤ B ⊣ Γ₂ 26 | —————————————————— 27 | Γ₀ ▷ e ⇐ B[i] ◁ Γ₂ 28 | 29 | 30 | Γ ⊢ A 31 | Γ ⊢ e ⇐ A[i] ⊣ Γ' 32 | ——————————————————————— 33 | Γ ▷ (e:A) ⇒ A[i] ◁ Γ' 34 | 35 | 36 | Γ₁ ⊢ e₁ ⇒ A[i] ⊣ Γ₂ 37 | Γ₂, x:A ⊢ e₂ ⇔ D[i] ⊣ Γ₃ 38 | —————————————————————————————————— 39 | Γ₁ ▷ let x = e₁ in e₂ ⇔ D[i] ◁ Γ₃ 40 | 41 | 42 | Γ₀,Γ₁ = Purify(Γ) 43 | Γ₀,▪[x], x:A[i] ⊢ e ⇐ A[i] ⊣ Γ₀', ▪[x], Γ₀'' 44 | ———————————————————————————————————————————— 45 | Γ ▷ μx. e ⇐ A[i] ▷ Merge[Γ](Γ₀';Γ₁) 46 | 47 | 48 | Γ, α=A ⊢ e ⇔ D[i] ⊣ Γ', α=A, Γ'' 49 | —————————————————————————————————— 50 | Γ ▷ let α = A in e ⇔ D[i] ◁ Γ' 51 | 52 | 53 | Variable types 54 | 55 | Γ ▷ e ⇐ Γ(α')[i] ◁ Γ' 56 | ——————————————————————— 57 | Γ ⊢ e ⇐ α'[i] ⊣ Γ' 58 | 59 | 60 | Γ ▷ e ⇐ A[i] ◁ Γ' A ≠ α' 61 | ———————————————————————————— 62 | Γ ⊢ e ⇐ A[i] ⊣ Γ' 63 | 64 | 65 | Γ ▷ e ⇒ α'[i] ◁ Γ' 66 | ——————————————————————— 67 | Γ ⊢ e ⇒ Γ(α')[i] ⊣ Γ' 68 | 69 | 70 | Γ ▷ e ⇒ A[i] ◁ Γ' A ≠ α' 71 | ————————————————————————————— 72 | Γ ⊢ e ⇒ A[i] ⊣ Γ' 73 | 74 | 75 | Boolean types 76 | 77 | ——————————————————— 78 | Γ ⊢ t/f ⇐ bool ⊣ Γ 79 | 80 | 81 | ———————————————————————————————————————— 82 | Γ, α'=?, Γ' ⊢ t/f ⇐ α' ⊣ Γ, α'=bool, Γ' 83 | 84 | 85 | Γ₀ ⊢ e ⇒ bool[i] ⊣ Γ₁ 86 | Γ₁ ⊢ e₁ ⇐ A[i] ⊣ Γ₂ 87 | Γ₂ ⊢ e₂ ⇐ A[i] ⊣ Γ₃ 88 | —————————————————————————————— 89 | Γ₀ ⊢ if(e, e₁, e₂) ⇐ A[i] ⊣ Γ₃ 90 | 91 | 92 | Γ₀ ⊢ e ⇒ α'[i] ⊣ Γ₁,α'=?,Γ₁' 93 | Γ₁,α'=bool,Γ₁' ⊢ e₁ ⇐ A[i] ⊣ Γ₂ 94 | Γ₂ ⊢ e₂ ⇐ A[i] ⊣ Γ₃ 95 | —————————————————————————————— 96 | Γ₀ ⊢ if(e, e₁, e₂) ⇐ A[i] ⊣ Γ₃ 97 | 98 | 99 | Function types 100 | 101 | Γ, ▪[x], x:A[i] ⊢ e ⇐ B[i] ⊣ Γ', ▪[x], Γ'' 102 | ———————————————————————————————————————————— 103 | Γ ▷ λx.e ⇐ A → B[i] ◁ Γ' 104 | 105 | 106 | Γ, β'=?, γ'=?, α'=β'→γ', Γ' ⊢ λx.e ⇐ α'[i] ▷ Γ'' 107 | ——————————————————————————————————————————————— 108 | Γ, α'=?, Γ' ▷ λx.e ⇐ α'[i] ◁ Γ' 109 | 110 | 111 | Γ₁ ⊢ e₁ ⇒ A → B[i] ⊣ Γ₂ 112 | Γ₂ ⊢ e₂ ⇐ A[i] ⊣ Γ₃ 113 | ————————————————————— 114 | Γ₁ ▷ e₁ e₂ ⇒ B[i] ◁ Γ₃ 115 | 116 | Γ ⊢ e₁ ⇒ α'[i] ⊣ Γ₁,α'=?,Γ₂ 117 | Γ₁,β'=?,γ'=?,α'=β'→γ',Γ₂ ⊢ e₂ ⇐ β'[i] ⊣ Γ' 118 | —————————————————————————————————————————— 119 | Γ ▷ e₁ e₂ ⇒ γ' ◁ Γ' 120 | 121 | 122 | Delay types 123 | 124 | Γ ⊢ e ⇐ A[i+1] ⊣ Γ' 125 | ———————————————————— 126 | Γ ▷ •e ⇐ •A[i] ⊣ Γ' 127 | 128 | 129 | Γ,β'=?,α'=•β',Γ' ⊢ e ⇐ A[i+1] ⊣ Γ'' 130 | ——————————————————————————————————— 131 | Γ,α'=?,Γ' ▷ •e ⇐ α'[i] ⊣ Γ'' 132 | 133 | 134 | Γ₁ ⊢ e₁ ⇒ •A[i] ⊣ Γ₂ 135 | Γ₂, ▪[x], x:A[i+1] ⊢ e₂ ⇔ D[i] ⊣ Γ₃, ▪[x], Γ' 136 | ————————————————————————————————————————————— 137 | Γ₁ ▷ let •x = e₁ in e₂ ⇔ D[i] ◁ Γ₃ 138 | 139 | 140 | Γ₁ ⊢ e₁ ⇒ α'[i] ⊣ Γ₂,α'=?,Γ₂' 141 | Γ₂, β'=?, α'=•α', Γ₂', ▪[x], x:A[i+1] ⊢ e₂ ⇔ D[i] ⊣ Γ₃, ▪[x], Γ' 142 | ———————————————————————————————————————————————————————————————— 143 | Γ₁ ▷ let •x = e₁ in e₂ ⇔ D[i] ◁ Γ₃ 144 | 145 | 146 | Stream types 147 | 148 | Γ₀ ⊢ e₀ ⇐ alloc ⊣ Γ₁ 149 | Γ₁ ⊢ e₁ ⇐ A[i] ⊣ Γ₂ 150 | Γ₂ ⊢ e₂ ⇐ S(A)[i+1] ⊣ Γ₃ 151 | ————————————————————————— 152 | Γ₀ ▷ cons(e₀,e₁,e₂) ⇐ S(A)[i] ◁ Γ₃ 153 | 154 | 155 | Γ₁ ⊢ e₁ ⇒ S(A)[i] ⊣ Γ₂ 156 | Γ₂, x:A[i], y:S(A)[i+1] ⊢ e₂ ⇔ D[i] ⊣ Γ₃, x:A[i], y:S(A)[i+1], Γ' 157 | ————————————————————————————————————————————————————————————————— 158 | Γ₁ ▷ let x :: y = e₁ in e₂ ⇔ D[i] ◁ Γ₃ 159 | 160 | 161 | Γ₁ ⊢ e₁ ⇒ α'[i] ⊣ Γ₂ 162 | Γ₂, β'=?, x:β'[i], y:S(β')[i+1] ⊢ e₂ ⇔ D[i] ⊣ Γ₃, x:β'[i], y:S(β')[i+1], Γ' 163 | ———————————————————————————————————————————————————————————————————————————————— 164 | Γ₁ ▷ let x :: y = e₁ in e₂ ⇔ D[i] ◁ Γ₃ 165 | 166 | 167 | Pure types 168 | 169 | Γ₀,Γ₁ = Purify(Γ) 170 | Γ₀ ⊢ e ⇐ A[i] ⊣ Γ₀' 171 | ————————————————————————————————— 172 | Γ ▷ !e ⇐ !A[i] ◁ Merge[Γ](Γ₀;Γ₁) 173 | 174 | 175 | Γ₀,β'=?, α'=!β',Γ₁ ⊢ !e ⇐ α' ⊣ Γ' 176 | ————————————————————————————————— 177 | Γ₀,α'=?,Γ₁ ▷ !e ⇐ α'[i] ◁ Γ' 178 | 179 | 180 | Γ₁ ⊢ e₁ ⇒ α' ⊣ Γ₂, α'=?, Γ₂' 181 | Γ₂, β'=?, α'=•β', Γ₂', u::β'[i] ⊢ e₂ ⇔ D[i] ⊣ Γ₃, u::β'[i], Γ₃' 182 | ——————————————————————————————————————————————————————————————— 183 | Γ₁ ▷ let !u = e₁ in e₂ ⇔ D[i] ◁ Γ₃ 184 | 185 | 186 | Recursive Types 187 | 188 | Γ, ▪[δ], K¹=?, ..., Kⁿ=?, δ:K¹ → ... → Kⁿ → ∗ = λα¹...αⁿ. μα.[C¹ A¹ | ... | Cⁿ Aⁿ] 189 | ⊢ e ⇐ D[i] ⊣ Γ', ▪[δ], Γ'' 190 | ———————————————————————————————————————————————————————————————————————————————————— 191 | Γ ▷ datatype δ α¹ ... αⁿ = μα.[C¹ A¹ | ... | Cⁿ Aⁿ] in e ⇐ D[i] ◁ Γ' 192 | 193 | 194 | Γ(δ) = λα¹...αⁿ. μδ.[C¹ A¹ | ... | Cⁿ Aⁿ] 195 | Γ ⊢ e ⇐ [A¹/α¹, ..., Aⁿ/αⁿ]Aʲ[i] ⊣ Γ' 196 | ———————————————————————————————————————— 197 | Γ ▷ Cʲ e ⇐ δ A¹ ... Aⁿ [i] ⊣ Γ' 198 | 199 | 200 | Γ(δ) = λα¹...αⁿ. μδ.[C¹ A¹ | ... | Cⁿ Aⁿ] 201 | Γ, α¹'=?, ..., αⁿ'=?, α' = δ α¹' ... αⁿ' ⊢ Cʲ ⇐ α'[i] ⊣ Γ' 202 | —————————————————————————————————————————————————————————— 203 | Γ, α'=?, Γ' ▷ Cʲ e ⇐ α' [i] ⊣ Γ' 204 | 205 | 206 | Γ⁰ ⊢ e ⇒ A[i] ⊣ Γ¹ 207 | 208 | Γ¹ ⊢ p¹ : A[i] ⊣ Γ¹' ↝ Θ¹ 209 | Γ¹', ▪[p¹], Θ¹ ⊢ e¹ ⇐ C[i] ⊣ Γ₂, ▪[p¹], Θ¹' 210 | ... 211 | Γⁿ ⊢ pⁿ : A[i] ⊣ Γⁿ' ↝ Θⁿ 212 | Γⁿ', ▪[pⁿ], Θⁿ ⊢ eⁿ ⇐ C[i] ⊣ Γⁿ⁺¹, ▪[pⁿ], Θⁿ' 213 | 214 | Γⁿ⁺¹ ⊢ p[1], ..., p[n] : A covers 215 | —————————————————————————————————————————————————————————— 216 | Γ⁰ ▷ case(e, p¹ → e¹ | ... | pⁿ → eⁿ) ⇐ C[i] ◁ Γⁿ⁺¹ 217 | 218 | 219 | Universal Types 220 | 221 | Γ, α ⊢ e ⇐ A[i] ⊣ Γ',α,Γ'' 222 | ——————————————————————————— 223 | Γ ▷ e ⇐ ∀α.A[i] ◁ Γ' 224 | 225 | 226 | Γ ⊢ e ⇒ ∀α.A[i] ⊣ Γ' 227 | ——————————————————————————————— 228 | Γ ▷ e ⇒ [α'/α]A[i] ◁ Γ', α'=? 229 | 230 | 231 | Existential Types 232 | 233 | 234 | Γ, α'=? ⊢ e ⇐ [α'/α]A[i] ⊣ Γ',α'=_,Γ'' 235 | ———————————————————————————————————————— 236 | Γ ▷ e ⇐ ∃α.A[i] ◁ Γ' 237 | 238 | 239 | Γ ⊢ e ⇒ ∃α.A[i] ⊣ Γ' 240 | ——————————————————————— 241 | Γ ▷ e ⇒ A[i] ◁ Γ', α 242 | 243 | 244 | GUI Types 245 | 246 | Γ;· ⊢ t ⇐ A ⊣ Γ'; · 247 | —————————————————————————— 248 | Γ ▷ G(t) ⇐ G(A)[i] ◁ Γ' 249 | 250 | 251 | Γ₀, β'=?, α'=G(β'),Γ₁; · ⊢ t ⇐ A[i] ⊣ Γ'; · 252 | ———————————————————————————————————————————— 253 | Γ₀,α'=?,Γ₁ ▷ G(t) ⇐ α'[i] ◁ Γ' 254 | 255 | 256 | 257 | Γ ⊢ e ⇒ G(A)[i] ⊣ Γ' 258 | —————————————————————————————— 259 | Γ;Δ ▷ run(e) ⇒ A[i] ◁ Γ';Δ 260 | 261 | 262 | Γ₁ ⊢ e ⇒ G(A)[i] ⊣ Γ₂, α'=?, Γ₂' 263 | ———————————————————————————————————————— 264 | Γ₁;Δ ▷ run(e) ⇒ A[i] ◁ Γ₂, α'=?, Γ₂';Δ 265 | 266 | 267 | Nonlinear Types 268 | 269 | Γ₁ ⊢ e ⇐ A[i] ⊣ Γ₂ 270 | ———————————————————————————————— 271 | Γ₁;Δ ▷ F(e) ⇐ F(A)[i] ◁ Γ₂; Δ 272 | 273 | 274 | Γ₁, β'=?, α'=?, Γ₁' ⊢ e ⇐ β'[i] ⊣ Γ₂ 275 | ————————————————————————————————————————— 276 | Γ₁, α'=?, Γ₁';Δ ▷ F(e) ⇐ α'[i] ◁ Γ₂; Δ 277 | 278 | 279 | 280 | Γ₁; Δ₁ ⊢ e₁ ⇒ F(A) ⊣ Γ₂;Δ₂ 281 | Γ₂, x:A[i]; Δ₂ ⊢ e₂ ⇔ C ⊣ Γ₃, x:A[i], Γ₃'; Δ₃ 282 | —————————————————————————————————————————————— 283 | Γ₁; Δ₁ ▷ let F(x) = e₁ in e₂ ⇔ C ◁ Γ₃; Δ₃ 284 | 285 | 286 | Γ₁; Δ₁ ⊢ e₁ ⇒ α'[i] ⊣ Γ₂, α'=?, Γ₂';Δ₂ 287 | Γ₂, β'=?, α'=F(α'), Γ₂', x:A[i]; Δ₂ ⊢ e₂ ⇔ D[i] ⊣ Γ₃, x:A[i], Γ₃'; Δ₃ 288 | ————————————————————————————————————————————————————————————————————— 289 | Γ₁; Δ₁ ▷ let F(x) = e₁ in e₂ ⇔ D[i] ◁ Γ₃; Δ₃ 290 | 291 | 292 | Linear Function Types 293 | 294 | 295 | Γ₁; Δ₁, ▪[x], x:A[i] ⊢ e ⇐ B[i] ⊣ Γ₂; Δ₂, ▪[x], · 296 | ——————————————————————————————————————————————————— 297 | Γ₁; Δ₁ ▷ λx.e ⇐ A ⊸ B[i] ◁ Γ₂; Δ₂ 298 | 299 | 300 | Γ₁, α'=?, Γ₁'; Δ₁, ▪[x], x:A[i] ⊢ e ⇐ B[i] ⊣ Γ₂; Δ₂, ▪[x], · 301 | ————————————————————————————————————————————————————————————— 302 | Γ₁, α'=?, Γ₁'; Δ₁ ▷ λx.e ⇐ A ⊸ B[i] ◁ Γ₂; Δ₂ 303 | 304 | 305 | Γ₁; Δ₁ ⊢ e₁ ⇒ A ⊸ B[i] ⊣ Γ₂; Δ₂ 306 | Γ₂; Δ₂ ⊢ e₂ ⇐ A[i] ⊣ Γ₃; Δ₃ 307 | ———————————————————————————————— 308 | Γ₁; Δ₁ ▷ e₁ e₂ ⇒ B[i] ◁ Γ₃; Δ₃ 309 | 310 | 311 | Γ₁; Δ₁ ⊢ e₁ ⇒ α'[i] ⊣ Γ₂, α'=?, Γ₂'; Δ₂ 312 | Γ₂, β'=?, γ'=?, α'=β'⊸γ', Γ₂'; Δ₂ ⊢ e₂ ⇐ A[i] ⊣ Γ₃; Δ₃ 313 | —————————————————————————————————————————————————————— 314 | Γ₁; Δ₁ ▷ e₁ e₂ ⇒ B[i] ◁ Γ₃; Δ₃ 315 | 316 | 317 | Linear let-binders 318 | 319 | ——————————————————————————————————————————— 320 | Γ₁; Δ₁, x:A[i], Δ₁' ▷ x:A[i] ◁ Γ₁; Δ₁, Δ₁' 321 | 322 | 323 | Γ₁; Δ₁ ⊢ e₁ ⇒ A[i+k] ⊣ Γ₂; Δ₂ 324 | Γ₂; Δ₂, ▪[x], x:A[i+k] ⊢ e₂ ⇔ D[i] ⊣ Γ₃; Δ₃, ▪[x], · 325 | ————————————————————————————————————————————————————— 326 | Γ₁; Δ₁ ▷ let[k] x = e₁ in e₂ ⇔ D[i] ◁ Γ₃; Δ₃ 327 | 328 | 329 | Γ₁ ⊢ e ⇒ A[i] ⊣ Γ₂ 330 | Γ₂, ▪[x], x:A[i]; Δ₁ ⊢ e' ⇔ D[i] ⊣ Γ₃, ▪[x], Γ₃'; Δ₂ 331 | ————————————————————————————————————————————————————— 332 | Γ₁;Δ₁ ▷ let int x = e in e ⇔ D[i] ◁ Γ₃; Δ₂ 333 | 334 | 335 | Linear Conditionals 336 | 337 | 338 | Γ₁ ⊢ e ⇒ bool[i] ⊣ Γ₂ 339 | Γ₂; Δ₁ ⊢ e₂ ⇐ D[i] ⊣ Γ₃; Δ₂ 340 | Γ₃; Δ₁ ⊢ e₃ ⇐ D[i] ⊣ Γ₄; Δ₂ 341 | ——————————————————————————————————————— 342 | Γ₁; Δ₁ ▷ if(e, e₂, e₃) ⇐ D[i] ◁ Γ₄; Δ₂ 343 | 344 | 345 | 346 | Datatypes and Pattern Matching 347 | 348 | Add Γ ::= ... | α={C[1] τ[1] | … | C[n] τ[n]} 349 | 350 | Intuitionistic patterns 351 | 352 | p ::= x | •x | !x | p :: xs | (p[1], …, p[n]) | C p 353 | 354 | 355 | The rule for pattern matching: 356 | 357 | Γ⁰ ⊢ e ⇒ A ⊣ Γ¹ 358 | Γ ⊢ p[1], ..., p[n] : A covers 359 | Γ¹ ⊢ p¹ : A[i] ⊧ Γ[1] Γ¹, ▪[p¹], Γ[1] ⊢ e¹ ⇐ D[i] ⊣ Γ², ▪[p¹], Γ[1]' 360 | ... 361 | Γⁿ ⊢ pⁿ : A[i] ⊧ Γ[n] Γⁿ, ▪[pⁿ], Γ[n] ⊢ eⁿ ⇐ D[i] ⊣ Γⁿ⁺¹, ▪[pⁿ], Γ[n+1]' 362 | ———————————————————————————————————————————————————————————————————————————— 363 | Γ₀ ▷ case e of { p¹ → e¹ | ... | pⁿ → eⁿ } ⇐ D[i] ◁ Γⁿ⁺¹ 364 | 365 | 366 | The variable generation judgement: 367 | 368 | Γ ⊢ p : A ⊣ Γ' ↝ Θ 369 | 370 | ——————————————————————————— 371 | Γ ⊢ x : A[i] ⊣ Γ' ↝ x:A[i] 372 | 373 | 374 | Γ, ▪[p], α'=? ⊢ p : [α'/α]A[i] ⊣ Γ', ▪[p], Γ'' ↝ Θ 375 | ————————————————————————————————————————————————————— 376 | Γ ⊢ p : ∀α.A[i] ⊣ Γ' ↝ Γ'', Θ 377 | 378 | 379 | Γ, ▪[p], α ⊢ p : A[i] ⊣ Γ', ▪[p], Γ'' ↝ Θ 380 | ————————————————————————————————————————————— 381 | Γ ⊢ p : ∃α.A[i] ⊣ Γ' ↝ Γ'', Θ 382 | 383 | 384 | 385 | ——————————————————————————————— 386 | Γ ⊢ •x : •A[i] ⊣ Γ' ↝ x:A[i+1] 387 | 388 | 389 | —————————————————————————————————————————————————————————— 390 | Γ₀,α'=?,Γ₁ ⊢ •x : α'[i] ⊣ Γ₀, β'=?, α'=•β', Γ₁ ↝ x:α'[i+1] 391 | 392 | 393 | ————————————————————————— 394 | Γ ⊢ !x : !A[i] ↝ x::A[i] 395 | 396 | 397 | ————————————————————————————————————————————————————————— 398 | Γ₀,α'=?,Γ₁ ⊢ !x : α'[i] ⊣ Γ₀, β'=?, α'=!β', Γ₁ ↝ x::α'[i] 399 | 400 | 401 | Γ ⊢ p : A[i] ⊣ Γ' ↝ Θ 402 | ————————————————————————————————————————————— 403 | Γ ⊢ p :: xs : S(A)[i] ⊣ Γ' ↝ Θ, xs:S(A)[i+1] 404 | 405 | 406 | Γ₀, β'=?, α'=S(β'), Γ₁ ⊢ p : β'[i] ⊣ Γ' ↝ Θ 407 | —————————————————————————————————————————————————— 408 | Γ₀,α'=?,Γ₁ ⊢ p :: xs : α'[i] ⊣ Γ' ↝ Θ, xs:α'[i+1] 409 | 410 | 411 | Γ¹ ⊢ p¹ : A¹ ⊣ Γ² ↝ Θ¹ 412 | ... 413 | Γⁿ ⊢ pⁿ : Aⁿ ⊣ Γⁿ⁺¹ ↝ Θⁿ 414 | ————————————————————————————————————————————————————— 415 | Γ¹ ⊢ (p¹, ..., pⁿ) : A¹ × ... × Aⁿ ⊣ Γⁿ⁺¹ ↝ Θ¹, …, Θⁿ 416 | 417 | 418 | Γ ⊢ p : [μα.A[α]/α]A ⊣ Γ' ↝ Θ 419 | ——————————————————————————————— 420 | Γ ⊢ C p : δ α₁ ...αᵢ ⊣ Γ' ↝ Θ 421 | 422 | 423 | Linear patterns 424 | 425 | 426 | Γ ⊢ p : A[i] ↝ Γ'; Θ; Δ 427 | 428 | 429 | Γ ⊢ p : A[0] ↝ Γ'; Θ 430 | ——————————————————————————— 431 | Γ ⊢ F p : F A[0] ↝ Γ; Θ; · 432 | 433 | 434 | Γ₁, β'=?, α'=F(β), Γ₂ ⊢ p : β' ⊢ Γ'; Θ 435 | —————————————————————————————————————— 436 | Γ₁, α'=?, Γ₂ ⊢ F p : α'[0] ↝ Γ'; Θ; · 437 | 438 | 439 | Γ₁ ⊢ p₁ : A₁[i] ↝ Γ₂; Θ₁; Δ₁ 440 | ... 441 | Γⱼ ⊢ pⱼ : Aⱼ[i] ↝ Γⱼ₊₁; Θⱼ₊₁; Δⱼ₊₁ 442 | ——————————————————————————————————————————————————————————————————— 443 | Γ₁ ⊢ (p₁, ..., pⱼ) : A₁ ⊗ ... ⊗ Aⱼ [i] ↝ Γⱼ₊₁; Θ₁,...,Θⱼ₊₁; Δ₁,...,Δⱼ₊₁ 444 | 445 | 446 | Γ₁,β'₁=?,...,β'ⱼ=?,α'=β'₁⊗...⊗β'ⱼ,Γ₁' ⊢ p₁ : β'₁[i] ↝ Γ₂; Θ₁; Δ₁ 447 | ... 448 | Γⱼ ⊢ pⱼ : β'ⱼ[i] ↝ Γⱼ₊₁; Θⱼ₊₁; Δⱼ₊₁ 449 | ——————————————————————————————————————————————————————————————————— 450 | Γ₁,α'=?,Γ₁' ⊢ (p₁, ..., pⱼ) : α' [i] ↝ Γⱼ₊₁; Θ₁,...,Θⱼ₊₁; Δ₁,...,Δⱼ₊₁ 451 | 452 | 453 | Γ ⊢ p : A[i+1] ↝ Γ'; ·; Θ 454 | ——————————————————————————— 455 | Γ ⊢ •p : •A[i] ↝ Γ';·;Θ 456 | 457 | 458 | Γ₁,β'=?, α'=•β', Γ₁' ⊢ p : A[i+1] ↝ Γ'; ·; Θ 459 | ————————————————————————————————————————————— 460 | Γ₁,α=?,Γ₁' ⊢ •p : •A[i] ↝ Γ';·;Θ 461 | 462 | 463 | 464 | —————————————————————————— 465 | Γ ⊢ x : A[i] ↝ Γ;·;x:A[i] 466 | 467 | 468 | Coverage checking 469 | 470 | Γ ⊢ p¹, ..., pⁿ : A fail 471 | 472 | —————————————— 473 | Γ ⊢ · : A fail 474 | 475 | 476 | ∃j ∈ 1..n Γ ⊢ pʲ, ... q^q : Aʲ fail 477 | ————————————————————————————————————————————————————————– 478 | Γ ⊢ (p¹, ..., pⁿ), ... (q¹, ..., qⁿ) : A¹ × ... × Aⁿ fail 479 | 480 | 481 | ⊥ 482 | —————————————————————— 483 | Γ ⊢ x, ... p : A fail 484 | 485 | 486 | ⊥ 487 | ———————————————————————— 488 | Γ ⊢ •x, ... p : •A fail 489 | 490 | 491 | ⊥ 492 | ———————————————————————— 493 | Γ ⊢ !x, ... p : !A fail 494 | 495 | 496 | Γ ⊢ p, ..., q : A fail 497 | ———————————————————————————————————————— 498 | Γ ⊢ (p :: xs), ... (q :: ys) : S(A) fail 499 | 500 | 501 | Γ(α) = λα¹...αʲ. μδ. [C¹ B¹ | ... | Cⁿ Bⁿ] 502 | ∃l ∈ 1..n. Γ ⊢ pˡ, ..., qˡ : [A¹/α¹, ..., Aʲ/αʲ]Bˡ 503 | ——————————————————————————————————————————————————————————— 504 | Γ ⊢ C¹ p¹, ... C¹ q¹, ..., Cⁿ pⁿ, ... Cⁿ qⁿ : α A¹ .. Aʲ fail 505 | -------------------------------------------------------------------------------- /unittest.ml: -------------------------------------------------------------------------------- 1 | type result = Success | Failure of string | Crash of exn 2 | 3 | type t = string * t' 4 | and t' = 5 | | Test of (unit -> result) 6 | | List of t list 7 | 8 | let fulltest name thunk = (name, Test (fun () -> try thunk() with e -> Crash e)) 9 | 10 | let test name thunk = 11 | let testcase () = 12 | try 13 | if thunk() then Success else Failure "" 14 | with 15 | e -> Crash e 16 | in 17 | (name, Test testcase) 18 | 19 | let crashtest name body handler = 20 | (name, Test(fun () -> 21 | try 22 | let _ = body() in Failure "" 23 | with 24 | e -> if handler e then Success else Failure "")) 25 | 26 | let group name ts = (name, List ts) 27 | 28 | let result out = function 29 | | Success -> Format.fprintf out "passed" 30 | | Failure msg -> Format.fprintf out "FAILED: %s" msg 31 | | Crash e -> Format.fprintf out "CRASH: %s" (Printexc.to_string e) 32 | 33 | let rec space out n = if n <= 0 then () else (Format.fprintf out " "; space out (n-1)) 34 | 35 | let run out t = 36 | let print fmt = Format.fprintf out fmt in 37 | let rec loop n (name, t) = 38 | let () = space out n in 39 | let () = print "%s: " name in 40 | match t with 41 | | List ts -> print "\n"; List.iter (loop (n+2)) ts 42 | | Test t -> (result out (t())); print "\n" 43 | in 44 | loop 0 t 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /unittest.mli: -------------------------------------------------------------------------------- 1 | type result = Success | Failure of string | Crash of exn 2 | type t 3 | 4 | val test : string -> (unit -> bool) -> t 5 | val fulltest : string -> (unit -> result) -> t 6 | val crashtest : string -> (unit -> 'a) -> (exn -> bool) -> t 7 | val group : string -> t list -> t 8 | 9 | val run : Format.formatter -> t -> unit 10 | --------------------------------------------------------------------------------