├── .gitignore ├── Makefile ├── Readme.md ├── dune ├── dune-project ├── lang ├── affe │ ├── affe.ml │ ├── affe_lang.ml │ ├── affe_www.ml │ ├── builtin.ml │ ├── constraint.ml │ ├── dune │ ├── env.ml │ ├── eval.ml │ ├── examples │ │ ├── array.affe │ │ ├── array.affe.expected │ │ ├── basics.affe │ │ ├── basics.affe.expected │ │ ├── channel.affe │ │ ├── channel.affe.expected │ │ ├── constructors.affe │ │ ├── constructors.affe.expected │ │ ├── container.affe.expected │ │ ├── cow.affe │ │ ├── cow.affe.expected │ │ ├── dune │ │ ├── example.affe │ │ ├── example.affe.expected │ │ ├── fail.affe │ │ ├── fail.affe.expected │ │ ├── nonlexical.affe │ │ ├── nonlexical.affe.expected │ │ ├── patmatch.affe │ │ ├── patmatch.affe.expected │ │ ├── pool.affe │ │ ├── pool.affe.expected │ │ ├── region.affe │ │ ├── region.affe.expected │ │ ├── sessions.affe │ │ ├── sessions.affe.expected │ │ ├── sudoku.affe │ │ ├── sudoku.affe.expected │ │ ├── test_un.affe │ │ └── test_un.affe.expected │ ├── instantiate.ml │ ├── instantiate.mli │ ├── kinds.ml │ ├── lattice_solver.ml │ ├── lexer.mll │ ├── multiplicity.ml │ ├── name.ml │ ├── parser.mly │ ├── printer.ml │ ├── region.ml │ ├── syntax.ml │ ├── transl.ml │ ├── types.ml │ ├── typing.ml │ └── variance.ml └── hm │ ├── README.markdown │ ├── dune │ ├── eval.ml │ ├── example.hm │ ├── hm.ml │ ├── lexer.mll │ ├── parser.mly │ ├── printer.ml │ ├── syntax.ml │ ├── type.ml │ └── typing.ml ├── www ├── addon │ ├── lint │ │ ├── lint.css │ │ └── lint.js │ ├── mode │ │ └── simple.js │ └── scroll │ │ ├── simplescrollbars.css │ │ └── simplescrollbars.js ├── examples │ ├── channel.affe │ ├── intro.affe │ ├── sessions.affe │ └── sudoku.affe ├── index.html ├── lib │ ├── codemirror.css │ └── codemirror.js ├── mode │ └── affe │ │ └── affe.js ├── script.js ├── style.css └── theme │ └── solarized.css └── zoo ├── dune ├── native ├── dune └── zoo.ml ├── web ├── dune ├── zoo.ml └── zoo_web.ml └── zoo.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.bc.js 4 | .gh-pages 5 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | NAME=pl-experiments 2 | DOCDIR=.gh-pages 3 | 4 | all: 5 | dune build lang/affe/affe.exe 6 | 7 | test: 8 | dune runtest 9 | 10 | clean: 11 | dune clean 12 | 13 | web: 14 | dune build lang/affe/affe_www.bc.js 15 | @cp _build/default/lang/affe/affe_www.bc.js www 16 | 17 | $(DOCDIR)/.git: 18 | mkdir -p $(DOCDIR) 19 | cd $(DOCDIR) && (\ 20 | git clone -b gh-pages git@github.com:Drup/$(NAME).git . \ 21 | ) 22 | 23 | gh-pages: $(DOCDIR)/.git web 24 | git -C $(DOCDIR) pull 25 | cp -r www/* $(DOCDIR)/affe/ 26 | git -C $(DOCDIR) add --all 27 | git -C $(DOCDIR) commit -a -m "gh-page updates" 28 | git -C $(DOCDIR) push origin gh-pages 29 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # My PL experiments 2 | 3 | A collection of personal PL research and experiments. 4 | For a more stable and pedagogic collection, please consult the [plzoo](http://andrej.com/plzoo/). 5 | 6 | ## The languages 7 | 8 | ### [Affe](lang/affe/) --- [**Try the online demo here!**](https://drup.github.io/pl-experiments/affe/) 9 | 10 | An ML language with affine/linear type system, kinds and a borrow system. 11 | Only the type system is implemented. 12 | 13 | ### [HM](lang/hm) 14 | 15 | An ML-like language with side-effects. 16 | Implemented by a run-of-the-mill hindley-milner in the style of HM(X) 17 | with a big-step evaluator. 18 | 19 | ## How to use 20 | 21 | `dune exec lang//.exe` to launch the toplevel for `` 22 | 23 | `dune runtest lang/` to run the tests for ``. 24 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name default) 3 | (deps (alias_rec all))) -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.2) 2 | (using menhir 2.0) 3 | (allow_approximate_merlin) -------------------------------------------------------------------------------- /lang/affe/affe.ml: -------------------------------------------------------------------------------- 1 | let () = Affe_lang.main () 2 | -------------------------------------------------------------------------------- /lang/affe/affe_lang.ml: -------------------------------------------------------------------------------- 1 | include Zoo.Main (struct 2 | 3 | let name = "Affe" 4 | 5 | type command = Syntax.command 6 | 7 | let options = [] 8 | 9 | type environment = { 10 | ty : Env.t ; 11 | name: Syntax.Rename.env ; 12 | (* value: Eval.env ; *) 13 | } 14 | let add_def x ty _v env = { 15 | ty = Env.add x ty env.ty ; 16 | name = { env.name with env = Syntax.Rename.add x.name x env.name.env } ; 17 | (* value = Eval.add x v env.value ; *) 18 | } 19 | let add_decl ty schm env = { 20 | ty = Env.add_constr ty schm env.ty ; 21 | name = { env.name with tyenv = Syntax.Rename.add ty.name ty env.name.tyenv } ; 22 | (* value = env.value ; *) 23 | } 24 | let initial_environment = { 25 | ty = Builtin.initial_env; 26 | name = Builtin.initial_rename_env; 27 | (* value = Eval.initial_env ; *) 28 | } 29 | 30 | let read_more str = 31 | let i = ref (String.length str - 1) in 32 | while !i >= 0 && List.mem str.[!i] [' '; '\n'; '\t'; '\r'] do decr i done ; 33 | !i < 1 || (str.[!i] <> ';' || str.[!i - 1] <> ';') 34 | 35 | let file_parser = Some (Parser.file Lexer.token) 36 | let toplevel_parser = Some (Parser.toplevel Lexer.token) 37 | 38 | let harness f = 39 | let env = Printer.create_naming_env () in 40 | try f () with 41 | | Constraint.TypeLeq.Fail (ty1, ty2) -> 42 | Zoo.error ~kind:"Type error" 43 | "@[<2>Cannot unify types@ %a@]@ @[<2>and@ %a@]@." 44 | (Printer.typ env) ty1 (Printer.typ env) ty2 45 | | Constraint.KindUnif.Fail (k1, k2) -> 46 | Zoo.error ~kind:"Kind error" 47 | "@[<2>Cannot unify kinds@ %a@]@ @[<2>and@ %a@]@." 48 | (Printer.kind env) k1 (Printer.kind env) k2 49 | | Multiplicity.Fail (name, u1, u2) -> 50 | Zoo.error ~kind:"Use error" 51 | "Variable %a used as %a and %a. This uses are incompatible." 52 | Printer.name name (Printer.use env) u1 (Printer.use env) u2 53 | | Env.Type_not_found name -> 54 | Zoo.error "Unknwon type %a" Printer.name name 55 | | Env.Var_not_found name -> 56 | Zoo.error "Unknwon variable %a" Printer.name name 57 | 58 | let exec import env c = 59 | let c = Syntax.Rename.command env.name c in 60 | let c = Region.annotate_command c in 61 | match c with 62 | | Syntax.ValueDecl {rec_flag ; name ; expr} -> 63 | if !Printer.debug then 64 | Zoo.print_info "@[<2>%a =@ @[%a@]@]@." 65 | Printer.name name Printer.expr expr 66 | ; 67 | let _constr, typ_env, scheme = 68 | harness @@ fun () -> 69 | Typing.infer_top env.ty rec_flag name expr 70 | in 71 | let v = () in 72 | (* let v = Eval.execute env.value expr in *) 73 | let env = { env with ty = typ_env } in 74 | Zoo.print_info "@[<2>%a :@ %a@]@.@." 75 | Printer.name name Printer.scheme scheme 76 | (* Printer.value v *) 77 | (* Printer.constrs constr *) 78 | (* Printer.env env.ty *) 79 | ; 80 | add_def name scheme v env 81 | | Syntax.ValueDef {name ; typ} -> 82 | let _typ_env, scheme = 83 | harness @@ fun () -> 84 | Transl.transl_type_scheme ~env:env.ty typ 85 | in 86 | Zoo.print_info "@[<2>%a :@ @[%a@]@]@." 87 | Printer.name name Printer.scheme scheme 88 | ; 89 | let v = Syntax.Primitive (CCOpt.get_exn name.name) in 90 | add_def name scheme v env 91 | | Syntax.TypeDecl decl -> 92 | let ty_name, ty_decl, constrs = 93 | harness @@ fun () -> 94 | Transl.transl_decl ~env:env.ty decl 95 | in 96 | (* let env = { env with ty = typ_env } in *) 97 | Zoo.print_info "@[<2>type %a@ = %a@]@." 98 | Printer.name ty_name 99 | Printer.kscheme ty_decl ; 100 | let env = add_decl ty_name ty_decl env in 101 | let f env (name, decl) = 102 | Zoo.print_info "@[<2>constructor %a :@ %a@]@." 103 | Printer.name name 104 | Printer.scheme decl ; 105 | add_def name decl (Syntax.Constructor name) env 106 | in 107 | List.fold_left f env constrs 108 | | Import s -> 109 | import env s 110 | end) 111 | -------------------------------------------------------------------------------- /lang/affe/affe_www.ml: -------------------------------------------------------------------------------- 1 | let doc = 2 | let open Js_of_ocaml_tyxml.Tyxml_js in 3 | [%html{| 4 |

5 | Welcome to the online demo of the Affe language! 6 |

7 |

8 | This language aims to prevent linearity violations, notably bugs such as 9 | use-after-free. Affe is an ML-like language similar to OCaml. 10 | In particular, Affe is functional with arbitrary side effects and 11 | complete type inference (i.e., users never need to write type annotations). 12 |

13 | 17 |

18 | You can find a list of examples below. Only typing is implemented is this 19 | online demo. The result of the typing (or the appropriate type error) is displayed 20 | in the bottom right. Beware, this is a prototype: error messages 21 | (and the UI in general) are research-quality. 22 |

23 |

24 | Have fun! 25 |

26 | |}] 27 | 28 | 29 | 30 | let l = [ 31 | "intro.affe"; 32 | "channel.affe"; 33 | "sessions.affe"; 34 | "sudoku.affe"; 35 | ] 36 | 37 | let () = 38 | Js_of_ocaml_tyxml.Tyxml_js.Register.id "content" doc; 39 | Printer.debug := false ; 40 | Affe_lang.load_files l ; 41 | Affe_lang.main () 42 | -------------------------------------------------------------------------------- /lang/affe/builtin.ml: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | let (@->) x y = Arrow (x,Kinds.un Global,y) 4 | let new_y () = 5 | let y_name = Name.create ~name:"a" () in 6 | let n = GenericVar y_name in 7 | (n @-> n) @-> n 8 | 9 | let int_name = Name.create ~name:"int" () 10 | let int = App (int_name, []) 11 | let int_kind = kscheme @@ Kinds.un Global 12 | 13 | let array_name = Name.create ~name:"array" () 14 | let array x = App (array_name, [x]) 15 | let array_kind = 16 | let name, k = gen_kind_var () in 17 | kscheme ~kvars:[name] ~args:[k] @@ Kinds.aff Global 18 | 19 | let unit_name = Name.create ~name:"unit" () 20 | let unit_ty = App (unit_name, []) 21 | let unit_kind = kscheme @@ Kinds.un Global 22 | let unit_constr_name = Name.create ~name:"()" () 23 | let unit = Syntax.Constructor unit_constr_name 24 | 25 | let bool_name = Name.create ~name:"bool" () 26 | let bool = App (bool_name, []) 27 | let bool_kind = kscheme @@ Kinds.un Global 28 | let true_constr_name = Name.create ~name:"True" () 29 | let true_val = Syntax.Constructor true_constr_name 30 | let false_constr_name = Name.create ~name:"False" () 31 | let false_val = Syntax.Constructor false_constr_name 32 | 33 | let initial_env = 34 | Env.empty 35 | |> Env.add_constr array_name array_kind 36 | |> Env.add_constr int_name int_kind 37 | |> Env.add_constr unit_name unit_kind 38 | |> Env.add_constr bool_name bool_kind 39 | |> Env.add unit_constr_name (tyscheme unit_ty) 40 | |> Env.add true_constr_name (tyscheme bool) 41 | |> Env.add false_constr_name (tyscheme bool) 42 | 43 | module PrimMap = CCMap.Make(String) 44 | let primitives = 45 | let open PrimMap in 46 | (* let un = Un Global in *) 47 | empty 48 | |> add "+" @@ tyscheme (int @-> int @-> int) 49 | |> add "-" @@ tyscheme (int @-> int @-> int) 50 | |> add "*" @@ tyscheme (int @-> int @-> int) 51 | |> add "/" @@ tyscheme (int @-> int @-> int) 52 | |> add "<" @@ tyscheme (int @-> int @-> bool) 53 | |> add ">" @@ tyscheme (int @-> int @-> bool) 54 | |> add "=" @@ tyscheme (int @-> int @-> bool) 55 | (* |> add "init" ( 56 | * let name, a = Types.gen_var () in 57 | * tyscheme ~tyvars:[name, un] 58 | * (int @-> (int @-> a) @-> array a) 59 | * ) 60 | * |> add "free" ( 61 | * let name, a = Types.gen_var () in 62 | * tyscheme ~tyvars:[name, un] (array a @-> unit_ty) 63 | * ) 64 | * |> add "length"( 65 | * let name, a = Types.gen_var () in 66 | * let kname, k = Types.gen_kind_var () in 67 | * let kname_borrow, k_borrow = Types.gen_kind_var () in 68 | * tyscheme 69 | * ~kvars:[kname; kname_borrow] 70 | * ~tyvars:[name, k] 71 | * ~constr:[(k, Un Never)] 72 | * (Borrow (Read, k_borrow, array a) @-> int) 73 | * ) 74 | * |> add "get"( 75 | * let name, a = Types.gen_var () in 76 | * let kname, k = Types.gen_kind_var () in 77 | * let kname_borrow, k_borrow = Types.gen_kind_var () in 78 | * tyscheme 79 | * ~kvars:[kname; kname_borrow] 80 | * ~tyvars:[name, k] 81 | * ~constr:[(k, Un Never)] 82 | * (Tuple [Borrow (Read, k_borrow, array a); int] @-> a ) 83 | * ) 84 | * |> add "set" ( 85 | * let name, a = Types.gen_var () in 86 | * let kname, k = Types.gen_kind_var () in 87 | * let kname_borrow, k_borrow = Types.gen_kind_var () in 88 | * tyscheme 89 | * ~kvars:[kname; kname_borrow] 90 | * ~tyvars:[name, k] 91 | * ~constr:[(k, Aff Never)] 92 | * (Tuple [Borrow (Write, k_borrow, array a); int; a] @-> unit_ty) 93 | * ) *) 94 | 95 | let initial_rename_env = Syntax.Rename.{ 96 | env = SMap.( 97 | empty 98 | |> add "()" unit_constr_name 99 | |> add "True" true_constr_name 100 | |> add "False" false_constr_name 101 | ); 102 | tyenv = SMap.( 103 | empty 104 | |> add "unit" unit_name 105 | |> add "int" int_name 106 | |> add "array" array_name 107 | |> add "bool" bool_name 108 | ); 109 | } 110 | -------------------------------------------------------------------------------- /lang/affe/dune: -------------------------------------------------------------------------------- 1 | (ocamllex lexer) 2 | (menhir 3 | (modules parser) 4 | (flags --explain --strict) 5 | ) 6 | 7 | (library 8 | (name affe) 9 | (libraries ocamlgraph iter zoo) 10 | (modules :standard \ Affe Affe_www Eval) 11 | (preprocess (pps ppx_deriving.std)) 12 | (wrapped false) 13 | ) 14 | 15 | (executable 16 | (name affe) 17 | (modules Affe) 18 | (libraries affe zoo_native) 19 | ) 20 | (executable 21 | (name affe_www) 22 | (modules Affe_www) 23 | (libraries affe zoo_web) 24 | (preprocess (pps tyxml-ppx)) 25 | (js_of_ocaml) 26 | ) 27 | -------------------------------------------------------------------------------- /lang/affe/env.ml: -------------------------------------------------------------------------------- 1 | 2 | exception Var_not_found of Name.t 3 | exception Type_not_found of Name.t 4 | 5 | type ('a, 'b) env = { 6 | vars : 'a Name.Map.t ; 7 | constr : 'b Name.Map.t ; 8 | } 9 | type t = (Types.scheme, Types.kscheme) env 10 | 11 | let add k v env = { env with vars = Name.Map.add k v env.vars } 12 | let add_constr k v env = { env with constr = Name.Map.add k v env.constr } 13 | 14 | let find k env = 15 | try Name.Map.find k env.vars with 16 | Not_found -> raise (Var_not_found k) 17 | let find_constr k env = 18 | try Name.Map.find k env.constr with 19 | Not_found -> raise (Type_not_found k) 20 | 21 | let rm k env = { env with vars = Name.Map.remove k env.vars } 22 | 23 | let empty = { 24 | vars = Name.Map.empty ; 25 | constr = Name.Map.empty ; 26 | } 27 | 28 | -------------------------------------------------------------------------------- /lang/affe/eval.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | type address = Name.t 4 | type value = 5 | | Array of value array 6 | | Constant of constant 7 | | Closure of env * Name.t * expr 8 | | Address of address 9 | | Constructor of Name.t * value list 10 | | Borrow of borrow * address 11 | and env = value Name.Map.t 12 | 13 | (** Global Environment *) 14 | 15 | let initial_env = Name.Map.empty 16 | let add = Name.Map.add 17 | let find x env = 18 | if Name.Map.mem x env then 19 | Name.Map.find x env 20 | else 21 | Zoo.error "Unbound variable %a" Printer.name x 22 | 23 | (** Substitutions *) 24 | 25 | let rec subst_value x v = function 26 | | Constructor c -> Constructor c 27 | | Constructor (c, Some v') -> Constructor (c, Some (subst_value x v v')) 28 | | Constant c -> Constant c 29 | | Lambda (y,e) when not @@ Name.equal x y -> 30 | (Lambda (y, subst x v e)) 31 | | Lambda (_, _) 32 | | Array _ 33 | | Unit 34 | as v -> v 35 | 36 | (** e[x -> v] *) 37 | and subst x v e = match e with 38 | | Var y when Name.equal x y -> V v 39 | | Var n -> Var n 40 | | V v' -> V (subst_value x v v') 41 | | App (f,e) -> App (subst x v f, List.map (subst x v) e) 42 | | Let (y,e1,e2) when not @@ Name.equal x y -> 43 | Let (y, subst x v e1, subst x v e2) 44 | | Match (constr, y,e1,e2) when not @@ Name.equal x y -> 45 | Match (constr, y, subst x v e1, subst x v e2) 46 | | Let (y,e1,e2) -> 47 | Let (y, subst x v e1, e2) 48 | | Match (constr, y, e1, e2) -> 49 | Match (constr, y, subst x v e1, e2) 50 | | Borrow (r, e) -> Borrow (r, subst x v e) 51 | 52 | let subst_env = Name.Map.fold subst 53 | 54 | (** Evaluation *) 55 | 56 | let value x = V x 57 | let lambda n b = V (Lambda (n, b)) 58 | let const x = V (Constant x) 59 | let delta c v = match c,v with 60 | | Int _, [] -> None 61 | 62 | | Plus, [ Constant (Int i) ; Constant (Int j) ] -> 63 | Some (V (Constant (Int (i + j)))) 64 | | Plus, [ Constant (Int i) ] -> 65 | let n = Name.create ~name:"i" () in 66 | Some (V (Lambda (n, App (const Plus, [const @@ Int i; Var n])))) 67 | 68 | (* | Alloc, [ Constant (Int i) ; v ] -> Some (V (Array (Array.make i v))) *) 69 | | Get, [ Array r ; Constant (Int i) ] -> Some (V r.(i)) 70 | (* | Set, [ Array r ] -> 71 | * let n = Name.create ~name:"r" () in 72 | * Some (V (Lambda (n, App (const Set, [V (Ref r); Var n])))) *) 73 | | Set, [ Array r ; Constant (Int i) ; v ] -> r.(i) <- v ; Some (V Unit) 74 | 75 | | Y, ve::t -> 76 | let n = Name.create ~name:"Y" () in 77 | let args = List.map value t in 78 | Some (App (V ve, lambda n (App(const Y, [V ve; Var n])) :: args)) 79 | 80 | | _ -> None 81 | 82 | exception Not_reducible : expr -> exn 83 | 84 | let log_eval i = Format.printf "%s< %a@." (String.make i ' ') Printer.expr 85 | let log_val i = Format.printf "%s> %a@." (String.make i ' ') Printer.value 86 | 87 | let reduction_failure e = 88 | Zoo.error ~kind:"Execution error" 89 | "The following expression can not be reduced:@.%a" Printer.expr e 90 | 91 | let rec eval i e = match e with 92 | | V v -> v 93 | | Borrow (_,e) -> eval i e 94 | | Var _ -> reduction_failure e 95 | | Let (x,e1,e2) -> 96 | (* log_eval i e ; *) 97 | let v = eval (i+1) e1 in 98 | let v' = eval (i+1) @@ subst x v e2 in 99 | (* log_val i v' ; *) 100 | v' 101 | | App(f,l) -> 102 | (* log_eval i e ; *) 103 | let vf = eval (i+1) f in 104 | let ve = List.map (eval @@ i+1) l in 105 | let v = eval_app (i+1) e vf ve in 106 | (* log_val i v ; *) 107 | v 108 | | Match (constr, x, e1, e2) -> 109 | let v = eval (i+1) e1 in 110 | match v with 111 | | Constructor (constr', Some param) when Name.equal constr constr' -> 112 | eval (i+1) @@ subst x param e2 113 | | _ -> reduction_failure e 114 | 115 | and eval_app i eorig f l = match f, l with 116 | | _, [] -> f 117 | | Constructor (x, None), [param] -> Constructor (x, Some param) 118 | | Constructor (_, _), _ -> reduction_failure eorig 119 | | Array _, _ -> reduction_failure eorig 120 | | Unit, _ -> reduction_failure eorig 121 | | Lambda(x, body), (v :: t) -> 122 | eval_app i eorig (eval (i+1) @@ subst x v body) t 123 | | Constant c, l -> 124 | begin match delta c l with 125 | | Some x -> eval (i+1) x 126 | | None -> reduction_failure eorig 127 | end 128 | 129 | let execute env p = eval 0 @@ subst_env env p 130 | -------------------------------------------------------------------------------- /lang/affe/examples/array.affe: -------------------------------------------------------------------------------- 1 | # type ('a : 'k) array : aff constraints 'k < aff 2 | val array_init : \ 'k ('a : _). int -> (int -{'k}> 'a) -{'k}> 'a array 3 | val array_free : \ ('a : _). 'a array -> unit 4 | val array_length : \ 'k ('a:_). &('k, 'a array) -> int 5 | val array_get : \ 'k ('a:_). &('k, 'a array) * int -> 'a 6 | val array_set : \ 'k ('a:_). &!('k, 'a array) * int * 'a -> unit 7 | -------------------------------------------------------------------------------- /lang/affe/examples/array.affe.expected: -------------------------------------------------------------------------------- 1 | array_init : 2 | ∀^k, ^k1, 'a. ('a : ^k) => int -> (int -{^k1}> 'a) -{^k1}> 'a array 3 | array_free : ∀^k, 'a. ('a : ^k) => 'a array -> unit 4 | array_length : ∀^k, ^k1, 'a. ('a : ^k) => &(^k1,'a array) -> int 5 | array_get : ∀^k, ^k1, 'a. ('a : ^k) => &(^k1,'a array) * int -> 'a 6 | array_set : ∀^k, ^k1, 'a. ('a : ^k) => &!(^k1,'a array) * int * 'a -> unit 7 | -------------------------------------------------------------------------------- /lang/affe/examples/basics.affe: -------------------------------------------------------------------------------- 1 | let id x = x 2 | let app f x = f x 3 | let ignore x = () 4 | let plus x y = x + y -------------------------------------------------------------------------------- /lang/affe/examples/basics.affe.expected: -------------------------------------------------------------------------------- 1 | id : ∀^k, 'a. ('a : ^k) => 'a -> 'a 2 | 3 | app : 4 | ∀^k, ^l, ^m, 'a, 'b. ('b : ^m) & ('a : ^l) => 5 | ('a -{^k}> 'b) -> 'a -{^k}> 'b 6 | 7 | ignore : ∀^k, 'a. ('a : ^k) & (^k < affₙ) => 'a -> unit 8 | 9 | plus : int -> int -> int 10 | 11 | -------------------------------------------------------------------------------- /lang/affe/examples/channel.affe: -------------------------------------------------------------------------------- 1 | # Channels 2 | # 3 | # We use channels as a basic example of the various concepts available in Affe 4 | 5 | # Prelude 6 | # Let's assume the existence of strings 7 | type string : un 8 | 9 | # Channels are affine. 10 | # This means that a channel can be used at most once. 11 | # It can't be aliased and used by two different functions, 12 | # but it can be "dropped", which means it can stay unused 13 | # 14 | # Affe supports three kinds: 15 | # - `un` : Unrestricted, can be used arbitrarely 16 | # - `aff` : Affine, can be used at most once 17 | # - `lin` : Must be used exactly once 18 | type channel : aff 19 | 20 | # We can open a channel at a particular addresse/file/.. 21 | val open : string -> channel 22 | 23 | # We can close a channel explicitely 24 | val close : channel -> unit 25 | 26 | # We can send and receive data from a channel 27 | # Since the channel can not be aliased, this takes the handle 28 | # on the channel, and then return it again 29 | val send : int -> channel -> channel 30 | val receive : channel -> int * channel 31 | 32 | # Basic programs on channels 33 | 34 | # Open a channel, wait for a message, send it back 35 | let echo_once s = 36 | let ch = open s in 37 | let (msg, ch) = receive ch in 38 | let ch = send msg ch in 39 | let () = close ch in # This `close` is optional, since channels are affines. 40 | # let x = send msg ch in # This would fail 41 | () 42 | 43 | # A common function on channels 44 | let with_channel s f = 45 | let ch = open s in 46 | let ch = f ch in 47 | close ch 48 | 49 | # The type of `with_channel` is 50 | # ∀^a. string -> (channel -{^a}> channel) -> unit 51 | # The annotation on the arrow indicate the linearity. 52 | # It's time to study arrows more closely. 53 | 54 | 55 | # Interlude on arrows 56 | # 57 | # Let us consider a function that applies a closure on a range of integer 58 | 59 | let iter_integers = 60 | let rec aux f i j = 61 | match i = j with { 62 | | True -> () 63 | | False -> 64 | let () = f i in 65 | aux f (i+1) j 66 | } 67 | in 68 | aux 69 | 70 | # This function takes a closure of type `int -{^k}> unit` 71 | # Where `^a` is a *kind* variable that must respect the constraints `^k < unₙ` 72 | # 73 | # Indeed, the closure is called multiple time. if it captured anything linear, 74 | # it could use it multiple time! 75 | 76 | # We can try to send multiple integers by uncommenting the following code: 77 | 78 | # let send_integers s = 79 | # let ch = open s in 80 | # let k msg = let _unused = send msg ch in () in 81 | # iter_integers k 0 10 82 | 83 | # We get an error indicating than the function `k` is `affine`, as it captures 84 | # the channel `ch` which is affine, and thus can not be passed to `iter_integers` 85 | -------------------------------------------------------------------------------- /lang/affe/examples/channel.affe.expected: -------------------------------------------------------------------------------- 1 | type string = un 2 | type channel = aff 3 | open : string -> channel 4 | close : channel -> unit 5 | send : int -> channel -> channel 6 | receive : channel -> int * channel 7 | echo_once : string -> unit 8 | 9 | with_channel : ∀^k. string -> (channel -{^k}> channel) -> unit 10 | 11 | iter_integers : 12 | ∀^k. (^k < unₙ) => (int -{^k}> unit) -> int -{^k}> int -{^k}> unit 13 | 14 | -------------------------------------------------------------------------------- /lang/affe/examples/constructors.affe: -------------------------------------------------------------------------------- 1 | type ('a : 'k) t = Foo of ('a -{'k}> 'a) 2 | let f = Foo (fun x -> x) 3 | let y = let Foo x = f in x 3 -------------------------------------------------------------------------------- /lang/affe/examples/constructors.affe.expected: -------------------------------------------------------------------------------- 1 | type t = ∀^k. ^k -> ^k 2 | constructor Foo : ∀^k, 'a. ('a -{^k}> 'a) -> 'a t 3 | f : ∀^k, 'a. ('a : ^k) => 'a t 4 | 5 | y : int 6 | 7 | -------------------------------------------------------------------------------- /lang/affe/examples/container.affe.expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Drup/pl-experiments/afa641025338f5d6b1151f128bf27eb8ddeb555c/lang/affe/examples/container.affe.expected -------------------------------------------------------------------------------- /lang/affe/examples/cow.affe: -------------------------------------------------------------------------------- 1 | import "array.affe" 2 | 3 | let get (x, i) = 4 | x.(i) 5 | 6 | let copy a = 7 | array_init (array_length a) (fun i -> a.(i)) 8 | 9 | let set (a, i, x) = 10 | let a2 = copy a in 11 | let x = (&!a2).(i) <- x in 12 | a2 13 | 14 | let set_mut (a, i, x) = a.(i) <- x 15 | -------------------------------------------------------------------------------- /lang/affe/examples/cow.affe.expected: -------------------------------------------------------------------------------- 1 | array_init : 2 | ∀^k, ^k1, 'a. ('a : ^k) => int -> (int -{^k1}> 'a) -{^k1}> 'a array 3 | array_free : ∀^k, 'a. ('a : ^k) => 'a array -> unit 4 | array_length : ∀^k, ^k1, 'a. ('a : ^k) => &(^k1,'a array) -> int 5 | array_get : ∀^k, ^k1, 'a. ('a : ^k) => &(^k1,'a array) * int -> 'a 6 | array_set : ∀^k, ^k1, 'a. ('a : ^k) => &!(^k1,'a array) * int * 'a -> unit 7 | get : ∀^k, ^l, 'a. ('a : ^l) => &(^k,'a array) * int -> 'a 8 | 9 | copy : ∀^k, ^l, 'a. ('a : ^l) & (^k < unₙ) => &(^k,'a array) -> 'a array 10 | 11 | set : 12 | ∀^k, ^l, 'a. ('a : ^l) & (^k < unₙ) => 13 | &(^k,'a array) * int * 'a -> 'a array 14 | 15 | set_mut : ∀^k, ^l, 'a. ('a : ^l) => &!(^k,'a array) * int * 'a -> unit 16 | 17 | -------------------------------------------------------------------------------- /lang/affe/examples/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let succes = [ 4 | "array.affe"; 5 | "region.affe"; 6 | "basics.affe"; 7 | "cow.affe"; 8 | "sessions.affe"; 9 | "channel.affe"; 10 | "patmatch.affe"; 11 | "sudoku.affe"; 12 | "constructors.affe"; 13 | "example.affe"; 14 | "pool.affe"; 15 | "test_un.affe"; 16 | ] 17 | 18 | let fail = [ 19 | "fail.affe"; 20 | "nonlexical.affe"; 21 | ] 22 | 23 | 24 | 25 | let stanza_success s = 26 | Format.asprintf {| 27 | (rule 28 | (deps ../affe.exe (glob_files *.affe)) 29 | (action 30 | (with-outputs-to %s.output (run ./../affe.exe %s)))) 31 | 32 | (rule 33 | (alias runtest) 34 | (action (diff %s.expected %s.output))) 35 | |} 36 | s s s s 37 | 38 | let stanza_fail s = 39 | Format.asprintf {| 40 | (rule 41 | (deps ../affe.exe (glob_files *.affe)) 42 | (action 43 | (with-accepted-exit-codes (not 0) 44 | (with-outputs-to %s.output 45 | (run ./../affe.exe %s))))) 46 | 47 | (rule 48 | (alias runtest) 49 | (action (diff %s.expected %s.output))) 50 | |} 51 | s s s s 52 | 53 | let () = 54 | Jbuild_plugin.V1.send @@ String.concat "\n" 55 | (List.map stanza_success succes 56 | @ List.map stanza_fail fail) 57 | -------------------------------------------------------------------------------- /lang/affe/examples/example.affe: -------------------------------------------------------------------------------- 1 | let id = fun x -> x 2 | let id2 = id id 3 | let x = 4 | let x = id2 3 in 5 | id2 6 | let a = 2 7 | let plusa = fun b -> a + b 8 | let c = plusa 2 9 | -------------------------------------------------------------------------------- /lang/affe/examples/example.affe.expected: -------------------------------------------------------------------------------- 1 | id : ∀^k, 'a. ('a : ^k) => 'a -> 'a 2 | 3 | id2 : ('_a -> '_a) 4 | 5 | x : int -> int 6 | 7 | a : int 8 | 9 | plusa : int -> int 10 | 11 | c : int 12 | 13 | -------------------------------------------------------------------------------- /lang/affe/examples/fail.affe: -------------------------------------------------------------------------------- 1 | type channel : lin 2 | val create : unit -> channel 3 | val close : channel -> unit 4 | 5 | let main = 6 | let c = create () in 7 | () 8 | -------------------------------------------------------------------------------- /lang/affe/examples/fail.affe.expected: -------------------------------------------------------------------------------- 1 | type channel = lin 2 | create : unit -> channel 3 | close : channel -> unit 4 | Type error: The kind inequality lin < ^_k < affₙ is not satisfiable. 5 | -------------------------------------------------------------------------------- /lang/affe/examples/nonlexical.affe: -------------------------------------------------------------------------------- 1 | let ignore _ = () 2 | 3 | let f x = 4 | let y = &x in 5 | ignore y; 6 | &!x -------------------------------------------------------------------------------- /lang/affe/examples/nonlexical.affe.expected: -------------------------------------------------------------------------------- 1 | ignore : ∀^k, 'a. ('a : ^k) & (^k < affₙ) => 'a -> unit 2 | 3 | Kind error: Cannot unify kinds un₄ 4 | and lin₃ 5 | 6 | -------------------------------------------------------------------------------- /lang/affe/examples/patmatch.affe: -------------------------------------------------------------------------------- 1 | let not x = match x with { 2 | | True -> False 3 | | False -> True 4 | } 5 | -------------------------------------------------------------------------------- /lang/affe/examples/patmatch.affe.expected: -------------------------------------------------------------------------------- 1 | not : bool -> bool 2 | 3 | -------------------------------------------------------------------------------- /lang/affe/examples/pool.affe: -------------------------------------------------------------------------------- 1 | type ('a : 'k) option : 'k = None of unit | Some of 'a 2 | 3 | type ('a : 'k) queue : 'k 4 | 5 | val qcreate : \ ('a : _) . unit -> 'a queue 6 | val qpush : \ 'k2 ('a : 'k) . 'a -> &('k2, 'a queue) -{'k}> unit 7 | val qpop : \ 'k2 ('a : _) . &('k2, 'a queue) -> 'a option 8 | val qiter : \ ('a :_) . ('a -> unit) -> 'a queue -> unit 9 | 10 | type ('a: 'k) pool : 'k = Pool of ((unit -> 'a) * 'a queue) 11 | let create f = Pool (f, qcreate()) 12 | 13 | let consume f c = match c with { 14 | | Pool (_cre,q) -> qiter f q 15 | } 16 | 17 | let use p f = 18 | match p with { Pool (cr, q) -> 19 | let o = 20 | match qpop &q with { 21 | | Some x -> x 22 | | None () -> cr () 23 | } in 24 | let r = f &!o in 25 | let () = qpush o &q in 26 | r 27 | } 28 | -------------------------------------------------------------------------------- /lang/affe/examples/pool.affe.expected: -------------------------------------------------------------------------------- 1 | type option = ∀^k. ^k -> ^k 2 | constructor None : ∀'a. unit -> 'a option 3 | constructor Some : ∀'a. 'a -> 'a option 4 | type queue = ∀^k. ^k -> ^k 5 | qcreate : ∀^k, 'a. ('a : ^k) => unit -> 'a queue 6 | qpush : ∀^k, ^k2, 'a. ('a : ^k) => 'a -> &(^k2,'a queue) -{^k}> unit 7 | qpop : ∀^k, ^k2, 'a. ('a : ^k) => &(^k2,'a queue) -> 'a option 8 | qiter : ∀^k, 'a. ('a : ^k) => ('a -> unit) -> 'a queue -> unit 9 | type pool = ^_k -> ^_k 10 | constructor Pool : ∀'a. unit -> 'a * 'a queue -> 'a pool 11 | create : ∀^k, 'a. ('a : ^k) => (unit -> 'a) -> 'a pool 12 | 13 | consume : ∀^k, 'a. ('a : ^k) => ('a -> unit) -> 'a pool -> unit 14 | 15 | use : 16 | ∀^k, ^l, ^m, 'a, 'a1. ('a1 : ^m) & ('a : ^l) & (^l < lin₁) => 17 | 'a1 pool -> (&!(aff₄,'a1) -{^k}> 'a) -{^m}> 'a 18 | 19 | -------------------------------------------------------------------------------- /lang/affe/examples/region.affe: -------------------------------------------------------------------------------- 1 | let ignore _ = () 2 | 3 | let x = 2 4 | 5 | let t1 = 6 | let y = &x in 7 | 2 8 | 9 | let t2 = 10 | ignore &x 11 | 12 | let t3 = fun y -> ignore &y 13 | -------------------------------------------------------------------------------- /lang/affe/examples/region.affe.expected: -------------------------------------------------------------------------------- 1 | ignore : ∀^k, 'a. ('a : ^k) & (^k < affₙ) => 'a -> unit 2 | 3 | x : int 4 | 5 | t1 : int 6 | 7 | t2 : unit 8 | 9 | t3 : ∀^k, 'a. ('a : ^k) => 'a -> unit 10 | 11 | -------------------------------------------------------------------------------- /lang/affe/examples/sessions.affe: -------------------------------------------------------------------------------- 1 | # Session types 2 | # 3 | # This follow the encoding by Luca Padovani in 4 | # A simple library implementation of binary sessions 5 | # See http://www.di.unito.it/~padovani/Software/FuSe/FuSe.html 6 | 7 | # The either type is useful for choices 8 | type ('a: 'k, 'b: 'k) either = Left of 'a | Right of 'b 9 | 10 | # Our session type primitives 11 | # These should be defined in term of lower level network primitives. 12 | # Here, we just state them without any implemnetation 13 | 14 | type empty : un 15 | # Type aliases are not implemented, so we expand ot and it in the rest of the file. 16 | # type ('a : _) ot : lin = (empty, 'a) st 17 | # type ('a : _) it : lin = ('a, empty) st 18 | 19 | type ('a : _, 'b: _) st : lin # This is the only linearity annotation in the whole file 20 | 21 | val receive: 22 | \ ('a:_)('b:_)('m:'k). 23 | # ('m * ('a, 'b) st) it -> 'm * ('a, 'b) st 24 | ('m * ('a, 'b) st, empty) st -> 'm * ('a, 'b) st 25 | 26 | val send : 27 | \ ('a:_)('b:_)('m:'k). 28 | # 'm -> ('m * ('a, 'b) st) ot -> ('b, 'a) st 29 | 'm -> (empty, 'm * ('a, 'b) st) st -{'k}> ('b, 'a) st 30 | 31 | val create : 32 | \ ('a:_) ('b:_). 33 | unit -> ('a, 'b) st * ('b, 'a) st 34 | 35 | val close : (empty, empty) st -> unit 36 | 37 | val select : 38 | \ ('a:_)('b:_)('m:_). 39 | (('a, 'b) st -> 'm) -> (empty, 'm) st -> ('b, 'a) st 40 | 41 | val branch : \ ('m:_). ('m, empty) st -> 'm 42 | 43 | # Protocol implementation 44 | # These directly follow the basic examples. 45 | 46 | let op_client ep x y = 47 | let ep = send x ep in 48 | let ep = send y ep in 49 | let (result, ep) = receive ep in 50 | let u = close ep in 51 | result 52 | 53 | let add_service ep = 54 | let (x, ep) = receive ep in 55 | let (y, ep) = receive ep in 56 | let ep = send (x + y) ep in 57 | close ep 58 | 59 | let dec_service ep = 60 | let (x, ep) = receive ep in 61 | let ep = send (x - 1) ep in 62 | close ep 63 | 64 | let math_service ep = 65 | let b = branch ep in 66 | match b with { 67 | | Left x -> add_service x 68 | | Right x -> dec_service x 69 | } 70 | 71 | let main1 () = 72 | let (a, b) = create () in 73 | let () = math_service a in 74 | let b = select Left b in 75 | op_client b 1 2 76 | 77 | let main2 () = 78 | let (a, b) = create () in 79 | let () = math_service a in 80 | let ep = select Right b in 81 | let ep = send 4 ep in 82 | let (result, ep) = receive ep in 83 | let () = close ep in 84 | result -------------------------------------------------------------------------------- /lang/affe/examples/sessions.affe.expected: -------------------------------------------------------------------------------- 1 | type either = ∀^k. ^k -> ^k -> ^k 2 | constructor Left : ∀'b, 'a. 'a -> ('a, 'b) either 3 | constructor Right : ∀'b, 'a. 'b -> ('a, 'b) either 4 | type empty = un 5 | type st = ∀^k, ^l. ^l -> ^k -> lin 6 | receive : 7 | ∀^k, ^l, ^m, 'm1, 'b, 'a. ('a : ^m) & ('b : ^l) & ('m1 : ^k) => 8 | ('m1 * ('a, 'b) st, empty) st -> 'm1 * ('a, 'b) st 9 | send : 10 | ∀^k, ^l, ^m, 'm1, 'b, 'a. ('a : ^m) & ('b : ^l) & ('m1 : ^k) => 11 | 'm1 -> (empty, 'm1 * ('a, 'b) st) st -{^k}> ('b, 'a) st 12 | create : 13 | ∀^k, ^l, 'b, 'a. ('a : ^l) & ('b : ^k) => unit -> ('a, 'b) st * ('b, 'a) st 14 | close : (empty, empty) st -> unit 15 | select : 16 | ∀^k, ^l, ^m, 'm1, 'b, 'a. ('a : ^m) & ('b : ^l) & ('m1 : ^k) => 17 | (('a, 'b) st -> 'm1) -> (empty, 'm1) st -> ('b, 'a) st 18 | branch : ∀^k, 'm. ('m : ^k) => ('m, empty) st -> 'm 19 | op_client : 20 | ∀^k, ^l, ^m, ^n, 'm1, 'm2, 'a. 21 | ('a : ^n) & ('m2 : ^m) & ('m1 : ^k) & (^k < ^l) & (lin < ^l) => 22 | (empty, 'm1 * ('m2 * (empty, 'a * (empty, empty) st) st, empty) st) st -> 'm1 -{lin}> 'm2 -{^l}> 'a 23 | 24 | add_service : 25 | (int * (int * (empty, int * (empty, empty) st) st, empty) st, empty) st -> unit 26 | 27 | dec_service : (int * (empty, int * (empty, empty) st) st, empty) st -> unit 28 | 29 | math_service : 30 | (((int * (int * (empty, int * (empty, empty) st) st, empty) st, empty) st, 31 | (int * (empty, int * (empty, empty) st) st, empty) st) either, 32 | empty) st -> unit 33 | 34 | main1 : unit -> int 35 | 36 | main2 : unit -> int 37 | 38 | -------------------------------------------------------------------------------- /lang/affe/examples/sudoku.affe: -------------------------------------------------------------------------------- 1 | import "cow.affe" 2 | 3 | # Misc 4 | 5 | val not : bool -> bool 6 | val and : bool -> bool -> bool 7 | 8 | # Int sets 9 | 10 | type intset 11 | val empty : intset 12 | val add : intset -> int -> intset 13 | val rm : intset -> int -> intset 14 | val iter_set : \ 'k . (int -{'k}> unit) -> intset -{'k}> unit 15 | val cardinal : intset -> int 16 | 17 | 18 | val print : \ 'k . &('k,intset array) -> unit 19 | 20 | let size = 9 21 | 22 | let full_cell = 23 | let rec f i xset = 24 | match i < 0 with { 25 | | True -> xset 26 | | False -> f (i - 1) (add xset i) 27 | } 28 | in 29 | f (size - 1) empty 30 | 31 | let singleton n = add empty n 32 | 33 | let get x (i, j) = get (x, i*size+j) 34 | let set_mut x (i, j) v = set_mut (x, i*size+j, v) 35 | let set x (i, j) v = set (x, i*size+j, v) 36 | 37 | val for_all : \ 'k 'k2 ('a: _) . ('a -{'k2}> bool) -> &('k, 'a array) -{'k2}> bool 38 | 39 | let for = 40 | let rec aux i j f = 41 | match i > j with { 42 | | True -> () 43 | | False -> 44 | let () = f i in 45 | aux (i+1) j f 46 | } 47 | in aux 48 | 49 | 50 | let remove_line i0 j0 g n = 51 | for (j0+1) (size - 1) (fun j -> 52 | let cell = rm (get &&g (i0 , j)) n in 53 | set_mut &&!g (i0, j) cell 54 | ) 55 | 56 | let remove_column i0 j0 g n = 57 | for (i0+1) (size - 1) (fun i -> 58 | let cell = rm (get &&g (i , j0)) n in 59 | set_mut &&!g (i , j0) cell 60 | ) 61 | 62 | let remove_square i0 j0 g n = 63 | let pos_i = i0 / 3 in 64 | let pos_j = j0 / 3 in 65 | for (3*pos_i) (3*(pos_i+1) - 1) (fun i -> 66 | for (3*pos_j) (3*(pos_j+1) - 1) (fun j -> 67 | match and (i = i0) (j = j0) with { 68 | | False -> 69 | let cell = rm (get &&g (i , j)) n in 70 | set_mut &&!g (i , j) cell 71 | | True -> 72 | () 73 | } 74 | ) 75 | ) 76 | 77 | let is_valid g = 78 | for_all (fun x -> cardinal x > 0) g 79 | 80 | let is_solved g = 81 | for_all (fun x -> cardinal x = 1) g 82 | 83 | let next_pos (i, j) = 84 | match j < (size - 1) with { 85 | | True -> (i, j + 1) 86 | | False -> (i + 1, 0) 87 | } 88 | 89 | let remove i j g n = 90 | let () = remove_line i j &&!g n in 91 | let () = remove_column i j &&!g n in 92 | let () = remove_square i j &&!g n in 93 | () 94 | 95 | let solve = 96 | let rec solve i j g = 97 | match is_solved &g with { 98 | | True -> print &g 99 | | False -> 100 | let s = get &g (i,j) in 101 | let (new_i, new_j) = next_pos (i,j) in 102 | let try_solution n = 103 | let new_g = set &g (i,j) (singleton n) in 104 | let () = remove i j &!new_g n in 105 | match is_valid &new_g with { 106 | | True -> solve new_i new_j new_g 107 | | False -> () 108 | } 109 | in 110 | iter_set try_solution s 111 | } 112 | in solve -------------------------------------------------------------------------------- /lang/affe/examples/sudoku.affe.expected: -------------------------------------------------------------------------------- 1 | array_init : 2 | ∀^k, ^k1, 'a. ('a : ^k) => int -> (int -{^k1}> 'a) -{^k1}> 'a array 3 | array_free : ∀^k, 'a. ('a : ^k) => 'a array -> unit 4 | array_length : ∀^k, ^k1, 'a. ('a : ^k) => &(^k1,'a array) -> int 5 | array_get : ∀^k, ^k1, 'a. ('a : ^k) => &(^k1,'a array) * int -> 'a 6 | array_set : ∀^k, ^k1, 'a. ('a : ^k) => &!(^k1,'a array) * int * 'a -> unit 7 | get : ∀^k, ^l, 'a. ('a : ^l) => &(^k,'a array) * int -> 'a 8 | 9 | copy : ∀^k, ^l, 'a. ('a : ^l) & (^k < unₙ) => &(^k,'a array) -> 'a array 10 | 11 | set : 12 | ∀^k, ^l, 'a. ('a : ^l) & (^k < unₙ) => 13 | &(^k,'a array) * int * 'a -> 'a array 14 | 15 | set_mut : ∀^k, ^l, 'a. ('a : ^l) => &!(^k,'a array) * int * 'a -> unit 16 | 17 | not : bool -> bool 18 | and : bool -> bool -> bool 19 | type intset = un 20 | empty : intset 21 | add : intset -> int -> intset 22 | rm : intset -> int -> intset 23 | iter_set : ∀^k. (int -{^k}> unit) -> intset -{^k}> unit 24 | cardinal : intset -> int 25 | print : ∀^k. &(^k,intset array) -> unit 26 | size : int 27 | 28 | full_cell : intset 29 | 30 | singleton : int -> intset 31 | 32 | get : ∀^k, ^l, 'a. ('a : ^l) => &(^k,'a array) -> int * int -{^k}> 'a 33 | 34 | set_mut : 35 | ∀^k, ^l, 'a. ('a : ^l) => 36 | &!(^k,'a array) -> int * int -{^k}> 'a -{^k}> unit 37 | 38 | set : 39 | ∀^k, ^l, 'a. ('a : ^l) & (^k < unₙ) => 40 | &(^k,'a array) -> int * int -{^k}> 'a -{^k}> 'a array 41 | 42 | for_all : 43 | ∀^k, ^k2, ^k1, 'a. ('a : ^k) => 44 | ('a -{^k2}> bool) -> &(^k1,'a array) -{^k2}> bool 45 | for : ∀^k. (^k < unₙ) => int -> int -> (int -{^k}> unit) -> unit 46 | 47 | remove_line : ∀^k. int -> int -> &!(^k,intset array) -> int -> unit 48 | 49 | remove_column : ∀^k. int -> int -> &!(^k,intset array) -> int -> unit 50 | 51 | remove_square : ∀^k. int -> int -> &!(^k,intset array) -> int -> unit 52 | 53 | is_valid : ∀^k. &(^k,intset array) -> bool 54 | 55 | is_solved : ∀^k. &(^k,intset array) -> bool 56 | 57 | next_pos : int * int -> int * int 58 | 59 | remove : ∀^k. int -> int -> &!(^k,intset array) -> int -> unit 60 | 61 | solve : int -> int -> intset array -> unit 62 | 63 | -------------------------------------------------------------------------------- /lang/affe/examples/test_un.affe: -------------------------------------------------------------------------------- 1 | let f = fun x -> fun y -> x 2 | let a x = f 2 x 3 | let a2 = a 3 4 | let b = fun x -> f x x 5 | -------------------------------------------------------------------------------- /lang/affe/examples/test_un.affe.expected: -------------------------------------------------------------------------------- 1 | f : 2 | ∀^k, ^l, 'a, 'b. ('b : ^l) & ('a : ^k) & (^l < affₙ) => 3 | 'a -> 'b -{^k}> 'a 4 | 5 | a : ∀^k, 'a. ('a : ^k) & (^k < affₙ) => 'a -> int 6 | 7 | a2 : int 8 | 9 | b : ∀^k, 'a. ('a : ^k) & (^k < unₙ) => 'a -> 'a 10 | 11 | -------------------------------------------------------------------------------- /lang/affe/instantiate.ml: -------------------------------------------------------------------------------- 1 | module T = Types 2 | 3 | type ienv = { 4 | kinds : (Name.t * T.kind) Name.Tbl.t; 5 | types : (Name.t * T.typ) Name.Tbl.t; 6 | level : int; 7 | } 8 | let create level = { 9 | kinds = Name.Tbl.create 17; 10 | types = Name.Tbl.create 17; 11 | level; 12 | } 13 | let level i = i.level 14 | 15 | let kvar ~ienv id = 16 | try 17 | Name.Tbl.find ienv.kinds id 18 | with Not_found -> 19 | let b = T.kind ?name:id.name ienv.level in 20 | Name.Tbl.add ienv.kinds id b ; 21 | b 22 | let tyvar ~ienv id = 23 | try 24 | Name.Tbl.find ienv.types id 25 | with Not_found -> 26 | let b = T.var ?name:id.name ienv.level in 27 | Name.Tbl.add ienv.types id b ; 28 | b 29 | 30 | let rec instance_kind ~ienv = function 31 | | Kinds.Var {contents = Link k} as korig -> 32 | let knew = instance_kind ~ienv k in 33 | if korig = knew then korig else knew 34 | | Var {contents = Unbound _} as k -> k 35 | | GenericVar id -> snd @@ kvar ~ienv id 36 | | Un _ | Aff _ | Lin _ as k -> k 37 | 38 | let rec instance_type ~ienv = function 39 | | T.Var {contents = Link ty} -> instance_type ~ienv ty 40 | | T.GenericVar id -> snd @@ tyvar ~ienv id 41 | | T.Var {contents = Unbound _} as ty -> ty 42 | | T.App(ty, args) -> 43 | let args = List.map (instance_type ~ienv) args in 44 | App(ty, args) 45 | | T.Tuple args -> 46 | let args = List.map (instance_type ~ienv) args in 47 | Tuple args 48 | | T.Borrow (r, k, ty) -> 49 | let k = instance_kind ~ienv k in 50 | let ty = instance_type ~ienv ty in 51 | Borrow (r, k, ty) 52 | | T.Arrow(param_ty, k, return_ty) -> 53 | Arrow(instance_type ~ienv param_ty, 54 | instance_kind ~ienv k, 55 | instance_type ~ienv return_ty) 56 | 57 | 58 | let instance_constr ~ienv c = 59 | let rec aux (c : T.normalized_constr) = match c with 60 | | And l -> T.And (List.map aux l) 61 | | KindLeq (k1, k2) -> 62 | KindLeq (instance_kind ~ienv k1, 63 | instance_kind ~ienv k2) 64 | | HasKind (id, t, k) -> 65 | let id, _ = tyvar ~ienv id in 66 | HasKind (id, instance_type ~ienv t, 67 | instance_kind ~ienv k) 68 | in 69 | aux c 70 | 71 | let included tbl vars = 72 | Name.Tbl.keys tbl 73 | |> Iter.for_all 74 | (fun x -> CCList.mem ~eq:Name.equal x vars) 75 | 76 | (** Exported functions *) 77 | 78 | let constr level constr = 79 | let ienv = create level in 80 | instance_constr ~ienv constr 81 | 82 | let kind_scheme ?args:(kargs=[]) ~level {T. kvars; constr; args; kind } = 83 | let ienv = create level in 84 | let kl = List.length kargs and l = List.length args in 85 | if kl <> l then 86 | Zoo.error ~kind:"Type error" 87 | "This type constructor is applied to %i types \ 88 | but has only %i parameters." l kl; 89 | let constr = 90 | List.fold_left2 (fun l k1 k2 -> T.(And [KindLeq (k1,k2); l])) 91 | constr 92 | kargs 93 | args 94 | in 95 | let constr = instance_constr ~ienv constr in 96 | let kind = instance_kind ~ienv kind in 97 | assert (included ienv.kinds kvars); 98 | (constr, kind) 99 | 100 | let typ_scheme ~level {T. constr ; tyvars; kvars; ty } = 101 | let ienv = create level in 102 | let c = instance_constr ~ienv constr in 103 | let ty = instance_type ~ienv ty in 104 | assert (included ienv.kinds kvars); 105 | assert (included ienv.types tyvars); 106 | (c, ty) 107 | -------------------------------------------------------------------------------- /lang/affe/instantiate.mli: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | type ienv 4 | val create : level -> ienv 5 | val level : ienv -> level 6 | 7 | val kvar : ienv:ienv -> Name.t -> Name.t * kind 8 | val tyvar : ienv:ienv -> Name.t -> Name.t * typ 9 | 10 | val constr : int -> normalized_constr -> normalized_constr 11 | 12 | val kind_scheme : 13 | ?args:kind list -> 14 | level:int -> kscheme -> normalized_constr * kind 15 | 16 | val typ_scheme : 17 | level:int -> 18 | scheme -> 19 | normalized_constr * typ 20 | -------------------------------------------------------------------------------- /lang/affe/kinds.ml: -------------------------------------------------------------------------------- 1 | module Region = struct 2 | type t = Global | Region of int | Never 3 | let compare r1 r2 = match r1, r2 with 4 | | Region r1, Region r2 -> CCInt.compare r1 r2 5 | | Global, Global | Never, Never -> 0 6 | | Global, _ | _, Never -> -1 7 | | _, Global | Never, _ -> 1 8 | let equal r1 r2 = compare r1 r2 = 0 9 | let biggest = Never 10 | let smallest = Global 11 | let max l1 l2 = match l1, l2 with 12 | | Region r1, Region r2 -> Region (CCInt.max r1 r2) 13 | | Never, _ | _, Never -> Never 14 | | Global, l | l, Global -> l 15 | let min l1 l2 = match l1, l2 with 16 | | Region r1, Region r2 -> Region (CCInt.min r1 r2) 17 | | Never, l | l, Never -> l 18 | | Global, _ | _, Global -> Global 19 | end 20 | type region = Region.t 21 | 22 | module Lattice = struct 23 | type t = 24 | | Un of Region.t 25 | | Aff of Region.t 26 | | Lin of Region.t 27 | let leq l1 l2 = match l1, l2 with 28 | | Lin r1, Lin r2 29 | | Aff r1, Aff r2 30 | | Un r1, Un r2 -> Region.compare r1 r2 <= 0 31 | | _, Lin Never -> true 32 | | Un Global, _ -> true 33 | | Un r1, Aff r2 | Un r1, Lin r2 | Aff r1, Lin r2 -> 34 | Region.compare r1 r2 <= 0 35 | | _ -> false 36 | let equal l1 l2 = match l1, l2 with 37 | | Lin r1, Lin r2 38 | | Aff r1, Aff r2 39 | | Un r1, Un r2 -> Region.equal r1 r2 40 | | _ -> false 41 | let smallest = Un Region.smallest 42 | let biggest = Lin Region.biggest 43 | let max l1 l2 = match l1, l2 with 44 | | Un r1, Un r2 -> Un (Region.max r1 r2) 45 | | Aff r1, Aff r2 -> Aff (Region.max r1 r2) 46 | | Lin r1, Lin r2 -> Lin (Region.max r1 r2) 47 | | Un _, (Aff _ as r) 48 | | (Un _ | Aff _), (Lin _ as r) 49 | | (Lin _ as r), (Un _ | Aff _) 50 | | (Aff _ as r), Un _ -> r 51 | let min l1 l2 = match l1, l2 with 52 | | Un r1, Un r2 -> Un (Region.min r1 r2) 53 | | Aff r1, Aff r2 -> Aff (Region.min r1 r2) 54 | | Lin r1, Lin r2 -> Lin (Region.min r1 r2) 55 | | (Aff _ | Lin _), (Un _ as r) 56 | | Lin _, (Aff _ as r) 57 | | (Un _ as r), (Aff _ | Lin _) 58 | | (Aff _ as r), Lin _ 59 | -> r 60 | let least_upper_bound = List.fold_left max smallest 61 | let greatest_lower_bound = List.fold_left min biggest 62 | let constants = 63 | [ Un Global ; Un Never ; 64 | Aff Global ; Aff Never ; 65 | Lin Global ; Lin Never ; 66 | ] 67 | let relations consts = 68 | let consts = constants @ consts in 69 | CCList.product (fun l r -> l, r) consts consts 70 | |> CCList.filter (fun (l, r) -> leq l r) 71 | end 72 | 73 | 74 | type level = int 75 | 76 | type kind = 77 | | Un : region -> kind 78 | | Aff : region -> kind 79 | | Lin : region -> kind 80 | | GenericVar : Name.t -> kind 81 | | Var : var ref -> kind 82 | 83 | and var = 84 | | Unbound of Name.t * level 85 | | Link of kind 86 | 87 | let un r = Un r 88 | let aff r = Aff r 89 | let lin r = Lin r 90 | 91 | 92 | (** Immutable impl, without embedded union find *) 93 | (* module K = struct 94 | * type t = 95 | * | Var of Name.t * level option 96 | * | Constant of Lattice.t 97 | * let equal l1 l2 = match l1, l2 with 98 | * | Var (n1,_), Var (n2,_) -> Name.equal n1 n2 99 | * | Constant l1, Constant l2 -> Lattice.(l1 = l2) 100 | * | _ -> false 101 | * let hash = Hashtbl.hash 102 | * let compare l1 l2 = if equal l1 l2 then 0 else compare l1 l2 103 | * end 104 | * 105 | * (\** Utilities for the lattice solver *\) 106 | * 107 | * type constant = Lattice.t 108 | * let classify = function 109 | * | Constant c -> `Constant c 110 | * | Var _ -> `Var 111 | * let constant c = Constant c *) 112 | 113 | 114 | module K = struct 115 | type t = kind 116 | 117 | let rec repr = function 118 | | Var {contents = Link k} -> repr k 119 | | Un _ | Aff _ | Lin _ | GenericVar _ 120 | | Var {contents = Unbound _} as k -> k 121 | 122 | let equal a b = repr a = repr b 123 | let hash x = Hashtbl.hash (repr x) 124 | let compare a b = compare (repr a) (repr b) 125 | 126 | type constant = Lattice.t 127 | let rec classify = function 128 | | Var { contents = Link k } -> classify k 129 | | Var { contents = Unbound (n,_) } 130 | | GenericVar n -> `Var n 131 | | Lin r -> `Constant (Lattice.Lin r) 132 | | Aff r -> `Constant (Lattice.Aff r) 133 | | Un r -> `Constant (Lattice.Un r) 134 | let constant = function 135 | | Lattice.Lin r -> Lin r 136 | | Lattice.Aff r -> Aff r 137 | | Lattice.Un r -> Un r 138 | 139 | end 140 | 141 | include K 142 | module Map = Map.Make(K) 143 | module Set = Set.Make(K) 144 | -------------------------------------------------------------------------------- /lang/affe/lattice_solver.ml: -------------------------------------------------------------------------------- 1 | module type LAT = sig 2 | type t 3 | val leq : t -> t -> bool 4 | val equal : t -> t -> bool 5 | val biggest : t 6 | val smallest : t 7 | val least_upper_bound : t list -> t 8 | val greatest_lower_bound : t list -> t 9 | val relations : t list -> (t * t) list 10 | end 11 | 12 | module type KINDS = sig 13 | type t 14 | val equal : t -> t -> bool 15 | val hash : t -> int 16 | val compare : t -> t -> int 17 | 18 | type constant 19 | val constant : constant -> t 20 | 21 | val classify : t -> [> `Var of Name.t | `Constant of constant ] 22 | val unify : t list -> t 23 | end 24 | 25 | let (?>) f m g = 26 | match m with 27 | | Some m -> f m g 28 | | None -> g 29 | 30 | module Make (Lat : LAT) (K : KINDS with type constant = Lat.t) = struct 31 | 32 | module G = Graph.Persistent.Digraph.Concrete(K) 33 | module Check = Graph.Path.Check(G) 34 | module Scc = Graph.Components.Make(G) 35 | module O = Graph.Oper.P(G) 36 | module Map = CCMap.Make(G.V) 37 | module Set = CCSet.Make(G.V) 38 | module H = Hashtbl.Make(G.V) 39 | 40 | exception IllegalEdge of K.constant * K.constant 41 | exception IllegalBounds of K.constant * K.t * K.constant 42 | 43 | let add_extra_vars map g = 44 | Name.Map.fold (fun _ (k,_) g -> G.add_vertex g k) map g 45 | 46 | let add_lattice_inequalities g0 = 47 | let constants = 48 | G.fold_vertex List.cons g0 [] 49 | |> CCList.filter_map 50 | (fun x -> match K.classify x with `Var _ -> None | `Constant c -> Some c) 51 | in 52 | let relations = Lat.relations constants in 53 | List.fold_left 54 | (fun g (k1, k2) -> G.add_edge g (K.constant k1) (K.constant k2)) 55 | g0 relations 56 | 57 | (* O(|V|*|C|) *) 58 | let lattice_closure g0 = 59 | let constant_subgraph = 60 | let aux v g = match K.classify v with 61 | | `Var _ -> G.remove_vertex g v 62 | | `Constant _ -> g 63 | in 64 | G.fold_vertex aux g0 g0 65 | in 66 | let c = Check.create g0 in 67 | let constant_check = Check.create constant_subgraph in 68 | let constants, vars = 69 | let f k (cl,vl) = match K.classify k with 70 | | `Var _ -> (cl, k :: vl) 71 | | `Constant c -> ((k, c) :: cl, vl) 72 | in G.fold_vertex f g0 ([],[]) 73 | in 74 | let add_bounds g var = 75 | let lesser, greater = 76 | let f (l,g) (vertex, constant) = 77 | if Check.check_path c var vertex then (l, constant::g) 78 | else if Check.check_path c vertex var then (constant::l, g) 79 | else (l, g) 80 | in 81 | List.fold_left f ([],[]) constants 82 | in 83 | let bound_lesser = Lat.least_upper_bound lesser in 84 | let bound_greater = Lat.greatest_lower_bound greater in 85 | let node_lesser = K.constant bound_lesser in 86 | let node_greater = K.constant bound_greater in 87 | if not (Check.check_path constant_check node_lesser node_greater) then 88 | raise (IllegalBounds (bound_lesser, var, bound_greater)); 89 | let g = G.add_edge g node_lesser var in 90 | let g = G.add_edge g var node_greater in 91 | g 92 | in 93 | List.fold_left add_bounds g0 vars 94 | 95 | (* O(|V+C|*unification + |E|) *) 96 | let unify_clusters g0 = 97 | (* We use [Types.kind] as vertices, [K.unify] will mutate them, 98 | thus making the internal sets of the graph invalid. 99 | To avoid issues, we extract the edges as a list and walk through it 100 | afterwards. It would be better to use a representation of kinds 101 | that is immutable. *) 102 | let edges = G.fold_edges (fun v1 v2 l -> (v1,v2) ::l) g0 [] in 103 | let clusters = Scc.scc_array g0 in 104 | let _vertices = Array.map K.unify clusters in 105 | let g_minified = 106 | let add_minified_edge g (v1, v2) = 107 | G.add_edge g v1 v2 108 | in 109 | List.fold_left add_minified_edge G.empty edges 110 | in 111 | 112 | (* let n, cluster = Scc.scc g0 in *) 113 | (* let unified_vars = 114 | * let a = Array.make n [] in 115 | * let register_vertice v = a.(cluster v) <- v :: a.(cluster v) in 116 | * G.iter_vertex register_vertice g0 ; 117 | * Array.map K.unify a (\* g0 is invalid after this operation *\) 118 | * in 119 | * let g_minified = 120 | * let add_minified_edge g (v1, v2) = 121 | * G.add_edge g (unified_vars.(cluster v1)) unified_vars.(cluster v2) 122 | * in 123 | * List.fold_left add_minified_edge G.empty edges 124 | * in *) 125 | g_minified 126 | 127 | 128 | let check_constants g0 = 129 | let cleanup_edge v1 v2 g = 130 | match K.classify v1, K.classify v2 with 131 | | `Constant l1, `Constant l2 -> 132 | if Lat.leq l1 l2 then g 133 | else raise (IllegalEdge (l1, l2)) 134 | | _ -> G.add_edge g v1 v2 135 | in 136 | G.fold_edges cleanup_edge g0 G.empty 137 | 138 | module Simplify = struct 139 | 140 | let unused_variables vars g0 = 141 | let cleanup_vertex v g = 142 | match K.classify v with 143 | | `Var n when not (Name.Map.mem n vars) -> G.remove_vertex g v 144 | | `Var _ | `Constant _ -> g 145 | in 146 | G.fold_vertex cleanup_vertex g0 g0 147 | 148 | (* Slightly modified version of Graph.Contraction(G).contract *) 149 | let contract prop unify g = 150 | (* if the edge is to be removed (property = true): 151 | * make a union of the two union-sets of start and end node; 152 | * put this set in the map for all nodes in this set *) 153 | let collect_clusters edge (m, edges) = 154 | if prop edge then 155 | let s_src, s_dst = Map.find (G.E.src edge) m, Map.find (G.E.dst edge) m in 156 | let s = Set.union s_src s_dst in 157 | let m = Set.fold (fun vertex m -> Map.add vertex s m) s m in 158 | m, edges 159 | else 160 | m, edge :: edges 161 | in 162 | (* initialize map with singleton-sets for every node (of itself) *) 163 | let m = 164 | G.fold_vertex (fun vertex m -> Map.add vertex (Set.singleton vertex) m) 165 | g Map.empty 166 | in 167 | (* find all closures *) 168 | let m, remaining_edges = G.fold_edges_e collect_clusters g (m, []) in 169 | (* WARNING: side effects in unify, the graph is invalid afterwards *) 170 | Map.iter (fun _ ks -> ignore @@ unify ks) m; 171 | let add_minified_edge g (v1, v2) = G.add_edge g v1 v2 in 172 | List.fold_left add_minified_edge G.empty remaining_edges 173 | 174 | let simplify_with_position variance_map g0 = 175 | let get_pos v = match K.classify v with 176 | | `Constant _ -> None 177 | | `Var n -> match Name.Map.find_opt n variance_map with 178 | | Some (_,v) -> Some v 179 | | None -> None 180 | in 181 | let p (v1, v2) = 182 | match get_pos v1, get_pos v2 with 183 | | Some Variance.(Neg | Bivar), Some _ when G.out_degree g0 v1 = 1 -> true 184 | | _, Some Variance.(Pos | Bivar) when G.in_degree g0 v2 = 1 -> true 185 | | _ -> false 186 | in 187 | let unif ks = K.unify @@ Set.elements ks in 188 | contract p unif g0 189 | 190 | let bounds g = 191 | let g = G.remove_vertex g (K.constant Lat.biggest) in 192 | let g = G.remove_vertex g (K.constant Lat.smallest) in 193 | g 194 | 195 | let go keep_vars g = 196 | g 197 | |> O.transitive_closure 198 | |> ?> unused_variables keep_vars 199 | |> O.transitive_reduction ~reflexive:true 200 | |> ?> simplify_with_position keep_vars 201 | |> bounds 202 | end 203 | 204 | let solve ?keep_vars l = 205 | l 206 | |> ?> add_extra_vars keep_vars 207 | |> add_lattice_inequalities 208 | |> lattice_closure 209 | |> unify_clusters 210 | |> Simplify.go keep_vars 211 | |> check_constants 212 | 213 | (* let simplify ?keep_vars l = 214 | * from_normal l 215 | * |> Simplify.go keep_vars 216 | * |> to_normal *) 217 | end 218 | -------------------------------------------------------------------------------- /lang/affe/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | } 4 | 5 | rule token = parse 6 | | [' ' '\t'] { token lexbuf } (* skip blanks *) 7 | | '#' [^'\n']* '\n' 8 | | '\n' { Lexing.new_line lexbuf ; token lexbuf } 9 | | '-'?[ '0'-'9' ]+ as x {INT (int_of_string x)} 10 | | '"' ([^ '"']* as s) '"' { STRING s} 11 | | "Y" { YTOK } 12 | | "let" { LET } 13 | | "in" { IN } 14 | | "=" { EQUAL } 15 | | "fun" { FUN } 16 | | "rec" { REC } 17 | | "%" { PERCENT } 18 | | "->" { RIGHTARROW } 19 | | "<-" { LEFTARROW } 20 | | "-{" { DASHLACCO } 21 | | "<" { LESS } 22 | | "&!" { ANDBANG } 23 | | "&" { AND } 24 | | "_" { UNDERSCORE } 25 | | "}>" { RACCOGREATER } 26 | | '(' { LPAREN } 27 | | ')' { RPAREN } 28 | | '{' { LACCO } 29 | | '}' { RACCO } 30 | | "[|" { LBRACKPIPE } 31 | | "|]" { PIPERBRACK } 32 | | "-" { MINUS } 33 | | "<" { LESS } 34 | | ">" { GREATER } 35 | | "+" { PLUS } 36 | | "*" { STAR } 37 | | "|" { BAR } 38 | | "/" { DIV } 39 | | "." { DOT } 40 | | "type" { TYPE } 41 | | "val" { VAL } 42 | | "with" { WITH } 43 | | "match" { MATCH None } 44 | | "match&" { MATCH (Some Immutable) } 45 | | "match&!" { MATCH (Some Mutable) } 46 | | "=>" { BIGRIGHTARROW } 47 | | "of" { OF } 48 | | "import" { IMPORT } 49 | | "for all" | "\\" { FORALL } 50 | | ":" { DOUBLECOLON } 51 | | "," { COMMA } 52 | | "un" { UN } 53 | | "aff" { AFF } 54 | | "lin" { LIN } 55 | | ';' { SEMI } 56 | | ";;" { SEMISEMI } 57 | | ('#' [^'\n']*)? eof { EOF } 58 | | "'" ( '_'? [ 'A'-'Z' 'a'-'z' '0'-'9' '_' '\'' ]+ as s) { TYIDENT s } 59 | | ( '_'? [ 'a'-'z' ] [ 'A'-'Z' 'a'-'z' '0'-'9' '_' '\'' ]*) as s { IDENT s } 60 | | ( '_'? [ 'A'-'Z' ] [ 'A'-'Z' 'a'-'z' '0'-'9' '_' '\'' ]*) as s { UIDENT s } 61 | -------------------------------------------------------------------------------- /lang/affe/multiplicity.ml: -------------------------------------------------------------------------------- 1 | open Types 2 | open Use 3 | 4 | type t = Use.t Name.Map.t 5 | let empty = Name.Map.empty 6 | let var x k = Name.Map.singleton x (Normal [k]) 7 | let borrow x r k = Name.Map.singleton x (Borrow (r, [k])) 8 | 9 | exception Fail of Name.t * Use.t * Use.t 10 | exception FailRegion of Name.t * Use.t 11 | let fail n u1 u2 = raise (Fail (n, u1, u2)) 12 | 13 | let constr_all_kinds ~bound ks = 14 | List.map (fun k -> Constraint.(k <= bound)) ks 15 | 16 | let merge (e1 : t) (e2 : t) = 17 | let constr = ref [] in 18 | let bound = Kinds.un Never in 19 | let constr_kinds ks = 20 | constr := (constr_all_kinds ~bound ks) @ !constr 21 | in 22 | let aux x u1 u2 = match u1, u2 with 23 | | Shadow _, u -> Some u 24 | | Borrow (Immutable, k1), Borrow (Immutable, k2) 25 | -> 26 | Some (Borrow (Immutable, k1@k2)) 27 | | Normal l1, Normal l2 -> 28 | let l = l1 @ l2 in 29 | constr_kinds l ; 30 | Some (Normal l) 31 | | Borrow _, Borrow _ 32 | | _, Shadow _ 33 | | Borrow _, Normal _ 34 | | Normal _, Borrow _ -> fail x u1 u2 35 | in 36 | let m = Name.Map.union aux e1 e2 in 37 | m, Constraint.cand !constr 38 | 39 | let parallel_merge (e1 : t) (e2 : t) = 40 | (* let constr = ref [] in 41 | * let constr_kinds ~bound ks = 42 | * constr := (constr_all_kinds ~bound ks) @ !constr 43 | * in *) 44 | let aux x u1 u2 = match u1, u2 with 45 | | Shadow r1, Shadow r2 -> 46 | Some (Shadow (Borrow.max r1 r2)) 47 | | Shadow r', Borrow (r,l) 48 | | Borrow (r, l), Shadow r' 49 | -> 50 | (* constr_kinds ~bound:(Aff Never) l ; *) 51 | Some (Borrow (Borrow.max r r', l)) 52 | | Borrow (Immutable as r, k1), Borrow (Immutable, k2) 53 | | Borrow (Mutable as r, k1), Borrow (Mutable, k2) 54 | -> 55 | Some (Borrow (r, k1@k2)) 56 | | Normal l1, Normal l2 -> 57 | let l = l1 @ l2 in 58 | Some (Normal l) 59 | | Shadow _, Normal l 60 | | Normal l, Shadow _ 61 | -> 62 | (* constr_kinds ~bound:(Aff Never) l ; *) 63 | Some (Normal l) 64 | | Borrow _, Borrow _ 65 | | Borrow _, Normal _ 66 | | Normal _, Borrow _ -> fail x u1 u2 67 | in 68 | let m = Name.Map.union aux e1 e2 in 69 | m, Constraint.ctrue 70 | 71 | let constraint_all (e : t) bound : constr = 72 | let aux _ ks l = match ks with 73 | | Normal ks -> constr_all_kinds ~bound ks @ l 74 | | Borrow _ | Shadow _ -> [] 75 | in 76 | let l = Name.Map.fold aux e [] in 77 | Constraint.cand l 78 | 79 | let bound_all_kinds (l,h) ks = 80 | CCList.flat_map 81 | (fun k -> Constraint.[l <= k; k <= h]) 82 | ks 83 | let exit_region bounded_vars region_level (m0 : t) = 84 | let constr = ref [] in 85 | let constr_kinds ks f = 86 | constr := 87 | (bound_all_kinds 88 | (f @@ Kinds.Region.Region region_level, f @@ Kinds.Region.Never) ks) 89 | @ !constr 90 | in 91 | let f var _ m = Name.Map.update var (function 92 | | None -> None 93 | | Some Borrow (Mutable, ks) -> 94 | constr_kinds ks (fun r -> Kinds.constant @@ Aff r); 95 | Some (Shadow Mutable) 96 | | Some Borrow (Immutable, ks) -> 97 | constr_kinds ks (fun r -> Kinds.constant @@ Un r); 98 | Some (Shadow Immutable) 99 | | Some b -> (* raise (FailRegion (var,b))) *) Some b) 100 | m 101 | in 102 | let m' = Name.Map.fold f bounded_vars m0 in 103 | m', Constraint.cand !constr 104 | 105 | let exit_binder (e : t) x k : constr * t = 106 | let constr = match Name.Map.find_opt x e with 107 | | Some Shadow _ 108 | | Some Borrow _ 109 | | Some Normal [_] 110 | -> Constraint.ctrue 111 | | None | Some Normal [] | Some Normal _ -> 112 | Constraint.(k <= Kinds.constant @@ Aff Never) 113 | in 114 | constr, Name.Map.remove x e 115 | -------------------------------------------------------------------------------- /lang/affe/name.ml: -------------------------------------------------------------------------------- 1 | module M = struct 2 | type t = {name : string option ; id : int} 3 | let hash x = Hashtbl.hash x.id 4 | let compare n1 n2 = compare n1.id n2.id 5 | let equal n1 n2 = n1.id = n2.id 6 | let dummy name = { name = Some name ; id = -1 } 7 | let create = 8 | let r = ref 0 in 9 | fun ?name () -> 10 | let id = !r in incr r ; 11 | { name ; id } 12 | end 13 | include M 14 | module Map = CCMap.Make(M) 15 | module Set = CCSet.Make(M) 16 | module Tbl = CCHashtbl.Make(M) 17 | -------------------------------------------------------------------------------- /lang/affe/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | 4 | let mk_lambda l body = List.fold_right (fun n e -> Lambda (n, e)) l body 5 | let mk_let r name args e1 e2 = 6 | let e1 = match args with [] -> e1 | l -> mk_lambda l e1 in 7 | Let (r, PVar name, e1, e2) 8 | let mk_decl rec_flag name args e = 9 | let expr = match args with [] -> e | l -> mk_lambda l e in 10 | ValueDecl {rec_flag; name; expr} 11 | 12 | let mk_binop op a b : expr = App (op, [a;b]) 13 | 14 | let mk_var s : expr = Var (Name.dummy s) 15 | let mk_get a i : expr = App (mk_var "array_get", [Tuple [a;i]]) 16 | let mk_set a i x : expr = App (mk_var "array_set", [Tuple [a;i;x]]) 17 | %} 18 | 19 | %token EOF SEMISEMI 20 | %token YTOK 21 | %token IDENT 22 | %token TYIDENT 23 | %token UIDENT 24 | %token INT 25 | %token STRING 26 | %token UN AFF LIN 27 | %token UNDERSCORE 28 | %token DOT 29 | %token STAR DIV 30 | %token EQUAL PLUS MINUS 31 | %token LPAREN RPAREN 32 | %token LACCO RACCO 33 | %token LBRACKPIPE PIPERBRACK 34 | %token LET IN REC 35 | %token MATCH 36 | %token SEMI 37 | %token BAR 38 | %token TYPE VAL WITH IMPORT 39 | %token RIGHTARROW LEFTARROW FUN BIGRIGHTARROW 40 | %token COMMA DOUBLECOLON OF 41 | %token LESS GREATER 42 | %token DASHLACCO RACCOGREATER 43 | %token AND 44 | %token PERCENT 45 | %token ANDBANG 46 | %token FORALL 47 | 48 | %nonassoc IN 49 | %nonassoc LEFTARROW 50 | %right SEMI 51 | %right RIGHTARROW DASHLACCO RACCOGREATER 52 | %nonassoc FUN 53 | /* %left FUNAPP */ 54 | %left PLUS MINUS 55 | %right STAR DIV 56 | %nonassoc LESS GREATER EQUAL 57 | /* %nonassoc below_DOT */ 58 | /* %nonassoc DOT */ 59 | %nonassoc 60 | /* AND ANDBANG INT */ IDENT /* UIDENT LPAREN LACCO LBRACKPIPE YTOK ALLOC */ 61 | 62 | %start file 63 | %type file 64 | 65 | %start toplevel 66 | %type toplevel 67 | 68 | %type expr 69 | %% 70 | file: list(command) EOF { $1 } 71 | toplevel: command SEMISEMI { $1 } 72 | 73 | command: 74 | | LET r=rec_flag name=name args=list(simple_pattern) EQUAL expr=expr 75 | { mk_decl r name args expr } 76 | | VAL name=name DOUBLECOLON typ=type_scheme 77 | { ValueDef { name ; typ } } 78 | | typdecl=type_decl { typdecl } 79 | | IMPORT s = STRING { Import s } 80 | 81 | 82 | expr: 83 | | e=simple_expr /* %prec below_DOT */ 84 | { e } 85 | | e1=expr SEMI e2=expr 86 | { Sequence (e1, e2) } 87 | | f=simple_expr l=list_expr /* %prec FUNAPP */ 88 | { App (f,List.rev l) } 89 | | e1=expr op=binop e2=expr 90 | { mk_binop op e1 e2 } 91 | | LET r=rec_flag name=name args=nonempty_list(simple_pattern) EQUAL e1=expr IN e2=expr 92 | { mk_let r name args e1 e2 } 93 | | LET p=pattern EQUAL e1=expr IN e2=expr 94 | { Let (NonRec, p, e1, e2) } 95 | | b=MATCH e=expr WITH LACCO l=cases RACCO 96 | { Match (b,e, l) } 97 | | FUN l=list(simple_pattern) RIGHTARROW body=expr 98 | { mk_lambda l body } 99 | | s=simple_expr DOT LPAREN i=expr RPAREN LEFTARROW e=expr 100 | { mk_set s i e } 101 | 102 | simple_expr: 103 | | c=constant { Constant c } 104 | | name=uname { Constructor (name) } 105 | | name=name { Var name } 106 | | LPAREN RPAREN { Builtin.unit } 107 | | LPAREN l=separated_nonempty_list(COMMA,expr) RPAREN 108 | { match l with 109 | | [e] -> e 110 | | l -> Tuple l 111 | } 112 | | LACCO e=expr RACCO { Region (Name.Map.empty, e) } 113 | | LBRACKPIPE l=separated_list(SEMI, simple_expr) PIPERBRACK { Array l } 114 | | b=borrow name=name { Borrow (b, name) } 115 | | AND b=borrow name=name { ReBorrow (b, name) } 116 | | s=simple_expr DOT LPAREN i=expr RPAREN { mk_get s i } 117 | 118 | cases: ioption(BAR) l=separated_nonempty_list(BAR, case) { l } 119 | case: 120 | p=pattern RIGHTARROW e=expr { p,e } 121 | 122 | %inline binop: 123 | | PLUS {Constant (Primitive "+")} 124 | | MINUS {Constant (Primitive "-")} 125 | | STAR {Constant (Primitive "*")} 126 | | DIV {Constant (Primitive "/")} 127 | | LESS {Constant (Primitive ">")} 128 | | GREATER {Constant (Primitive "<")} 129 | | EQUAL {Constant (Primitive "=")} 130 | 131 | %inline rec_flag: 132 | | { NonRec } 133 | | REC { Rec } 134 | 135 | pattern: 136 | | p=simple_pattern { p } 137 | | constr=uname p=pattern { PConstr (constr, Some p) } 138 | 139 | simple_pattern: 140 | | v=name { PVar v } 141 | | UNDERSCORE { PAny } 142 | | LPAREN RPAREN { PUnit } 143 | | constr=uname { PConstr (constr, None) } 144 | | LPAREN p=pattern RPAREN { p } 145 | | LPAREN l=separated_nontrivial_llist(COMMA,pattern) RPAREN { PTuple l } 146 | 147 | %inline borrow: 148 | | AND { Immutable } 149 | | ANDBANG { Mutable } 150 | 151 | list_expr: 152 | | simple_expr { [$1] } 153 | | list_expr simple_expr { $2 :: $1 } 154 | 155 | constant: 156 | | i=INT { Int i } 157 | | PERCENT s=IDENT { Primitive s } 158 | | YTOK { Y } 159 | 160 | name: 161 | | name=IDENT { Name.dummy name } 162 | uname: 163 | | name=UIDENT { Name.dummy name } 164 | type_var: 165 | | name=TYIDENT { Name.dummy name } 166 | kind_var: 167 | | name=TYIDENT { Name.dummy name } 168 | 169 | type_decl: 170 | | TYPE 171 | params=type_var_bindings name=name kind=kind_annot 172 | constructor=maybe_constructors constraints=maybe_constraints 173 | { TypeDecl {name; params; constructor ; constraints ; kind} } 174 | 175 | maybe_constructors: 176 | | { [] } 177 | | EQUAL option(BAR) l=separated_list(BAR, constructor_decl) 178 | { l } 179 | constructor_decl: 180 | name=uname OF e=type_expr_with_constraint 181 | { let constraints, typ = e in 182 | {T. name; constraints; typ} 183 | } 184 | 185 | maybe_constraints: 186 | | { C.ctrue } 187 | | WITH c=constraints { c } 188 | 189 | type_scheme: 190 | | p=param_list 191 | e=type_expr_with_constraint 192 | { let kvars, tyvars = p in 193 | let constraints, typ = e in 194 | {T. kvars; tyvars; constraints; typ} 195 | } 196 | 197 | %inline param_list: 198 | | { [], [] } 199 | | FORALL kparams=list(kind_var) params=list(type_quantifier) DOT { kparams, params} 200 | 201 | type_expr_with_constraint: 202 | | t=type_expr { (C.ctrue, t) } 203 | | c=constraints BIGRIGHTARROW t=type_expr { (c, t) } 204 | 205 | type_expr: 206 | | t=simple_type_expr { t } 207 | | l=separated_nontrivial_llist(STAR, simple_type_expr) { T.Tuple l } 208 | | t1=type_expr k=arrow t2=type_expr { T.Arrow (t1, k, t2) } 209 | simple_type_expr: 210 | | t=simple_type_expr_no_paren { t } 211 | | LPAREN e=type_expr RPAREN %prec FUN 212 | { e } 213 | simple_type_expr_no_paren: 214 | | n=type_var { T.Var n } 215 | | n=name { T.App (n, []) } 216 | | t=simple_type_expr n=name { T.App (n, [t]) } 217 | | b=borrow LPAREN k=kind_expr COMMA t=type_expr RPAREN 218 | { T.Borrow (b,k,t) } 219 | | LPAREN p=type_list RPAREN n=name 220 | { T.App (n, p) } 221 | 222 | %inline type_list: 223 | tys = inline_reversed_separated_nonempty_llist(COMMA, type_expr) { List.rev tys } 224 | 225 | %inline arrow: 226 | | RIGHTARROW { K.Un } 227 | | DASHLACCO k=kind_expr RACCOGREATER { k } 228 | 229 | kind_annot: 230 | | { K.Unknown } 231 | | DOUBLECOLON k=kind_expr { k } 232 | 233 | kind_expr: 234 | | n=kind_var { K.KVar n } 235 | | UN { K.Un } 236 | | AFF { K.Aff } 237 | | LIN { K.Lin } 238 | | UNDERSCORE { K.Unknown } 239 | 240 | constraints: l=separated_nonempty_list (COMMA, constr) { C.And l } 241 | constr: 242 | | k1=kind_expr LESS k2=kind_expr { C.KindLEq (k1, k2) } 243 | | k1=kind_expr GREATER k2=kind_expr { C.KindLEq (k2, k1) } 244 | | t=type_expr DOUBLECOLON k=kind_expr { C.HasKind (t, k) } 245 | 246 | type_quantifier: 247 | | LPAREN t=type_var_binding RPAREN {t} 248 | 249 | type_var_bindings: 250 | | { [] } 251 | | LPAREN 252 | l=inline_reversed_separated_nonempty_llist(COMMA,type_var_binding) 253 | RPAREN 254 | { List.rev l } 255 | type_var_binding: 256 | | ty=type_var DOUBLECOLON k=kind_expr { (ty, k) } 257 | 258 | 259 | (* Generic parsing rules *) 260 | 261 | reversed_separated_nonempty_llist(separator, X): 262 | xs = inline_reversed_separated_nonempty_llist(separator, X) { xs } 263 | 264 | %inline inline_reversed_separated_nonempty_llist(separator, X): 265 | x = X 266 | { [ x ] } 267 | | xs = reversed_separated_nonempty_llist(separator, X) 268 | separator 269 | x = X 270 | { x :: xs } 271 | 272 | reversed_separated_nontrivial_llist(separator, X): 273 | xs = reversed_separated_nontrivial_llist(separator, X) 274 | separator 275 | x = X 276 | { x :: xs } 277 | | x1 = X 278 | separator 279 | x2 = X 280 | { [ x2; x1 ] } 281 | 282 | %inline separated_nontrivial_llist(separator, X): 283 | xs = rev(reversed_separated_nontrivial_llist(separator, X)) 284 | { xs } 285 | -------------------------------------------------------------------------------- /lang/affe/printer.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | module T = Types 3 | 4 | let debug = ref false 5 | 6 | let bold = 7 | if !debug then 8 | fun fmt s -> Format.fprintf fmt "@<0>%s%s@<0>%s" "\027[1m" s "\027[0m" 9 | else 10 | Fmt.string 11 | 12 | let constant fmt = function 13 | | Int i -> Format.pp_print_int fmt i 14 | | Primitive s -> Fmt.pf fmt "%%%a" bold s 15 | | Y -> bold fmt "Y" 16 | 17 | let indice_array = [|"₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"|] 18 | let rec digits fmt i = 19 | if i < 0 then 20 | Format.pp_print_string fmt "₋" 21 | else if i < 10 then 22 | Format.pp_print_string fmt indice_array.(i) 23 | else begin 24 | digits fmt (i/10) ; 25 | Format.pp_print_string fmt indice_array.(i mod 10) 26 | end 27 | 28 | let name_with_digits fmt {Name. name ; id } = 29 | Format.fprintf fmt "%s%a" (CCOpt.get_or ~default:"" name) digits id 30 | let name_no_digits fmt {Name. name ; _ } = 31 | Format.fprintf fmt "%s" (CCOpt.get_or ~default:"" name) 32 | 33 | let name = if !debug then name_with_digits else name_no_digits 34 | 35 | (** Expressions and Patterns *) 36 | 37 | let borrow = function Immutable -> "" | Mutable -> "!" 38 | 39 | let rec pattern fmt = function 40 | | PAny -> Fmt.pf fmt "_" 41 | | PUnit -> Fmt.pf fmt "()" 42 | | PVar n -> name fmt n 43 | | PConstr (constr, None) -> 44 | Format.fprintf fmt "%a" name constr 45 | | PConstr (constr, Some pat) -> 46 | Format.fprintf fmt "%a (%a)" name constr pattern pat 47 | | PTuple l -> 48 | Format.fprintf fmt "@[(@ %a@ )@]" Fmt.(list ~sep:(unit ",@ ") pattern) l 49 | 50 | let binop = [ "+"; "-"; "*"; "/"; "<"; ">"; "=" ] 51 | 52 | let rec expr 53 | = fun fmt -> function 54 | | Constant c -> constant fmt c 55 | | Constructor c -> name fmt c 56 | | Lambda (n,e) -> 57 | Format.fprintf fmt "@[%a %a %a@ %a@]" 58 | bold "fun" 59 | pattern n 60 | bold "->" 61 | expr e 62 | | Array a -> 63 | Format.fprintf fmt "@[[|@ %a@ |]@]" Fmt.(list ~sep:(unit ";@ ") expr) a 64 | | Tuple a -> 65 | Format.fprintf fmt "@[(@ %a@ )@]" Fmt.(list ~sep:(unit ",@ ") expr) a 66 | | App (Constant (Primitive s), [e1; e2]) when List.mem s binop -> 67 | Format.fprintf fmt "@[<2>@[%a@]@ %s @[%a@]@]" 68 | expr_with_paren e1 69 | s 70 | expr_with_paren e2 71 | | Var v -> name fmt v 72 | | Borrow (r,v) -> 73 | Format.fprintf fmt "&%s%a" (borrow r) name v 74 | | ReBorrow (r,v) -> 75 | Format.fprintf fmt "&&%s%a" (borrow r) name v 76 | | App (f,e) -> 77 | Format.fprintf fmt "@[<2>@[%a@]@ %a@]" 78 | expr_with_paren f 79 | Format.(pp_print_list ~pp_sep:pp_print_space expr_with_paren) e 80 | | Let (b,pat,e1,e2) -> 81 | Format.fprintf fmt "@[@[<2>%a %a %a@ %a@]@ %a@ %a@]" 82 | bold (if b = Rec then "let rec" else "let") 83 | pattern pat 84 | bold "=" expr e1 85 | bold "in" expr e2 86 | | Match (b, e, l) -> 87 | let sep = Fmt.cut in 88 | let case fmt (p, e) = 89 | Fmt.pf fmt "@[<2>| %a ->@ %a@]" pattern p expr e 90 | in 91 | let s = match b with 92 | | None -> "" 93 | | Some Immutable -> "&" 94 | | Some Mutable -> "&!" 95 | in 96 | Fmt.pf fmt "@[@[%a@ %a@ %a@]@ %a@]" 97 | bold ("match"^s) expr e bold "in" 98 | (Fmt.list ~sep case) l 99 | | Region (ns, e) -> 100 | let pp fmt () = 101 | Fmt.pf fmt "@[%a|@]@ %a" 102 | Fmt.(iter_bindings ~sep:sp Name.Map.iter (pair name nop)) ns expr e 103 | in 104 | Fmt.braces pp fmt () 105 | | Sequence (e1, e2) -> 106 | Format.fprintf fmt "@[%a;@ %a@]" expr e1 expr e2 107 | 108 | and expr_with_paren fmt x = 109 | let must_have_paren = match x with 110 | | App _ 111 | | Let _ 112 | | Match _ 113 | | Lambda _ 114 | | Sequence _ 115 | -> true 116 | | Constant _ 117 | | Array _ 118 | | Tuple _ 119 | | Constructor _ 120 | | Var _ 121 | | Borrow (_, _) 122 | | ReBorrow (_, _) 123 | | Region _ 124 | -> false 125 | in 126 | Format.fprintf fmt 127 | (if must_have_paren then "@[(%a@])" else "%a") expr x 128 | 129 | (** Types *) 130 | 131 | module UsedNames = CCHashtbl.Make(CCString) 132 | type naming_env = { 133 | tbl : string Name.Tbl.t; 134 | used : int UsedNames.t; 135 | } 136 | let create_naming_env () = { 137 | tbl = Name.Tbl.create 4; 138 | used = UsedNames.create 4; 139 | } 140 | 141 | let fresh_name pool used = 142 | let l = String.length pool in 143 | let rec mk_string i = 144 | if i < l then 145 | pool.[i] :: [] 146 | else 147 | pool.[i mod l] :: mk_string (i / l) 148 | in 149 | let rec try_all i = 150 | let s = CCString.of_list @@ mk_string i in 151 | match UsedNames.find_opt used s with 152 | | Some _ -> try_all (i+1) 153 | | None -> s 154 | in 155 | try_all 0 156 | 157 | let get_print_name env pool n = 158 | match Name.Tbl.find_opt env.tbl n with 159 | | Some n -> n 160 | | None -> 161 | let s = 162 | match n.name with 163 | | None -> 164 | let name = fresh_name pool env.used in 165 | UsedNames.add env.used name 1; 166 | name 167 | | Some name -> 168 | begin match UsedNames.find_opt env.used name with 169 | | None -> 170 | UsedNames.add env.used name 1; 171 | name 172 | | Some i -> 173 | UsedNames.add env.used name (i+1); 174 | name ^ string_of_int i 175 | end 176 | in 177 | Name.Tbl.add env.tbl n s; 178 | s 179 | 180 | let typool = "abcdef" 181 | let tyname ?(unbound=false) env fmt n = 182 | if !debug then 183 | Format.fprintf fmt "^%s%a" (if unbound then "_" else "") 184 | name_with_digits n 185 | else 186 | Format.fprintf fmt "'%s%s" (if unbound then "_" else "") 187 | (get_print_name env typool n) 188 | let kpool = "klmn" 189 | let kname ?(unbound=false) env fmt n = 190 | if !debug then 191 | Format.fprintf fmt "^%s%a" (if unbound then "_" else "") 192 | name_with_digits n 193 | else 194 | Format.fprintf fmt "^%s%s" (if unbound then "_" else "") 195 | (get_print_name env kpool n) 196 | 197 | let region fmt = function 198 | | Kinds.Region.Region i -> digits fmt i 199 | | Never -> Fmt.string fmt "ₙ" 200 | | Global -> () 201 | 202 | let rec kvar 203 | = fun env fmt -> function 204 | | Kinds.Unbound (n,_) -> kname ~unbound:true env fmt n 205 | | Link t -> kind env fmt t 206 | 207 | and kind env fmt = function 208 | | Kinds.Un r -> Format.fprintf fmt "un%a" region r 209 | | Aff r -> Format.fprintf fmt "aff%a" region r 210 | | Lin r -> Format.fprintf fmt "lin%a" region r 211 | | Var { contents = x } -> kvar env fmt x 212 | | GenericVar n -> kname env fmt n 213 | 214 | let use env fmt (u : Types.Use.t) = match u with 215 | | Shadow _ -> Fmt.pf fmt "Shadow" 216 | | Borrow (b, ks) -> Fmt.pf fmt "&%s(%a)" (borrow b) (Fmt.list @@ kind env) ks 217 | | Normal ks -> Fmt.pf fmt "Use(%a)" (Fmt.list @@ kind env) ks 218 | 219 | let rec tyvar 220 | = fun env fmt -> function 221 | | T.Unbound (n,_) -> tyname ~unbound:true env fmt n 222 | | T.Link t -> typ_with_paren env fmt t 223 | 224 | and typ 225 | = fun env fmt -> function 226 | | T.Borrow (r, k, t) -> 227 | Format.fprintf fmt "&%s(%a,%a)" (borrow r) (kind env) k (typ env) t 228 | | T.Tuple l -> 229 | let pp_sep fmt () = Format.fprintf fmt " *@ " in 230 | Format.fprintf fmt "@[<2>%a@]" 231 | (Format.pp_print_list ~pp_sep @@ typ env) l 232 | | T.App (f,[]) -> 233 | name fmt f 234 | | T.App (f,[e]) -> 235 | Format.fprintf fmt "@[<2>%a@ %a@]" (typ env) e name f 236 | | T.App (f,e) -> 237 | let pp_sep fmt () = Format.fprintf fmt ",@ " in 238 | Format.fprintf fmt "@[<2>(%a)@ %a@]" 239 | (Format.pp_print_list ~pp_sep @@ typ env) e name f 240 | | T.Arrow (a, Un Global,b) -> 241 | Format.fprintf fmt "%a -> %a" (typ_with_paren env) a (typ env) b 242 | | T.Arrow (a,k,b) -> 243 | Format.fprintf fmt "%a -{%a}> %a" 244 | (typ_with_paren env) a (kind env) k (typ env) b 245 | | T.Var { contents = x } -> tyvar env fmt x 246 | | T.GenericVar n -> tyname env fmt n 247 | 248 | and typ_with_paren env fmt x = 249 | let must_have_paren = match x with 250 | | T.Arrow _ -> true 251 | | _ -> false 252 | in 253 | Format.fprintf fmt 254 | (if must_have_paren then "@[(%a@])" else "%a") (typ env) x 255 | 256 | (** Constraints *) 257 | 258 | 259 | let rec flatten' = function 260 | | T.And l -> flattenL l 261 | | c -> [c] 262 | and flattenL l = CCList.flat_map flatten' l 263 | 264 | let rec constrs env fmt (x: Types.normalized_constr) = match x with 265 | | KindLeq (k1, k2) -> 266 | Format.fprintf fmt "(%a < %a)" (kind env) k1 (kind env) k2 267 | | HasKind (_, ty, k) -> 268 | Format.fprintf fmt "(%a : %a)" (typ env) ty (kind env) k 269 | | And l -> 270 | let l = flattenL l in 271 | let pp_sep fmt () = Format.fprintf fmt " &@ " in 272 | Format.fprintf fmt "%a" Format.(pp_print_list ~pp_sep @@ constrs env) l 273 | 274 | (** Schemes *) 275 | 276 | let kscheme fmt {T. constr = c ; kvars ; args ; kind = k } = 277 | let env = create_naming_env () in 278 | let pp_sep fmt () = Format.fprintf fmt ", " in 279 | let pp_arrow fmt () = Format.fprintf fmt "@ ->@ " in 280 | Format.pp_open_box fmt 2 ; 281 | begin 282 | if kvars <> [] then 283 | Format.fprintf fmt "∀%a.@ " 284 | Format.(pp_print_list ~pp_sep @@ kname ~unbound:false env) kvars 285 | end; 286 | begin 287 | if c <> T.And [] then 288 | Format.fprintf fmt "%a =>@ " (constrs env) c 289 | end; 290 | Format.fprintf fmt "%a" 291 | Format.(pp_print_list ~pp_sep:pp_arrow @@ kind env) (args@[k]); 292 | Format.pp_close_box fmt (); 293 | () 294 | 295 | and scheme fmt {T. constr = c ; tyvars ; kvars ; ty } = 296 | let env = create_naming_env () in 297 | let pp_sep fmt () = Format.fprintf fmt ",@ " in 298 | Format.pp_open_box fmt 0 ; 299 | begin 300 | let has_kinds = not @@ CCList.is_empty kvars in 301 | let has_types = not @@ CCList.is_empty tyvars in 302 | if has_kinds || has_types then begin 303 | Fmt.pf fmt "∀@["; 304 | Format.(pp_print_list ~pp_sep (kname ~unbound:false env)) fmt kvars ; 305 | if has_kinds && has_types then pp_sep fmt () ; 306 | Format.(pp_print_list ~pp_sep (tyname ~unbound:false env)) fmt tyvars; 307 | Fmt.pf fmt "@].@ "; 308 | end; 309 | end; 310 | begin 311 | if c <> T.And [] then 312 | Format.fprintf fmt "@[%a@] =>@ " (constrs env) c 313 | end; 314 | Fmt.box (typ env) fmt ty; 315 | Format.pp_close_box fmt (); 316 | () 317 | 318 | let env fmt env = 319 | let print_env pp_key pp_val fmt e = 320 | Format.pp_print_list 321 | ~pp_sep:Format.pp_print_cut 322 | (fun fmt (k,ty) -> 323 | Format.fprintf fmt "%a: %a" pp_key k pp_val ty) 324 | fmt 325 | @@ Name.Map.bindings e 326 | in 327 | let print_env prefix pp_key pp_val fmt e = 328 | if Name.Map.is_empty e then () else 329 | Format.fprintf fmt "%s:@;<1 2>@[%a@]@." 330 | prefix (print_env pp_key pp_val) e 331 | in 332 | Format.fprintf fmt "%a%a%a" 333 | (print_env "Variables:" name scheme) env.Env.vars 334 | (print_env "Type Constructors:" name kscheme) env.Env.constr 335 | -------------------------------------------------------------------------------- /lang/affe/region.ml: -------------------------------------------------------------------------------- 1 | (** Automatic region annotation *) 2 | 3 | open Syntax 4 | module S = Name.Set 5 | module M = Name.Map 6 | 7 | type use = 8 | | Borrow of borrow 9 | | Shadow of borrow 10 | | Full 11 | 12 | let get_borrows m = 13 | M.fold (fun k v m -> match v with 14 | | Borrow b -> M.add k b m 15 | | Full | Shadow _ -> m 16 | ) m M.empty 17 | let region ns e = 18 | let m = get_borrows ns in 19 | if M.is_empty m then e else Region (m, e) 20 | 21 | let get_vars m = M.keys m |> S.of_iter 22 | let add_opt m k b = match b with 23 | | None -> m 24 | | Some v -> M.add k v m 25 | let update_all f m = 26 | M.fold (fun k v m -> match f k (Some v) with 27 | | None -> m 28 | | Some v' -> M.add k v' m 29 | ) m M.empty 30 | 31 | let rec vars_in_pattern (p : pattern) = match p with 32 | | PUnit | PAny -> S.empty 33 | | PVar v -> S.singleton v 34 | | PConstr (_, None) -> S.empty 35 | | PConstr (_, Some p) -> vars_in_pattern p 36 | | PTuple l -> 37 | List.fold_left (fun s p -> S.union s @@ vars_in_pattern p) S.empty l 38 | 39 | let mergeL l = 40 | let classify (state : 'a) i e : 'a = match state, e with 41 | | `None, None -> `None 42 | | `None, Some (Borrow Immutable | Shadow Immutable) -> `Immutable 43 | | `Immutable, 44 | (None | Some (Borrow Immutable | Shadow Immutable)) 45 | -> `Immutable 46 | | (`None | `Immutable), 47 | Some (Borrow Mutable | Shadow Mutable) 48 | -> `OneMutable i 49 | | `OneMutable i, None -> `OneMutable i 50 | | `OneMutable _, Some _ -> `Many 51 | | `Many, _ -> `Many 52 | | `Full, _ | _, Some Full -> `Full 53 | in 54 | let get_status k = 55 | let l = Iter.map (M.find_opt k) @@ Iter.of_list l in 56 | Iter.foldi classify `None l 57 | in 58 | let all_vars = List.fold_left S.union S.empty @@ List.map get_vars l in 59 | let status = S.fold (fun k m -> M.add k (get_status k) m) all_vars M.empty in 60 | let final_vars = 61 | M.fold (fun k b m -> match b with 62 | | `None -> m 63 | | `Immutable -> M.add k (Borrow Immutable) m 64 | | `OneMutable _ -> M.add k (Borrow Mutable) m 65 | | `Full -> M.add k Full m 66 | | `Many -> m 67 | ) status M.empty 68 | in 69 | let update_one i k b = 70 | match M.find k status, b with 71 | | _, None -> None 72 | | `None, b -> b 73 | | `Immutable, 74 | Some (Borrow Immutable | Shadow Immutable) 75 | -> None 76 | | `Immutable, 77 | Some (Borrow Mutable | Shadow Mutable | Full) 78 | -> assert false 79 | | `OneMutable _, Some (Shadow Mutable) -> None 80 | | `OneMutable j, b -> 81 | if i < j then b 82 | else if i = j then None 83 | else assert false 84 | | `Many, Some Shadow _ -> None 85 | | `Many, b -> b 86 | | `Full, Some Full -> None 87 | | `Full, Some Shadow _ -> None 88 | | `Full, b -> b 89 | in 90 | let update_all i (e, m) = region (update_all (update_one i) m) e in 91 | final_vars, update_all 92 | 93 | let get_vars vars1 vars2 = 94 | let f b1 b2 = match b1, b2 with 95 | | None, b | b, None -> 96 | None, b, None 97 | | Some Full, _ -> 98 | None, b1, b2 99 | | _, Some Full -> 100 | b1, b2, None 101 | | Some Borrow Immutable, Some Borrow Immutable 102 | | Some Shadow Immutable, Some Borrow Immutable 103 | | Some Borrow Immutable, Some Shadow Immutable 104 | -> None, Some (Borrow Immutable), None 105 | | Some Shadow Immutable, Some Shadow Immutable 106 | -> None, Some (Shadow Immutable), None 107 | | Some Borrow Immutable, Some (Borrow Mutable | Shadow Mutable) -> 108 | b1, b2, None 109 | | Some (Borrow Mutable | Shadow Mutable), Some Borrow Immutable -> 110 | None, b1, b2 111 | | Some Shadow Immutable, (Some (Borrow Mutable | Shadow Mutable) as b) 112 | | (Some (Borrow Mutable | Shadow Mutable) as b), Some Shadow Immutable 113 | -> None, b, None 114 | | Some Shadow Mutable, Some Shadow Mutable 115 | -> None, b1, None 116 | | Some Borrow Mutable, _ 117 | | _, Some Borrow Mutable 118 | -> b1, Some (Shadow Mutable), b2 119 | in 120 | let all_vars = S.union (get_vars vars1) (get_vars vars2) in 121 | S.fold (fun k (ml, mc, mr) -> 122 | let bl, bc, br = f (M.find_opt k vars1) (M.find_opt k vars2) in 123 | add_opt ml k bl, add_opt mc k bc, add_opt mr k br 124 | ) 125 | all_vars 126 | (M.empty, M.empty, M.empty) 127 | 128 | let merge2 (e1, vars1) (e2, vars2) = 129 | let vars1, vars, vars2 = get_vars vars1 vars2 in 130 | let e1 = region vars1 e1 in 131 | let e2 = region vars2 e2 in 132 | e1, vars, e2 133 | 134 | let mergeCase (e1, vars1) aCases = 135 | (* TODO: This is not as careful as it should be, we should 136 | treat the case where case disagree on borrow specially *) 137 | let f _ b1 b2 = match b1, b2 with 138 | | Full, _ | _, Full -> Some Full 139 | | Borrow b1, Borrow b2 -> Some (Borrow (Types.Borrow.max b1 b2)) 140 | | Shadow b1, Shadow b2 -> Some (Shadow (Types.Borrow.max b1 b2)) 141 | | Shadow Mutable, Borrow _ | Borrow _, Shadow Mutable 142 | -> Some (Borrow Mutable) 143 | | Borrow b, Shadow Immutable | Shadow Immutable, Borrow b 144 | -> Some (Borrow b) 145 | in 146 | let cases, vars2 = 147 | let on_cases (cases, vars) (p,e,vars') = 148 | (p,e)::cases, M.union f vars vars' 149 | in 150 | List.fold_left on_cases ([],M.empty) aCases 151 | in 152 | let vars1, vars, vars2 = get_vars vars1 vars2 in 153 | let e1 = region vars1 e1 in 154 | let cases = List.map (fun (p,e) -> (p, region vars2 e)) cases in 155 | e1, vars, cases 156 | 157 | 158 | let foldAccumInt i0 f l0 = 159 | let _, l = List.fold_left (fun (i,l) a -> i+1, (f i a :: l)) (i0, []) l0 in 160 | List.rev l 161 | 162 | let rec annotate (e0 : expr) = match e0 with 163 | | Constant _ 164 | | Constructor _ 165 | -> 166 | e0, M.empty 167 | | Var x -> 168 | e0, M.singleton x Full 169 | | Borrow (b, x) 170 | | ReBorrow (b, x) -> 171 | e0, M.singleton x (Borrow b) 172 | | Lambda (pat , e) -> 173 | let e, vars = annotate_with_pat pat e in 174 | Lambda (pat, e), vars 175 | | Let (recflag, pat, e1, e2) -> 176 | let a1 = annotate e1 in 177 | let a2 = annotate_with_pat pat e2 in 178 | let e1, vars, e2 = merge2 a1 a2 in 179 | Let (recflag, pat, e1, e2), vars 180 | | Sequence (e1, e2) -> 181 | let a1 = annotate e1 in 182 | let a2 = annotate e2 in 183 | let e1, vars, e2 = merge2 a1 a2 in 184 | Sequence (e1, e2), vars 185 | | App (e, l) -> 186 | let e, vars = annotate e in 187 | let al = List.map annotate l in 188 | let final_vars, aux = mergeL (vars:: List.map snd al) in 189 | let e = aux 0 (e, vars) in 190 | let l = foldAccumInt 1 aux al in 191 | App (e, l), final_vars 192 | | Array l -> 193 | let al = List.map annotate l in 194 | let final_vars, aux = mergeL (List.map snd al) in 195 | let l = foldAccumInt 0 aux al in 196 | Array l, final_vars 197 | | Tuple l -> 198 | let al = List.map annotate l in 199 | let final_vars, aux = mergeL (List.map snd al) in 200 | let l = foldAccumInt 0 aux al in 201 | Tuple l, final_vars 202 | | Region (_orig_vars, e) -> 203 | (* assert (M.is_empty _orig_vars); *) 204 | let e, vars = annotate e in 205 | region vars e, M.empty 206 | | Match (spec, e, cases) -> 207 | let a = annotate e in 208 | let a_cases = 209 | let on_cases (p,e) = 210 | let e, vars' = annotate_with_pat p e in (p,e,vars') 211 | in 212 | List.map on_cases cases 213 | in 214 | let e, vars, cases = mergeCase a a_cases in 215 | Match (spec, e, cases), vars 216 | 217 | and annotate_with_pat pat e = 218 | let e, vars = annotate e in 219 | let bset = vars_in_pattern pat in 220 | let is_bound k _ = S.mem k bset in 221 | let bound_vars, unbound_vars = M.partition is_bound vars in 222 | let e = region bound_vars e in 223 | e, unbound_vars 224 | 225 | let annotate_command (c : command) = match c with 226 | | ValueDecl { rec_flag; name; expr } -> 227 | let expr, vars = annotate expr in 228 | let expr = region vars expr in 229 | ValueDecl { rec_flag; name; expr } 230 | | TypeDecl _ 231 | | ValueDef _ 232 | | Import _ 233 | -> c 234 | 235 | -------------------------------------------------------------------------------- /lang/affe/syntax.ml: -------------------------------------------------------------------------------- 1 | type constant = 2 | | Int of int 3 | | Primitive of string 4 | | Y 5 | 6 | type borrow = Immutable | Mutable 7 | 8 | type match_spec = borrow option 9 | 10 | type rec_flag = 11 | | Rec 12 | | NonRec 13 | 14 | type pattern = 15 | | PUnit 16 | | PAny 17 | | PVar of Name.t 18 | | PConstr of Name.t * pattern option 19 | | PTuple of pattern list 20 | 21 | type lambda = pattern * expr 22 | 23 | and expr = 24 | | Constant of constant 25 | | Lambda of lambda 26 | | Array of expr list 27 | | Constructor of Name.t 28 | | Var of Name.t 29 | | Borrow of borrow * Name.t 30 | | ReBorrow of borrow * Name.t 31 | | App of expr * expr list 32 | | Let of rec_flag * pattern * expr * expr 33 | | Match of match_spec * expr * lambda list 34 | | Region of borrow Name.Map.t * expr 35 | | Tuple of expr list 36 | | Sequence of expr * expr 37 | 38 | type kind = 39 | | Unknown 40 | | Un | Aff | Lin 41 | | KVar of Name.t 42 | 43 | and constraints = 44 | | KindLEq of kind * kind 45 | | HasKind of typ * kind 46 | | And of constraints list 47 | 48 | and typ = 49 | | App of Name.t * typ list 50 | | Arrow of typ * kind * typ 51 | | Tuple of typ list 52 | | Var of Name.t 53 | | Borrow of borrow * kind * typ 54 | 55 | module C = struct 56 | 57 | type t = constraints = 58 | | KindLEq of kind * kind 59 | | HasKind of typ * kind 60 | | And of constraints list 61 | 62 | let ctrue : t = And [] 63 | end 64 | 65 | module K = struct 66 | 67 | type t = kind = 68 | | Unknown 69 | | Un | Aff | Lin 70 | | KVar of Name.t 71 | 72 | type scheme = { 73 | kvars : Name.t list ; 74 | constraints : C.t ; 75 | params : kind list ; 76 | kind : kind ; 77 | } 78 | end 79 | 80 | module T = struct 81 | 82 | type t = typ = 83 | | App of Name.t * typ list 84 | | Arrow of typ * kind * typ 85 | | Tuple of typ list 86 | | Var of Name.t 87 | | Borrow of borrow * kind * typ 88 | 89 | type scheme = { 90 | kvars : Name.t list ; 91 | tyvars : (Name.t * K.t) list ; 92 | constraints : constraints ; 93 | typ : typ ; 94 | } 95 | 96 | type constructor = { 97 | name : Name.t ; 98 | constraints : constraints ; 99 | typ : typ ; 100 | } 101 | 102 | type decl = { 103 | name : Name.t ; 104 | params : (Name.t * kind) list ; 105 | kind : kind ; 106 | constraints : constraints ; 107 | constructor : constructor list ; 108 | } 109 | 110 | end 111 | 112 | type decl = { 113 | rec_flag : rec_flag ; 114 | name : Name.t ; 115 | expr : expr ; 116 | } 117 | 118 | type def = { 119 | name : Name.t ; 120 | typ : T.scheme ; 121 | } 122 | 123 | type command = 124 | | ValueDecl of decl 125 | | TypeDecl of T.decl 126 | | ValueDef of def 127 | | Import of string 128 | 129 | module Rename = struct 130 | [@@@warning "-9"] 131 | 132 | module SMap = Map.Make(String) 133 | 134 | let find x env = 135 | match x with 136 | | None -> Name.create () 137 | | Some x -> 138 | if SMap.mem x env then 139 | SMap.find x env 140 | else 141 | Zoo.error "Unbound variable %s" x 142 | 143 | let add n k env = match n with 144 | | None -> assert false 145 | | Some n -> SMap.add n k env 146 | 147 | let maps env ns = 148 | Name.Map.fold 149 | (fun {name} k m -> Name.Map.add (find name env) k m) 150 | ns Name.Map.empty 151 | 152 | let rec pattern env = function 153 | | PUnit -> env, PUnit 154 | | PAny -> env, PAny 155 | | PVar {name} -> 156 | let new_name = Name.create ?name () in 157 | let env = add name new_name env in 158 | env, PVar new_name 159 | | PConstr (constr, None) -> 160 | let constr = find constr.name env in 161 | env, PConstr (constr, None) 162 | | PConstr (constr, Some p) -> 163 | let constr = find constr.name env in 164 | let env, p = pattern env p in 165 | env, PConstr (constr, Some p) 166 | | PTuple l -> 167 | let env, l = CCList.fold_map pattern env l in 168 | env, PTuple l 169 | 170 | let rec expr env = function 171 | | Lambda (pat, e) -> 172 | let pat, e = lambda env (pat, e) in 173 | Lambda (pat, e) 174 | | Constructor ({name}) -> Constructor (find name env) 175 | | Constant _ as e -> e 176 | | Array l -> Array (List.map (expr env) l) 177 | | Tuple l -> Tuple (List.map (expr env) l) 178 | | Region (ns, e) -> Region (maps env ns, expr env e) 179 | | Var { name } -> Var (find name env) 180 | | Borrow (r, {name}) -> Borrow (r, find name env) 181 | | ReBorrow (r, {name}) -> ReBorrow (r, find name env) 182 | | App (f, l) -> App (expr env f, List.map (expr env) l) 183 | | Let (b, pat, e1, e2) -> 184 | let env', pat = pattern env pat in 185 | let e1 = expr (if b = Rec then env' else env) e1 in 186 | let e2 = expr env' e2 in 187 | Let (b, pat, e1, e2) 188 | | Match (b, e, l) -> 189 | let e = expr env e in 190 | let l = List.map (lambda env) l in 191 | Match (b, e, l) 192 | | Sequence (e1, e2) -> 193 | Sequence (expr env e1, expr env e2) 194 | 195 | and lambda env (pat, e) = 196 | let env, pat = pattern env pat in 197 | let e = expr env e in 198 | (pat, e) 199 | 200 | let rec kind_expr ~kvarenv = function 201 | | K.KVar {name} -> KVar (find name kvarenv) 202 | | Un | Aff | Lin | Unknown as k -> k 203 | and constrs ~kvarenv ~tyenv ~tyvarenv = function 204 | | C.KindLEq (k1, k2) -> 205 | KindLEq (kind_expr ~kvarenv k1, kind_expr ~kvarenv k2) 206 | | HasKind (ty, k) -> 207 | HasKind (type_expr ~kvarenv ~tyenv ~tyvarenv ty, kind_expr ~kvarenv k) 208 | | And l -> And (List.map (constrs ~kvarenv ~tyenv ~tyvarenv) l) 209 | and type_expr ~kvarenv ~tyenv ~tyvarenv = function 210 | | T.Arrow (ty1, k, ty2) -> 211 | Arrow (type_expr ~kvarenv ~tyenv ~tyvarenv ty1, 212 | kind_expr ~kvarenv k, 213 | type_expr ~kvarenv ~tyenv ~tyvarenv ty2) 214 | | App ({name}, args) -> 215 | App (find name tyenv, List.map (type_expr ~kvarenv ~tyenv ~tyvarenv) args) 216 | | Tuple (args) -> 217 | Tuple (List.map (type_expr ~kvarenv ~tyenv ~tyvarenv) args) 218 | | Var {name} -> 219 | Var (find name tyvarenv) 220 | | Borrow (r, k, ty) -> 221 | Borrow (r, kind_expr ~kvarenv k, type_expr ~kvarenv ~tyenv ~tyvarenv ty) 222 | 223 | let add_kind_var kvarenv {Name. name} = 224 | match name with 225 | | Some n when SMap.mem n kvarenv -> 226 | kvarenv, find name kvarenv 227 | | _ -> 228 | let n = Name.create ?name () in 229 | add name n kvarenv, n 230 | let add_kind_expr kvarenv = function 231 | | KVar name -> 232 | let kenv, n = add_kind_var kvarenv name in 233 | kenv, KVar n 234 | | Un | Aff | Lin | Unknown as k -> kvarenv, k 235 | let add_type_param (kvarenv, varenv) (({name} : Name.t), k) = 236 | let kenv, k = add_kind_expr kvarenv k in 237 | let n = Name.create ?name () in 238 | let venv = add name n varenv in 239 | (kenv, venv), (n,k) 240 | 241 | let kind_scheme tyenv {K. kvars; params; constraints; kind } = 242 | let kenv = SMap.empty and tyvarenv = SMap.empty in 243 | let kenv, kvars = CCList.fold_map add_kind_var kenv kvars in 244 | let kvarenv, params = CCList.fold_map add_kind_expr kenv params in 245 | let constraints = constrs ~kvarenv ~tyvarenv ~tyenv constraints in 246 | let kind = kind_expr ~kvarenv kind in 247 | {K. kvars; params; constraints; kind } 248 | 249 | let type_scheme tyenv {T. kvars; tyvars; constraints; typ } = 250 | let kenv = SMap.empty and tyvarenv = SMap.empty in 251 | let kenv, kvars = CCList.fold_map add_kind_var kenv kvars in 252 | let (kvarenv, tyvarenv), tyvars = 253 | CCList.fold_map add_type_param (kenv, tyvarenv) tyvars 254 | in 255 | let constraints = constrs ~kvarenv ~tyvarenv ~tyenv constraints in 256 | let typ = type_expr ~kvarenv ~tyenv ~tyvarenv typ in 257 | {T. kvars; tyvars; constraints; typ} 258 | 259 | let rename_constructor 260 | ~tyenv ~kvarenv ~tyvarenv {T. name = {name}; constraints; typ} = 261 | let name = Name.create ?name () in 262 | let typ = type_expr ~kvarenv ~tyenv ~tyvarenv typ in 263 | let constraints = constrs ~kvarenv ~tyvarenv ~tyenv constraints in 264 | {T. name; constraints; typ} 265 | 266 | type env = { 267 | env : Name.t SMap.t ; 268 | tyenv : Name.t SMap.t ; 269 | } 270 | 271 | let command { env ; tyenv } = function 272 | | ValueDecl { rec_flag; name = {name} ; expr = e } -> 273 | let e = expr env e in 274 | let name = Name.create ?name () in 275 | ValueDecl { rec_flag; name ; expr = e } 276 | | TypeDecl { 277 | name = {name}; params; kind; constraints; constructor; 278 | } -> 279 | let name = Name.create ?name () in 280 | 281 | let kvarenv = SMap.empty and tyvarenv = SMap.empty in 282 | let (kvarenv, tyvarenv), params = 283 | CCList.fold_map add_type_param (kvarenv, tyvarenv) params 284 | in 285 | let constructor = 286 | List.map (rename_constructor ~kvarenv ~tyenv ~tyvarenv) constructor 287 | in 288 | let constraints = constrs ~kvarenv ~tyvarenv ~tyenv constraints in 289 | let kind = kind_expr ~kvarenv kind in 290 | TypeDecl { name ; params ; constructor ; constraints ; kind } 291 | | ValueDef { name = {name} ; typ } -> 292 | let typ = type_scheme tyenv typ in 293 | let name = Name.create ?name () in 294 | ValueDef { name ; typ } 295 | | Import s -> Import s 296 | 297 | end 298 | -------------------------------------------------------------------------------- /lang/affe/transl.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | let transl_kind ~ienv = function 4 | | K.KVar n -> 5 | snd @@ Instantiate.kvar ~ienv n 6 | | Unknown -> snd @@ Types.kind @@ Instantiate.level ienv 7 | | Un -> Un Global 8 | | Aff -> Aff Global 9 | | Lin -> Lin Global 10 | 11 | let rec transl_type ~ienv = function 12 | | T.Var n -> 13 | snd @@ Instantiate.tyvar ~ienv n 14 | | App (t, l) -> 15 | let tyargs = List.map (transl_type ~ienv) l in 16 | App (t, tyargs) 17 | | Tuple l -> 18 | let tyargs = List.map (transl_type ~ienv) l in 19 | Tuple tyargs 20 | | Arrow (t1, k, t2) -> 21 | Arrow (transl_type ~ienv t1, 22 | transl_kind ~ienv k, 23 | transl_type ~ienv t2) 24 | | Borrow (r, k, t) -> 25 | Borrow (r, 26 | transl_kind ~ienv k, 27 | transl_type ~ienv t) 28 | 29 | let rec transl_constr ~ienv = function 30 | | C.KindLEq (k1,k2) -> 31 | Constraint.cleq (transl_kind ~ienv k1) (transl_kind ~ienv k2) 32 | | HasKind (t,k) -> 33 | Constraint.hasKind (transl_type ~ienv t) (transl_kind ~ienv k) 34 | | And l -> 35 | Constraint.cand @@ List.map (transl_constr ~ienv) l 36 | 37 | let transl_params ~ienv params = 38 | let constrs, params = 39 | List.fold_right (fun (var, kind) (constrs, params) -> 40 | let k = transl_kind ~ienv kind in 41 | let var, ty = Instantiate.tyvar ~ienv var in 42 | Constraint.(hasKind ty k &&& constrs), (var, ty, k)::params) 43 | params 44 | (Constraint.ctrue, []) 45 | in 46 | constrs, ienv, params 47 | 48 | let transl_type_scheme ~env (schm : T.scheme) = 49 | let level = 1 in 50 | let ienv = Instantiate.create level in 51 | let constr_params, ienv, _tyvars = transl_params ~ienv schm.tyvars in 52 | let constr_lit = transl_constr ~ienv schm.constraints in 53 | let constr = Constraint.(constr_lit &&& constr_params) in 54 | let typ = transl_type ~ienv schm.typ in 55 | let env, scheme = Typing.make_type_scheme ~env ~constr typ in 56 | env, scheme 57 | 58 | let transl_type_constructor 59 | ~env ~ienv params typname constraints (constructor : T.constructor) 60 | = 61 | let name = constructor.name in 62 | let typarams = List.map (fun (_,ty,_) -> ty) params in 63 | let constr = 64 | transl_constr ~ienv (C.And [constraints; constructor.constraints]) 65 | in 66 | let constructor_typ = transl_type ~ienv constructor.typ in 67 | let typ = Types.Arrow (constructor_typ, Un Global, App (typname, typarams)) in 68 | let _env, scheme = Typing.make_type_scheme ~env ~constr typ in 69 | name, scheme 70 | 71 | let transl_decl ~env 72 | {T. name ; params ; constraints; constructor ; kind } = 73 | 74 | let level = 1 in 75 | let ienv = Instantiate.create level in 76 | let constr_params, ienv, params = transl_params ~ienv params in 77 | let constructor_schemes = 78 | List.map 79 | (transl_type_constructor ~env ~ienv params name constraints) 80 | constructor 81 | in 82 | 83 | let kargs = List.map (fun (_,_,k) -> k) params in 84 | let ret_kind = transl_kind ~ienv kind in 85 | let constr_lit = transl_constr ~ienv constraints in 86 | let constr = Constraint.(constr_lit &&& constr_params) in 87 | 88 | let typs = 89 | List.map (fun {T. typ; _} -> transl_type ~ienv typ) constructor 90 | in 91 | 92 | let _env, kscheme = 93 | Typing.make_type_decl ~env ~constr kargs ret_kind typs 94 | in 95 | 96 | name, kscheme, constructor_schemes 97 | -------------------------------------------------------------------------------- /lang/affe/types.ml: -------------------------------------------------------------------------------- 1 | type level = int 2 | 3 | 4 | module Borrow = struct 5 | type t = Syntax.borrow = Immutable | Mutable 6 | let equal b1 b2 = match b1, b2 with 7 | | Immutable, Immutable 8 | | Mutable, Mutable 9 | -> true 10 | | _ 11 | -> false 12 | let max b1 b2 = match b1, b2 with 13 | | _, Mutable | Mutable, _ -> Mutable 14 | | Immutable, Immutable 15 | -> Immutable 16 | end 17 | 18 | type kind = Kinds.t 19 | 20 | type typ = 21 | | App : Name.t * typ list -> typ 22 | | Arrow : typ * kind * typ -> typ 23 | | GenericVar : Name.t -> typ 24 | | Var : tyvar ref -> typ 25 | | Borrow : Borrow.t * kind * typ -> typ 26 | | Tuple of typ list 27 | 28 | and tyvar = 29 | | Unbound of Name.t * level 30 | | Link of typ 31 | 32 | type constr = 33 | | TypeLeq of typ * typ 34 | | KindLeq of kind * kind 35 | | HasKind of typ * kind 36 | | And of constr list 37 | 38 | type normalized_constr = 39 | | KindLeq of kind * kind 40 | | HasKind of Name.t * typ * kind 41 | | And of normalized_constr list 42 | 43 | type scheme = { 44 | kvars : Name.t list ; 45 | tyvars : Name.t list ; 46 | constr : normalized_constr ; 47 | ty : typ ; 48 | } 49 | 50 | type kscheme = { 51 | kvars : Name.t list ; 52 | constr : normalized_constr ; 53 | args : kind list ; 54 | kind : kind ; 55 | } 56 | 57 | 58 | let var ?name level = 59 | let n = Name.create ?name () in 60 | n, Var (ref (Unbound(n, level))) 61 | let kind ?name level = 62 | let n = Name.create ?name () in 63 | n, Kinds.Var (ref (Kinds.Unbound(n, level))) 64 | let gen_var () = let n = Name.create () in n, GenericVar n 65 | let gen_kind_var () = let n = Name.create () in n, Kinds.GenericVar n 66 | 67 | let tyscheme ?(constr=And []) ?(kvars=[]) ?(tyvars=[]) ty = 68 | { constr ; kvars ; tyvars ; ty } 69 | 70 | let kscheme ?(constr=And []) ?(kvars=[]) ?(args=[]) kind = 71 | { constr ; kvars ; args ; kind } 72 | 73 | let rec repr = function 74 | | Var { contents = Link t } -> repr t 75 | | _ as t -> t 76 | 77 | module Fold = struct 78 | 79 | let (++) = Name.Set.union 80 | 81 | let rec kind (++) z = function 82 | | Kinds.GenericVar n -> (`Kind n) ++ z 83 | | Var { contents = Link t } -> kind (++) z t 84 | | Var { contents = Unbound (n, _) } -> (`Kind n) ++ z 85 | | Un _ | Aff _ | Lin _ -> z 86 | 87 | let kinds (++) z l = 88 | List.fold_left 89 | (fun e k -> kind (++) e k) 90 | z l 91 | 92 | let rec types (++) z = function 93 | | GenericVar n -> 94 | `Ty n ++ z 95 | | Var { contents = Link t } -> 96 | types (++) z t 97 | | Var { contents = Unbound (n, _) } -> 98 | `Ty n ++ z 99 | | App (_, args) -> 100 | List.fold_left (fun x t -> 101 | types (++) x t 102 | ) z args 103 | | Arrow (ty1, k, ty2) -> 104 | types (++) ( kind (++) (types (++) z ty2) k) ty1 105 | | Tuple tys -> 106 | let aux x ty = types (++) x ty in 107 | List.fold_left aux z tys 108 | | Borrow (_, k, t) -> 109 | kind (++) (types (++) z t) k 110 | 111 | let rec normalized_constr (++) z = function 112 | | KindLeq (k1,k2) -> kind (++) (kind (++) z k1) k2 113 | | HasKind (_, t, k) -> kind (++) (types (++) z t) k 114 | | And l -> List.fold_left (normalized_constr (++)) z l 115 | 116 | let scheme (++) z { tyvars ; ty ; constr ; _ } = 117 | let z' = types (++) z ty in 118 | let fv, _ = normalized_constr (++) z' constr in 119 | Name.Set.diff fv (Name.Set.of_list tyvars) 120 | end 121 | 122 | module Free_vars = struct 123 | 124 | let fv_zero = Name.Set.empty 125 | let fv_red x kfv = match x with 126 | | `Kind x -> Name.Set.add x kfv 127 | let kind k = Fold.kind fv_red fv_zero k 128 | let kinds ks = Fold.kinds fv_red fv_zero ks 129 | 130 | let fv_zero = (Name.Set.empty, Name.Set.empty) 131 | let fv_red x (fv, kfv) = match x with 132 | | `Ty x -> Name.Set.add x fv, kfv 133 | | `Kind x -> fv, Name.Set.add x kfv 134 | let normalized_constr c = Fold.normalized_constr fv_red fv_zero c 135 | let types ty = Fold.types fv_red fv_zero ty 136 | let scheme s = Fold.scheme fv_red fv_zero s 137 | let schemes l = 138 | List.fold_left 139 | (fun e sch -> Name.Set.union e @@ scheme sch) 140 | Name.Set.empty 141 | l 142 | end 143 | 144 | module Use = struct 145 | 146 | type t = 147 | | Shadow of Borrow.t 148 | | Borrow of (Borrow.t * kind list) 149 | | Normal of kind list 150 | 151 | end 152 | -------------------------------------------------------------------------------- /lang/affe/variance.ml: -------------------------------------------------------------------------------- 1 | module M = struct 2 | type t = 3 | | Pos 4 | | Neg 5 | | Invar 6 | | Bivar 7 | [@@deriving eq, ord] 8 | end 9 | include M 10 | type variance = t 11 | 12 | let neg = function 13 | | Pos -> Neg 14 | | Neg -> Pos 15 | | Invar -> Invar 16 | | Bivar -> Bivar 17 | let merge v1 v2 = match v1, v2 with 18 | | Bivar, v 19 | | v, Bivar -> v 20 | | Pos, Pos -> Pos 21 | | Neg, Neg -> Neg 22 | | Invar, _ 23 | | Neg, Pos 24 | | Pos, Neg 25 | | _, Invar -> Invar 26 | 27 | 28 | module Map = struct 29 | type t = variance Name.Map.t 30 | let empty = Name.Map.empty 31 | let get (m : t) k = CCOpt.get_or ~default:Bivar @@ Name.Map.find_opt k m 32 | let find (m : t) k = Name.Map.find_opt k m 33 | let mem (m : t) k = Name.Map.mem k m 34 | let add (m : t) k v = 35 | Name.Map.update k (function None -> Some v | Some v' -> Some (merge v v')) m 36 | let merge = Name.Map.union (fun _ v1 v2 -> Some (merge v1 v2)) 37 | end 38 | -------------------------------------------------------------------------------- /lang/hm/README.markdown: -------------------------------------------------------------------------------- 1 | An eager impure functional language with an hindley-milner type system that supports 2 | type inference, parametric polymorphism and value restriction. 3 | The implementation contains a parser, type inference, 4 | and an interpreter. The language has integers, references, first class 5 | functions, and a general fixpoint operator. 6 | 7 | The file `example.hm` demonstrates the usage of the value restriction. 8 | 9 | The implementation is based on the article [Efficient and Insightful Generalization](http://okmij.org/ftp/ML/generalization.html) by Oleg Kiselyov. 10 | -------------------------------------------------------------------------------- /lang/hm/dune: -------------------------------------------------------------------------------- 1 | (ocamllex lexer) 2 | (menhir (modules parser)) 3 | 4 | (executable 5 | (name hm) 6 | (libraries zoo_native) 7 | ) 8 | -------------------------------------------------------------------------------- /lang/hm/eval.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | (** Global Environment *) 4 | 5 | type env = value NameMap.t 6 | let initial_env = NameMap.empty 7 | let add = NameMap.add 8 | let find x env = 9 | if NameMap.mem x env then 10 | NameMap.find x env 11 | else 12 | Zoo.error "Unbound variable %a" Printer.name x 13 | 14 | (** Substitutions *) 15 | 16 | let rec subst_value x v = function 17 | | Constant c -> Constant c 18 | | Lambda (y,e) when not @@ Name.equal x y -> 19 | (Lambda (y, subst x v e)) 20 | | Lambda (_, _) 21 | | Y 22 | | Ref _ 23 | as v -> v 24 | 25 | (** e[x -> v] *) 26 | and subst x v e = match e with 27 | | Var y when Name.equal x y -> V v 28 | | Var n -> Var n 29 | | V v' -> V (subst_value x v v') 30 | | App (f,e) -> App (subst x v f, List.map (subst x v) e) 31 | | Let (y,e1,e2) when not @@ Name.equal x y -> 32 | Let (y, subst x v e1, subst x v e2) 33 | | Let (y,e1,e2) -> 34 | Let (y, subst x v e1, e2) 35 | 36 | let subst_env = NameMap.fold subst 37 | 38 | (** Evaluation *) 39 | 40 | let const x = V (Constant x) 41 | let delta c v = match c,v with 42 | | Int _, [] -> None 43 | 44 | | Plus, [ Constant (Int i) ; Constant (Int j) ] -> 45 | Some (V (Constant (Int (i + j)))) 46 | | Plus, [ Constant (Int i) ] -> 47 | let n = Name.create ~name:"i" () in 48 | Some (V (Lambda (n, App (const Plus, [const @@ Int i; Var n])))) 49 | 50 | | NewRef, [ v ] -> Some (V (Ref (ref v))) 51 | | Get, [ Ref r ] -> Some (V !r) 52 | | Set, [ Ref r ] -> 53 | let n = Name.create ~name:"r" () in 54 | Some (V (Lambda (n, App (const Set, [V (Ref r); Var n])))) 55 | | Set, [ Ref r ; v ] -> r := v ; Some (V v) 56 | 57 | | _ -> None 58 | 59 | exception Not_reducible : expr -> exn 60 | 61 | let log_eval i = Format.printf "%s< %a@." (String.make i ' ') Printer.expr 62 | let log_val i = Format.printf "%s> %a@." (String.make i ' ') Printer.value 63 | 64 | let reduction_failure e = 65 | Zoo.error ~kind:"Execution error" 66 | "The following expression can not be reduced:@.%a" Printer.expr e 67 | 68 | let rec eval i e = match e with 69 | | V v -> v 70 | | Var _ -> reduction_failure e 71 | | Let (x,e1,e2) -> 72 | (* log_eval i e ; *) 73 | let v = eval (i+1) e1 in 74 | let v' = eval (i+1) @@ subst x v e2 in 75 | (* log_val i v' ; *) 76 | v' 77 | | App(f,l) -> 78 | (* log_eval i e ; *) 79 | let vf = eval (i+1) f in 80 | let ve = List.map (eval @@ i+1) l in 81 | let v = eval_app (i+1) e vf ve in 82 | (* log_val i v ; *) 83 | v 84 | 85 | and eval_app i eorig f l = match f, l with 86 | | _, [] -> f 87 | | Ref _, _ -> reduction_failure eorig 88 | | Y, ve::t -> 89 | let n = Name.create ~name:"Y" () in 90 | eval_app i eorig ve (Lambda(n, App(V Y, [V ve; Var n])) :: t) 91 | | Lambda(x, body), (v :: t) -> 92 | eval_app i eorig (eval (i+1) @@ subst x v body) t 93 | | Constant c, l -> 94 | begin match delta c l with 95 | | Some x -> eval (i+1) x 96 | | None -> reduction_failure eorig 97 | end 98 | 99 | let execute env p = eval 0 @@ subst_env env p 100 | -------------------------------------------------------------------------------- /lang/hm/example.hm: -------------------------------------------------------------------------------- 1 | let x = 2 | let id = fun x -> x in 3 | let id2 = id id in 4 | let x = id2 3 in 5 | id2 6 | let x = 2 7 | let plusx = fun y -> + x y 8 | let a = plusx 2 9 | -------------------------------------------------------------------------------- /lang/hm/hm.ml: -------------------------------------------------------------------------------- 1 | module HM = Zoo.Main (struct 2 | 3 | let name = "HM" 4 | 5 | type command = Syntax.command 6 | 7 | let options = [] 8 | 9 | type environment = { 10 | ty : Type.Env.env ; 11 | name: Syntax.Rename.env ; 12 | value: Eval.env ; 13 | } 14 | let add_def x ty v env = { 15 | ty = Type.Env.add x ty env.ty ; 16 | name = Syntax.Rename.add x.name x env.name ; 17 | value = Eval.add x v env.value ; 18 | } 19 | let initial_environment = { 20 | ty = Type.Env.empty; 21 | name = Syntax.Rename.SMap.empty ; 22 | value = Eval.initial_env ; 23 | } 24 | 25 | let read_more str = 26 | let i = ref (String.length str - 1) in 27 | while !i >= 0 && List.mem str.[!i] [' '; '\n'; '\t'; '\r'] do decr i done ; 28 | !i < 1 || (str.[!i] <> ';' || str.[!i - 1] <> ';') 29 | 30 | let file_parser = Some (Parser.file Lexer.token) 31 | let toplevel_parser = Some (Parser.toplevel Lexer.token) 32 | 33 | let exec env c = 34 | let c = Syntax.Rename.command env.name c in 35 | match c with 36 | | Syntax.Def (x, e) -> 37 | let ty = Typing.infer_top env.ty e in 38 | let v = Eval.execute env.value e in 39 | Zoo.print_info "@[<2>%a@ : @[%a@]@ = @[%a@]@." 40 | Printer.name x Printer.typ ty Printer.value v ; 41 | add_def x ty v env 42 | end) 43 | 44 | let () = HM.main () 45 | -------------------------------------------------------------------------------- /lang/hm/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | } 4 | 5 | rule token = parse 6 | | [' ' '\t'] { token lexbuf } (* skip blanks *) 7 | | '\n' { Lexing.new_line lexbuf ; token lexbuf } 8 | | '-'?[ '0'-'9' ]+ as x {INT (int_of_string x)} 9 | | "Y" { YTOK } 10 | | "let" { LET } 11 | | "+" { PLUS } 12 | | "in" { IN } 13 | | "=" { EQUAL } 14 | | "fun" { FUN } 15 | | "ref" { REF } 16 | | "!" { BANG } 17 | | ":=" { COLONEQUAL } 18 | | "->" { RIGHTARROW } 19 | | '(' { LPAREN } 20 | | ')' { RPAREN } 21 | | [ 'A'-'Z' 'a'-'z' '0'-'9' '_' '\'' ]+ as s { IDENT s } 22 | | eof { EOF } 23 | | ";;" { SEMISEMI } 24 | -------------------------------------------------------------------------------- /lang/hm/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | %} 4 | 5 | %token EOF SEMISEMI 6 | %token YTOK 7 | %token IDENT 8 | %token INT 9 | %token EQUAL PLUS 10 | %token LPAREN RPAREN 11 | %token LET IN 12 | %token RIGHTARROW FUN 13 | %token REF BANG COLONEQUAL 14 | 15 | %nonassoc FUN 16 | %left FUNAPP 17 | %nonassoc INT IDENT LPAREN YTOK PLUS REF BANG COLONEQUAL 18 | 19 | %start file 20 | %type file 21 | 22 | %start toplevel 23 | %type toplevel 24 | 25 | %% 26 | file: list(command) EOF { $1 } 27 | toplevel: command SEMISEMI { $1 } 28 | 29 | command: 30 | | LET name=name EQUAL e=expr { Def (name, e) } 31 | 32 | expr: 33 | | e=simple_expr %prec FUN { e } 34 | | f=simple_expr l=list_expr %prec FUNAPP 35 | { App (f,List.rev l) } 36 | | LET name=name EQUAL e1=expr IN e2=expr { Let (name, e1, e2) } 37 | 38 | simple_expr: 39 | | v=value { V v } 40 | | name=name { Var name } 41 | | LPAREN e=expr RPAREN { e } 42 | 43 | list_expr: 44 | | simple_expr { [$1] } 45 | | list_expr simple_expr { $2 :: $1 } 46 | 47 | value: 48 | | FUN name=name RIGHTARROW e=expr { Lambda (name, e) } 49 | | c=constant { Constant c } 50 | | YTOK { Y } 51 | 52 | constant: 53 | | i=INT { Int i } 54 | | PLUS { Plus } 55 | | REF { NewRef } 56 | | BANG { Get } 57 | | COLONEQUAL { Set } 58 | 59 | name: 60 | | name=IDENT { Name.dummy name } 61 | -------------------------------------------------------------------------------- /lang/hm/printer.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | module T = Type 3 | 4 | let bold fmt s = Format.fprintf fmt "@<0>%s%s@<0>%s" "\027[1m" s "\027[0m" 5 | 6 | let constant fmt = function 7 | | Int i -> Format.pp_print_int fmt i 8 | | Plus -> bold fmt "+" 9 | | NewRef -> bold fmt "new" 10 | | Get -> bold fmt "!" 11 | | Set -> bold fmt ":=" 12 | 13 | let indice_array = [|"₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"|] 14 | let rec digits fmt i = 15 | if i < 0 then 16 | Format.pp_print_string fmt "₋" 17 | else if i < 10 then 18 | Format.pp_print_string fmt indice_array.(i) 19 | else begin 20 | digits fmt (i/10) ; 21 | Format.pp_print_string fmt indice_array.(i mod 10) 22 | end 23 | 24 | let name fmt {Name. name ; id } = 25 | Format.fprintf fmt "%s%a" name digits id 26 | 27 | let rec value 28 | = fun fmt -> function 29 | | Constant c -> constant fmt c 30 | | Lambda (n,e) -> 31 | Format.fprintf fmt "@[<2>%a %a %a@ %a@]" 32 | bold "fun" 33 | name n 34 | bold "->" 35 | expr e 36 | | Ref { contents } -> Format.fprintf fmt "{%a}" value contents 37 | | Y -> Format.fprintf fmt "Y" 38 | 39 | and expr 40 | = fun fmt -> function 41 | | V v -> value fmt v 42 | | Var v -> name fmt v 43 | | App (f,e) -> 44 | Format.fprintf fmt "@[<2>@[%a@]@ %a@]" 45 | expr_with_paren f 46 | Format.(pp_print_list ~pp_sep:pp_print_space expr_with_paren) e 47 | | Let (n,e1,e2) -> 48 | Format.fprintf fmt "@[@[<2>%a %a %a@ %a@]@ %a@ %a@]" 49 | bold "let" name n 50 | bold "=" expr e1 51 | bold "in" expr e2 52 | 53 | and expr_with_paren fmt x = 54 | let must_have_paren = match x with 55 | | App _ -> true 56 | | Let _ -> true 57 | | V (Lambda _) -> true 58 | | _ -> false 59 | in 60 | Format.fprintf fmt 61 | (if must_have_paren then "@[(%a@])" else "%a") expr x 62 | 63 | let rec typ_need_paren = function 64 | | T.Arrow _ -> true 65 | | T.Var { contents = Link t } -> typ_need_paren t 66 | | _ -> false 67 | 68 | let rec tyvar 69 | = fun fmt -> function 70 | | T.Unbound (n,_) -> Format.fprintf fmt "'_%a" name n 71 | | T.Link t -> typ_with_paren fmt t 72 | 73 | and typ 74 | = fun fmt -> function 75 | | T.Const n -> name fmt n 76 | | T.App (f,e) -> Format.fprintf fmt "@[<2>%a@ %a@]" typ_with_paren e typ f 77 | | T.Arrow (a,b) -> Format.fprintf fmt "%a -> %a" typ_with_paren a typ b 78 | | T.Var { contents = x } -> tyvar fmt x 79 | | T.GenericVar n -> Format.fprintf fmt "'%a" name n 80 | 81 | and typ_with_paren fmt x = 82 | let must_have_paren = match x with 83 | | T.Arrow _ -> true 84 | | _ -> false 85 | in 86 | Format.fprintf fmt 87 | (if must_have_paren then "@[(%a@])" else "%a") typ x 88 | 89 | let typ_env fmt env = 90 | let print_env fmt e = 91 | Format.pp_print_list 92 | ~pp_sep:Format.pp_print_cut 93 | (fun fmt (k,ty) -> Format.fprintf fmt "%a: %a" name k typ ty) 94 | fmt 95 | @@ T.Env.M.bindings e 96 | in 97 | Format.fprintf fmt "Server:@;<1 2>@[%a@]@.Client:@;<1 2>@[%a@]@." 98 | print_env env 99 | -------------------------------------------------------------------------------- /lang/hm/syntax.ml: -------------------------------------------------------------------------------- 1 | module Name = struct 2 | type t = {name : string ; id : int} 3 | let compare n1 n2 = compare n1.id n2.id 4 | let equal n1 n2 = n1.id = n2.id 5 | let dummy name = { name ; id = -1 } 6 | let create = 7 | let r = ref 0 in 8 | fun ?(name="") () -> 9 | let id = !r in incr r ; 10 | { name ; id } 11 | end 12 | module NameMap = Map.Make(Name) 13 | 14 | type constant = 15 | | Int of int 16 | | Plus 17 | | NewRef 18 | | Get 19 | | Set 20 | 21 | type value = 22 | | Constant of constant 23 | | Lambda of Name.t * expr 24 | | Ref of value ref 25 | | Y 26 | 27 | and expr = 28 | | V of value 29 | | Var of Name.t 30 | | App of expr * expr list 31 | | Let of Name.t * expr * expr 32 | type command = 33 | | Def of Name.t * expr 34 | 35 | let is_value = function 36 | | V _ -> true 37 | | _ -> false 38 | 39 | 40 | module Rename = struct 41 | [@@@warning "-9"] 42 | 43 | module SMap = Map.Make(String) 44 | 45 | type env = Name.t SMap.t 46 | 47 | let find x env = 48 | if SMap.mem x env then 49 | SMap.find x env 50 | else 51 | Zoo.error "Unbound variable %s" x 52 | 53 | let add n k env = SMap.add n k env 54 | 55 | let rec value env = function 56 | | Lambda ({name}, e) -> 57 | let new_name = Name.create ~name () in 58 | let env = add name new_name env in 59 | let e = expr env e in 60 | Lambda (new_name, e) 61 | | Constant _ | Y | Ref _ as e-> e 62 | 63 | and expr env = function 64 | | V v -> V (value env v) 65 | | Var { name } -> Var (find name env) 66 | | App (f, l) -> App (expr env f, List.map (expr env) l) 67 | | Let ({name}, e1, e2) -> 68 | let e1 = expr env e1 in 69 | let new_name = Name.create ~name () in 70 | let env = add name new_name env in 71 | let e2 = expr env e2 in 72 | Let (new_name, e1, e2) 73 | 74 | let command env = function 75 | | Def ({name},e) -> 76 | let e = expr env e in 77 | let new_name = Name.create ~name () in 78 | Def (new_name, e) 79 | 80 | end 81 | -------------------------------------------------------------------------------- /lang/hm/type.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | type level = int 4 | 5 | type t = 6 | | Const : Name.t -> t 7 | | App : t * t -> t 8 | | Arrow : t * t -> t 9 | | GenericVar : Name.t -> t 10 | | Var : var ref -> t 11 | 12 | and var = 13 | | Unbound of Name.t * level 14 | | Link of t 15 | 16 | module Env = struct 17 | module M = NameMap 18 | exception Var_not_found of Name.t 19 | type env = t M.t 20 | let add k (v: t) env = M.add k v env 21 | 22 | let find k env : t = 23 | try M.find k env with 24 | Not_found -> raise (Var_not_found k) 25 | 26 | let empty = M.empty 27 | end 28 | 29 | (** Predefined types *) 30 | 31 | let new_y () = 32 | let y_name = Name.create ~name:"a" () in 33 | let n = GenericVar y_name in 34 | Arrow(Arrow(n,n),n) 35 | 36 | let int_name = Name.create ~name:"int" () 37 | let int = Const int_name 38 | 39 | let ref_name = Name.create ~name:"ref" () 40 | let ref = Const ref_name 41 | 42 | let (@->) x y = Arrow (x,y) 43 | -------------------------------------------------------------------------------- /lang/hm/typing.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | module T = Type 3 | 4 | let fail fmt = 5 | Zoo.error ~kind:"Type error" fmt 6 | 7 | let new_var level = T.Var (ref (T.Unbound(Name.create (), level))) 8 | let new_gen_var () = T.GenericVar(Name.create ()) 9 | 10 | let occurs_check_adjust_levels tvar_id tvar_level ty = 11 | let rec f : T.t -> _ = function 12 | | T.Var {contents = T.Link ty} -> f ty 13 | | T.GenericVar _ -> assert false 14 | | T.Var ({contents = T.Unbound(other_id, other_level)} as other_tvar) -> 15 | if other_id = tvar_id then 16 | fail "Recursive types" 17 | else 18 | other_tvar := Unbound(other_id, min tvar_level other_level) 19 | | T.App(ty, ty_arg) -> 20 | f ty ; 21 | f ty_arg 22 | | T.Arrow(param_ty, return_ty) -> 23 | f param_ty ; 24 | f return_ty 25 | | T.Const _ -> () 26 | in 27 | f ty 28 | 29 | 30 | let rec unify 31 | = fun ty1 ty2 -> match ty1, ty2 with 32 | | _, _ when ty1 == ty2 -> () 33 | 34 | | T.Const name1, T.Const name2 when Syntax.Name.equal name1 name2 -> () 35 | 36 | | T.App(ty1, ty_arg1), T.App(ty2, ty_arg2) -> 37 | unify ty1 ty2 ; 38 | unify ty_arg1 ty_arg2 39 | 40 | | T.Arrow(param_ty1, return_ty1), T.Arrow(param_ty2, return_ty2) -> 41 | unify param_ty1 param_ty2 ; 42 | unify return_ty1 return_ty2 43 | 44 | | T.Var {contents = Link ty1}, ty2 -> unify ty1 ty2 45 | | ty1, T.Var {contents = Link ty2} -> unify ty1 ty2 46 | 47 | | T.Var {contents = Unbound(id1, _)}, 48 | T.Var {contents = Unbound(id2, _)} when id1 = id2 -> 49 | (* There is only a single instance of a particular type variable. *) 50 | assert false 51 | 52 | | T.Var ({contents = Unbound(id, level)} as tvar), ty 53 | | ty, T.Var ({contents = Unbound(id, level)} as tvar) -> 54 | occurs_check_adjust_levels id level ty ; 55 | tvar := Link ty 56 | 57 | | _, _ -> 58 | fail "Cannot unify types %a and %a@." Printer.typ ty1 Printer.typ ty2 59 | 60 | 61 | 62 | let rec generalize level = function 63 | | T.Var {contents = Unbound(id, other_level)} when other_level > level -> 64 | T.GenericVar id 65 | | T.App(ty, ty_arg) -> 66 | App(generalize level ty, generalize level ty_arg) 67 | | T.Arrow(param_ty, return_ty) -> 68 | Arrow(generalize level param_ty, generalize level return_ty) 69 | 70 | | T.Var {contents = Link ty} -> generalize level ty 71 | 72 | | ( T.GenericVar _ 73 | | T.Var {contents = Unbound _} 74 | | T.Const _ 75 | ) as ty -> ty 76 | 77 | (** The real generalization function that is aware of the value restriction. *) 78 | let generalize level ty exp = 79 | if Syntax.is_value exp then 80 | generalize level ty 81 | else 82 | ty 83 | 84 | let instantiate level ty = 85 | let id_var_map = Hashtbl.create 10 in 86 | let rec f = function 87 | | T.Const _ as ty -> ty 88 | | T.Var {contents = Link ty} -> f ty 89 | | T.GenericVar id -> 90 | begin try 91 | Hashtbl.find id_var_map id 92 | with Not_found -> 93 | let var = new_var level in 94 | Hashtbl.add id_var_map id var ; 95 | var 96 | end 97 | | T.Var {contents = Unbound _} as ty -> ty 98 | | T.App(ty, ty_arg) -> 99 | App(f ty, f ty_arg) 100 | | T.Arrow(param_ty, return_ty) -> 101 | Arrow(f param_ty, f return_ty) 102 | in 103 | f ty 104 | 105 | let constant = let open T in function 106 | | Int _ -> int 107 | | Plus -> int @-> int @-> int 108 | | NewRef -> 109 | let a = new_gen_var () in 110 | a @-> T.App (ref, a) 111 | | Get -> 112 | let a = new_gen_var () in 113 | T.App (ref, a) @-> a 114 | | Set -> 115 | let a = new_gen_var () in 116 | T.App (ref, a) @-> a @-> a 117 | 118 | let rec infer_value env level = function 119 | | Constant c -> instantiate level @@ constant c 120 | | Y -> instantiate level @@ T.new_y () 121 | | Lambda(param, body_expr) -> 122 | let param_ty = new_var level in 123 | let fn_env = T.Env.add param param_ty env in 124 | let return_ty = infer fn_env level body_expr in 125 | T.Arrow (param_ty, return_ty) 126 | | Ref v -> 127 | T.App (T.ref, infer_value env level !v) 128 | 129 | and infer env level = function 130 | | V v -> infer_value env level v 131 | | Var name -> 132 | instantiate level @@ T.Env.find name env 133 | | Let(var_name, value_expr, body_expr) -> 134 | let var_ty = infer env (level + 1) value_expr in 135 | let generalized_ty = generalize level var_ty value_expr in 136 | infer (T.Env.add var_name generalized_ty env) level body_expr 137 | | App(fn_expr, arg) -> 138 | let f_ty = infer env level fn_expr in 139 | infer_app env level f_ty arg 140 | 141 | and infer_app env level f_ty = function 142 | | [] -> f_ty 143 | | e::t -> 144 | let param_ty = infer env level e in 145 | let return_ty = new_var level in 146 | unify f_ty (T.Arrow (param_ty, return_ty)) ; 147 | infer_app env level return_ty t 148 | 149 | let infer_top env e = 150 | let ty = infer env 1 e in 151 | let ty = generalize 0 ty e in 152 | ty 153 | -------------------------------------------------------------------------------- /www/addon/lint/lint.css: -------------------------------------------------------------------------------- 1 | /* The lint marker gutter */ 2 | .CodeMirror-lint-markers { 3 | width: 16px; 4 | } 5 | 6 | .CodeMirror-lint-tooltip { 7 | background-color: #ffd; 8 | border: 1px solid black; 9 | border-radius: 4px 4px 4px 4px; 10 | color: black; 11 | font-family: monospace; 12 | font-size: 10pt; 13 | overflow: hidden; 14 | padding: 2px 5px; 15 | position: fixed; 16 | white-space: pre; 17 | white-space: pre-wrap; 18 | z-index: 100; 19 | max-width: 600px; 20 | opacity: 0; 21 | transition: opacity .4s; 22 | -moz-transition: opacity .4s; 23 | -webkit-transition: opacity .4s; 24 | -o-transition: opacity .4s; 25 | -ms-transition: opacity .4s; 26 | } 27 | 28 | .CodeMirror-lint-mark-error, .CodeMirror-lint-mark-warning { 29 | background-position: left bottom; 30 | background-repeat: repeat-x; 31 | } 32 | 33 | .CodeMirror-lint-mark-error { 34 | background-image: 35 | url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAQAAAADCAYAAAC09K7GAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9sJDw4cOCW1/KIAAAAZdEVYdENvbW1lbnQAQ3JlYXRlZCB3aXRoIEdJTVBXgQ4XAAAAHElEQVQI12NggIL/DAz/GdA5/xkY/qPKMDAwAADLZwf5rvm+LQAAAABJRU5ErkJggg==") 36 | ; 37 | } 38 | 39 | .CodeMirror-lint-mark-warning { 40 | background-image: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAQAAAADCAYAAAC09K7GAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9sJFhQXEbhTg7YAAAAZdEVYdENvbW1lbnQAQ3JlYXRlZCB3aXRoIEdJTVBXgQ4XAAAAMklEQVQI12NkgIIvJ3QXMjAwdDN+OaEbysDA4MPAwNDNwMCwiOHLCd1zX07o6kBVGQEAKBANtobskNMAAAAASUVORK5CYII="); 41 | } 42 | 43 | .CodeMirror-lint-marker-error, .CodeMirror-lint-marker-warning { 44 | background-position: center center; 45 | background-repeat: no-repeat; 46 | cursor: pointer; 47 | display: inline-block; 48 | height: 16px; 49 | width: 16px; 50 | vertical-align: middle; 51 | position: relative; 52 | } 53 | 54 | .CodeMirror-lint-message-error, .CodeMirror-lint-message-warning { 55 | padding-left: 18px; 56 | background-position: top left; 57 | background-repeat: no-repeat; 58 | } 59 | 60 | .CodeMirror-lint-marker-error, .CodeMirror-lint-message-error { 61 | background-image: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAHlBMVEW7AAC7AACxAAC7AAC7AAAAAAC4AAC5AAD///+7AAAUdclpAAAABnRSTlMXnORSiwCK0ZKSAAAATUlEQVR42mWPOQ7AQAgDuQLx/z8csYRmPRIFIwRGnosRrpamvkKi0FTIiMASR3hhKW+hAN6/tIWhu9PDWiTGNEkTtIOucA5Oyr9ckPgAWm0GPBog6v4AAAAASUVORK5CYII="); 62 | } 63 | 64 | .CodeMirror-lint-marker-warning, .CodeMirror-lint-message-warning { 65 | background-image: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAANlBMVEX/uwDvrwD/uwD/uwD/uwD/uwD/uwD/uwD/uwD6twD/uwAAAADurwD2tQD7uAD+ugAAAAD/uwDhmeTRAAAADHRSTlMJ8mN1EYcbmiixgACm7WbuAAAAVklEQVR42n3PUQqAIBBFUU1LLc3u/jdbOJoW1P08DA9Gba8+YWJ6gNJoNYIBzAA2chBth5kLmG9YUoG0NHAUwFXwO9LuBQL1giCQb8gC9Oro2vp5rncCIY8L8uEx5ZkAAAAASUVORK5CYII="); 66 | } 67 | 68 | .CodeMirror-lint-marker-multiple { 69 | background-image: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAcAAAAHCAMAAADzjKfhAAAACVBMVEUAAAAAAAC/v7914kyHAAAAAXRSTlMAQObYZgAAACNJREFUeNo1ioEJAAAIwmz/H90iFFSGJgFMe3gaLZ0od+9/AQZ0ADosbYraAAAAAElFTkSuQmCC"); 70 | background-repeat: no-repeat; 71 | background-position: right bottom; 72 | width: 100%; height: 100%; 73 | } 74 | -------------------------------------------------------------------------------- /www/addon/lint/lint.js: -------------------------------------------------------------------------------- 1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others 2 | // Distributed under an MIT license: https://codemirror.net/LICENSE 3 | 4 | (function(mod) { 5 | if (typeof exports == "object" && typeof module == "object") // CommonJS 6 | mod(require("../../lib/codemirror")); 7 | else if (typeof define == "function" && define.amd) // AMD 8 | define(["../../lib/codemirror"], mod); 9 | else // Plain browser env 10 | mod(CodeMirror); 11 | })(function(CodeMirror) { 12 | "use strict"; 13 | var GUTTER_ID = "CodeMirror-lint-markers"; 14 | 15 | function showTooltip(e, content) { 16 | var tt = document.createElement("div"); 17 | tt.className = "CodeMirror-lint-tooltip"; 18 | tt.appendChild(content.cloneNode(true)); 19 | document.body.appendChild(tt); 20 | 21 | function position(e) { 22 | if (!tt.parentNode) return CodeMirror.off(document, "mousemove", position); 23 | tt.style.top = Math.max(0, e.clientY - tt.offsetHeight - 5) + "px"; 24 | tt.style.left = (e.clientX + 5) + "px"; 25 | } 26 | CodeMirror.on(document, "mousemove", position); 27 | position(e); 28 | if (tt.style.opacity != null) tt.style.opacity = 1; 29 | return tt; 30 | } 31 | function rm(elt) { 32 | if (elt.parentNode) elt.parentNode.removeChild(elt); 33 | } 34 | function hideTooltip(tt) { 35 | if (!tt.parentNode) return; 36 | if (tt.style.opacity == null) rm(tt); 37 | tt.style.opacity = 0; 38 | setTimeout(function() { rm(tt); }, 600); 39 | } 40 | 41 | function showTooltipFor(e, content, node) { 42 | var tooltip = showTooltip(e, content); 43 | function hide() { 44 | CodeMirror.off(node, "mouseout", hide); 45 | if (tooltip) { hideTooltip(tooltip); tooltip = null; } 46 | } 47 | var poll = setInterval(function() { 48 | if (tooltip) for (var n = node;; n = n.parentNode) { 49 | if (n && n.nodeType == 11) n = n.host; 50 | if (n == document.body) return; 51 | if (!n) { hide(); break; } 52 | } 53 | if (!tooltip) return clearInterval(poll); 54 | }, 400); 55 | CodeMirror.on(node, "mouseout", hide); 56 | } 57 | 58 | function LintState(cm, options, hasGutter) { 59 | this.marked = []; 60 | this.options = options; 61 | this.timeout = null; 62 | this.hasGutter = hasGutter; 63 | this.onMouseOver = function(e) { onMouseOver(cm, e); }; 64 | this.waitingFor = 0 65 | } 66 | 67 | function parseOptions(_cm, options) { 68 | if (options instanceof Function) return {getAnnotations: options}; 69 | if (!options || options === true) options = {}; 70 | return options; 71 | } 72 | 73 | function clearMarks(cm) { 74 | var state = cm.state.lint; 75 | if (state.hasGutter) cm.clearGutter(GUTTER_ID); 76 | for (var i = 0; i < state.marked.length; ++i) 77 | state.marked[i].clear(); 78 | state.marked.length = 0; 79 | } 80 | 81 | function makeMarker(labels, severity, multiple, tooltips) { 82 | var marker = document.createElement("div"), inner = marker; 83 | marker.className = "CodeMirror-lint-marker-" + severity; 84 | if (multiple) { 85 | inner = marker.appendChild(document.createElement("div")); 86 | inner.className = "CodeMirror-lint-marker-multiple"; 87 | } 88 | 89 | if (tooltips != false) CodeMirror.on(inner, "mouseover", function(e) { 90 | showTooltipFor(e, labels, inner); 91 | }); 92 | 93 | return marker; 94 | } 95 | 96 | function getMaxSeverity(a, b) { 97 | if (a == "error") return a; 98 | else return b; 99 | } 100 | 101 | function groupByLine(annotations) { 102 | var lines = []; 103 | for (var i = 0; i < annotations.length; ++i) { 104 | var ann = annotations[i], line = ann.from.line; 105 | (lines[line] || (lines[line] = [])).push(ann); 106 | } 107 | return lines; 108 | } 109 | 110 | function annotationTooltip(ann) { 111 | var severity = ann.severity; 112 | if (!severity) severity = "error"; 113 | var tip = document.createElement("div"); 114 | tip.className = "CodeMirror-lint-message-" + severity; 115 | if (typeof ann.messageHTML != 'undefined') { 116 | tip.innerHTML = ann.messageHTML; 117 | } else { 118 | tip.appendChild(document.createTextNode(ann.message)); 119 | } 120 | return tip; 121 | } 122 | 123 | function lintAsync(cm, getAnnotations, passOptions) { 124 | var state = cm.state.lint 125 | var id = ++state.waitingFor 126 | function abort() { 127 | id = -1 128 | cm.off("change", abort) 129 | } 130 | cm.on("change", abort) 131 | getAnnotations(cm.getValue(), function(annotations, arg2) { 132 | cm.off("change", abort) 133 | if (state.waitingFor != id) return 134 | if (arg2 && annotations instanceof CodeMirror) annotations = arg2 135 | cm.operation(function() {updateLinting(cm, annotations)}) 136 | }, passOptions, cm); 137 | } 138 | 139 | function startLinting(cm) { 140 | var state = cm.state.lint, options = state.options; 141 | /* 142 | * Passing rules in `options` property prevents JSHint (and other linters) from complaining 143 | * about unrecognized rules like `onUpdateLinting`, `delay`, `lintOnChange`, etc. 144 | */ 145 | var passOptions = options.options || options; 146 | var getAnnotations = options.getAnnotations || cm.getHelper(CodeMirror.Pos(0, 0), "lint"); 147 | if (!getAnnotations) return; 148 | if (options.async || getAnnotations.async) { 149 | lintAsync(cm, getAnnotations, passOptions) 150 | } else { 151 | var annotations = getAnnotations(cm.getValue(), passOptions, cm); 152 | if (!annotations) return; 153 | if (annotations.then) annotations.then(function(issues) { 154 | cm.operation(function() {updateLinting(cm, issues)}) 155 | }); 156 | else cm.operation(function() {updateLinting(cm, annotations)}) 157 | } 158 | } 159 | 160 | function updateLinting(cm, annotationsNotSorted) { 161 | clearMarks(cm); 162 | var state = cm.state.lint, options = state.options; 163 | 164 | var annotations = groupByLine(annotationsNotSorted); 165 | 166 | for (var line = 0; line < annotations.length; ++line) { 167 | var anns = annotations[line]; 168 | if (!anns) continue; 169 | 170 | var maxSeverity = null; 171 | var tipLabel = state.hasGutter && document.createDocumentFragment(); 172 | 173 | for (var i = 0; i < anns.length; ++i) { 174 | var ann = anns[i]; 175 | var severity = ann.severity; 176 | if (!severity) severity = "error"; 177 | maxSeverity = getMaxSeverity(maxSeverity, severity); 178 | 179 | if (options.formatAnnotation) ann = options.formatAnnotation(ann); 180 | if (state.hasGutter) tipLabel.appendChild(annotationTooltip(ann)); 181 | 182 | if (ann.to) state.marked.push(cm.markText(ann.from, ann.to, { 183 | className: "CodeMirror-lint-mark-" + severity, 184 | __annotation: ann 185 | })); 186 | } 187 | 188 | if (state.hasGutter) 189 | cm.setGutterMarker(line, GUTTER_ID, makeMarker(tipLabel, maxSeverity, anns.length > 1, 190 | state.options.tooltips)); 191 | } 192 | if (options.onUpdateLinting) options.onUpdateLinting(annotationsNotSorted, annotations, cm); 193 | } 194 | 195 | function onChange(cm) { 196 | var state = cm.state.lint; 197 | if (!state) return; 198 | clearTimeout(state.timeout); 199 | state.timeout = setTimeout(function(){startLinting(cm);}, state.options.delay || 500); 200 | } 201 | 202 | function popupTooltips(annotations, e) { 203 | var target = e.target || e.srcElement; 204 | var tooltip = document.createDocumentFragment(); 205 | for (var i = 0; i < annotations.length; i++) { 206 | var ann = annotations[i]; 207 | tooltip.appendChild(annotationTooltip(ann)); 208 | } 209 | showTooltipFor(e, tooltip, target); 210 | } 211 | 212 | function onMouseOver(cm, e) { 213 | var target = e.target || e.srcElement; 214 | if (!/\bCodeMirror-lint-mark-/.test(target.className)) return; 215 | var box = target.getBoundingClientRect(), x = (box.left + box.right) / 2, y = (box.top + box.bottom) / 2; 216 | var spans = cm.findMarksAt(cm.coordsChar({left: x, top: y}, "client")); 217 | 218 | var annotations = []; 219 | for (var i = 0; i < spans.length; ++i) { 220 | var ann = spans[i].__annotation; 221 | if (ann) annotations.push(ann); 222 | } 223 | if (annotations.length) popupTooltips(annotations, e); 224 | } 225 | 226 | CodeMirror.defineOption("lint", false, function(cm, val, old) { 227 | if (old && old != CodeMirror.Init) { 228 | clearMarks(cm); 229 | if (cm.state.lint.options.lintOnChange !== false) 230 | cm.off("change", onChange); 231 | CodeMirror.off(cm.getWrapperElement(), "mouseover", cm.state.lint.onMouseOver); 232 | clearTimeout(cm.state.lint.timeout); 233 | delete cm.state.lint; 234 | } 235 | 236 | if (val) { 237 | var gutters = cm.getOption("gutters"), hasLintGutter = false; 238 | for (var i = 0; i < gutters.length; ++i) if (gutters[i] == GUTTER_ID) hasLintGutter = true; 239 | var state = cm.state.lint = new LintState(cm, parseOptions(cm, val), hasLintGutter); 240 | if (state.options.lintOnChange !== false) 241 | cm.on("change", onChange); 242 | if (state.options.tooltips != false && state.options.tooltips != "gutter") 243 | CodeMirror.on(cm.getWrapperElement(), "mouseover", state.onMouseOver); 244 | 245 | startLinting(cm); 246 | } 247 | }); 248 | 249 | CodeMirror.defineExtension("performLint", function() { 250 | if (this.state.lint) startLinting(this); 251 | }); 252 | }); 253 | -------------------------------------------------------------------------------- /www/addon/mode/simple.js: -------------------------------------------------------------------------------- 1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others 2 | // Distributed under an MIT license: https://codemirror.net/LICENSE 3 | 4 | (function(mod) { 5 | if (typeof exports == "object" && typeof module == "object") // CommonJS 6 | mod(require("../../lib/codemirror")); 7 | else if (typeof define == "function" && define.amd) // AMD 8 | define(["../../lib/codemirror"], mod); 9 | else // Plain browser env 10 | mod(CodeMirror); 11 | })(function(CodeMirror) { 12 | "use strict"; 13 | 14 | CodeMirror.defineSimpleMode = function(name, states) { 15 | CodeMirror.defineMode(name, function(config) { 16 | return CodeMirror.simpleMode(config, states); 17 | }); 18 | }; 19 | 20 | CodeMirror.simpleMode = function(config, states) { 21 | ensureState(states, "start"); 22 | var states_ = {}, meta = states.meta || {}, hasIndentation = false; 23 | for (var state in states) if (state != meta && states.hasOwnProperty(state)) { 24 | var list = states_[state] = [], orig = states[state]; 25 | for (var i = 0; i < orig.length; i++) { 26 | var data = orig[i]; 27 | list.push(new Rule(data, states)); 28 | if (data.indent || data.dedent) hasIndentation = true; 29 | } 30 | } 31 | var mode = { 32 | startState: function() { 33 | return {state: "start", pending: null, 34 | local: null, localState: null, 35 | indent: hasIndentation ? [] : null}; 36 | }, 37 | copyState: function(state) { 38 | var s = {state: state.state, pending: state.pending, 39 | local: state.local, localState: null, 40 | indent: state.indent && state.indent.slice(0)}; 41 | if (state.localState) 42 | s.localState = CodeMirror.copyState(state.local.mode, state.localState); 43 | if (state.stack) 44 | s.stack = state.stack.slice(0); 45 | for (var pers = state.persistentStates; pers; pers = pers.next) 46 | s.persistentStates = {mode: pers.mode, 47 | spec: pers.spec, 48 | state: pers.state == state.localState ? s.localState : CodeMirror.copyState(pers.mode, pers.state), 49 | next: s.persistentStates}; 50 | return s; 51 | }, 52 | token: tokenFunction(states_, config), 53 | innerMode: function(state) { return state.local && {mode: state.local.mode, state: state.localState}; }, 54 | indent: indentFunction(states_, meta) 55 | }; 56 | if (meta) for (var prop in meta) if (meta.hasOwnProperty(prop)) 57 | mode[prop] = meta[prop]; 58 | return mode; 59 | }; 60 | 61 | function ensureState(states, name) { 62 | if (!states.hasOwnProperty(name)) 63 | throw new Error("Undefined state " + name + " in simple mode"); 64 | } 65 | 66 | function toRegex(val, caret) { 67 | if (!val) return /(?:)/; 68 | var flags = ""; 69 | if (val instanceof RegExp) { 70 | if (val.ignoreCase) flags = "i"; 71 | val = val.source; 72 | } else { 73 | val = String(val); 74 | } 75 | return new RegExp((caret === false ? "" : "^") + "(?:" + val + ")", flags); 76 | } 77 | 78 | function asToken(val) { 79 | if (!val) return null; 80 | if (val.apply) return val 81 | if (typeof val == "string") return val.replace(/\./g, " "); 82 | var result = []; 83 | for (var i = 0; i < val.length; i++) 84 | result.push(val[i] && val[i].replace(/\./g, " ")); 85 | return result; 86 | } 87 | 88 | function Rule(data, states) { 89 | if (data.next || data.push) ensureState(states, data.next || data.push); 90 | this.regex = toRegex(data.regex); 91 | this.token = asToken(data.token); 92 | this.data = data; 93 | } 94 | 95 | function tokenFunction(states, config) { 96 | return function(stream, state) { 97 | if (state.pending) { 98 | var pend = state.pending.shift(); 99 | if (state.pending.length == 0) state.pending = null; 100 | stream.pos += pend.text.length; 101 | return pend.token; 102 | } 103 | 104 | if (state.local) { 105 | if (state.local.end && stream.match(state.local.end)) { 106 | var tok = state.local.endToken || null; 107 | state.local = state.localState = null; 108 | return tok; 109 | } else { 110 | var tok = state.local.mode.token(stream, state.localState), m; 111 | if (state.local.endScan && (m = state.local.endScan.exec(stream.current()))) 112 | stream.pos = stream.start + m.index; 113 | return tok; 114 | } 115 | } 116 | 117 | var curState = states[state.state]; 118 | for (var i = 0; i < curState.length; i++) { 119 | var rule = curState[i]; 120 | var matches = (!rule.data.sol || stream.sol()) && stream.match(rule.regex); 121 | if (matches) { 122 | if (rule.data.next) { 123 | state.state = rule.data.next; 124 | } else if (rule.data.push) { 125 | (state.stack || (state.stack = [])).push(state.state); 126 | state.state = rule.data.push; 127 | } else if (rule.data.pop && state.stack && state.stack.length) { 128 | state.state = state.stack.pop(); 129 | } 130 | 131 | if (rule.data.mode) 132 | enterLocalMode(config, state, rule.data.mode, rule.token); 133 | if (rule.data.indent) 134 | state.indent.push(stream.indentation() + config.indentUnit); 135 | if (rule.data.dedent) 136 | state.indent.pop(); 137 | var token = rule.token 138 | if (token && token.apply) token = token(matches) 139 | if (matches.length > 2 && rule.token && typeof rule.token != "string") { 140 | state.pending = []; 141 | for (var j = 2; j < matches.length; j++) 142 | if (matches[j]) 143 | state.pending.push({text: matches[j], token: rule.token[j - 1]}); 144 | stream.backUp(matches[0].length - (matches[1] ? matches[1].length : 0)); 145 | return token[0]; 146 | } else if (token && token.join) { 147 | return token[0]; 148 | } else { 149 | return token; 150 | } 151 | } 152 | } 153 | stream.next(); 154 | return null; 155 | }; 156 | } 157 | 158 | function cmp(a, b) { 159 | if (a === b) return true; 160 | if (!a || typeof a != "object" || !b || typeof b != "object") return false; 161 | var props = 0; 162 | for (var prop in a) if (a.hasOwnProperty(prop)) { 163 | if (!b.hasOwnProperty(prop) || !cmp(a[prop], b[prop])) return false; 164 | props++; 165 | } 166 | for (var prop in b) if (b.hasOwnProperty(prop)) props--; 167 | return props == 0; 168 | } 169 | 170 | function enterLocalMode(config, state, spec, token) { 171 | var pers; 172 | if (spec.persistent) for (var p = state.persistentStates; p && !pers; p = p.next) 173 | if (spec.spec ? cmp(spec.spec, p.spec) : spec.mode == p.mode) pers = p; 174 | var mode = pers ? pers.mode : spec.mode || CodeMirror.getMode(config, spec.spec); 175 | var lState = pers ? pers.state : CodeMirror.startState(mode); 176 | if (spec.persistent && !pers) 177 | state.persistentStates = {mode: mode, spec: spec.spec, state: lState, next: state.persistentStates}; 178 | 179 | state.localState = lState; 180 | state.local = {mode: mode, 181 | end: spec.end && toRegex(spec.end), 182 | endScan: spec.end && spec.forceEnd !== false && toRegex(spec.end, false), 183 | endToken: token && token.join ? token[token.length - 1] : token}; 184 | } 185 | 186 | function indexOf(val, arr) { 187 | for (var i = 0; i < arr.length; i++) if (arr[i] === val) return true; 188 | } 189 | 190 | function indentFunction(states, meta) { 191 | return function(state, textAfter, line) { 192 | if (state.local && state.local.mode.indent) 193 | return state.local.mode.indent(state.localState, textAfter, line); 194 | if (state.indent == null || state.local || meta.dontIndentStates && indexOf(state.state, meta.dontIndentStates) > -1) 195 | return CodeMirror.Pass; 196 | 197 | var pos = state.indent.length - 1, rules = states[state.state]; 198 | scan: for (;;) { 199 | for (var i = 0; i < rules.length; i++) { 200 | var rule = rules[i]; 201 | if (rule.data.dedent && rule.data.dedentIfLineStart !== false) { 202 | var m = rule.regex.exec(textAfter); 203 | if (m && m[0]) { 204 | pos--; 205 | if (rule.next || rule.push) rules = states[rule.next || rule.push]; 206 | textAfter = textAfter.slice(m[0].length); 207 | continue scan; 208 | } 209 | } 210 | } 211 | break; 212 | } 213 | return pos < 0 ? 0 : state.indent[pos]; 214 | }; 215 | } 216 | }); 217 | -------------------------------------------------------------------------------- /www/addon/scroll/simplescrollbars.css: -------------------------------------------------------------------------------- 1 | .CodeMirror-simplescroll-horizontal div, .CodeMirror-simplescroll-vertical div { 2 | position: absolute; 3 | background: #ccc; 4 | -moz-box-sizing: border-box; 5 | box-sizing: border-box; 6 | border: 1px solid #bbb; 7 | border-radius: 2px; 8 | } 9 | 10 | .CodeMirror-simplescroll-horizontal, .CodeMirror-simplescroll-vertical { 11 | position: absolute; 12 | z-index: 6; 13 | background: #eee; 14 | } 15 | 16 | .CodeMirror-simplescroll-horizontal { 17 | bottom: 0; left: 0; 18 | height: 8px; 19 | } 20 | .CodeMirror-simplescroll-horizontal div { 21 | bottom: 0; 22 | height: 100%; 23 | } 24 | 25 | .CodeMirror-simplescroll-vertical { 26 | right: 0; top: 0; 27 | width: 8px; 28 | } 29 | .CodeMirror-simplescroll-vertical div { 30 | right: 0; 31 | width: 100%; 32 | } 33 | 34 | 35 | .CodeMirror-overlayscroll .CodeMirror-scrollbar-filler, .CodeMirror-overlayscroll .CodeMirror-gutter-filler { 36 | display: none; 37 | } 38 | 39 | .CodeMirror-overlayscroll-horizontal div, .CodeMirror-overlayscroll-vertical div { 40 | position: absolute; 41 | background: #bcd; 42 | border-radius: 3px; 43 | } 44 | 45 | .CodeMirror-overlayscroll-horizontal, .CodeMirror-overlayscroll-vertical { 46 | position: absolute; 47 | z-index: 6; 48 | } 49 | 50 | .CodeMirror-overlayscroll-horizontal { 51 | bottom: 0; left: 0; 52 | height: 6px; 53 | } 54 | .CodeMirror-overlayscroll-horizontal div { 55 | bottom: 0; 56 | height: 100%; 57 | } 58 | 59 | .CodeMirror-overlayscroll-vertical { 60 | right: 0; top: 0; 61 | width: 6px; 62 | } 63 | .CodeMirror-overlayscroll-vertical div { 64 | right: 0; 65 | width: 100%; 66 | } 67 | -------------------------------------------------------------------------------- /www/addon/scroll/simplescrollbars.js: -------------------------------------------------------------------------------- 1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others 2 | // Distributed under an MIT license: https://codemirror.net/LICENSE 3 | 4 | (function(mod) { 5 | if (typeof exports == "object" && typeof module == "object") // CommonJS 6 | mod(require("../../lib/codemirror")); 7 | else if (typeof define == "function" && define.amd) // AMD 8 | define(["../../lib/codemirror"], mod); 9 | else // Plain browser env 10 | mod(CodeMirror); 11 | })(function(CodeMirror) { 12 | "use strict"; 13 | 14 | function Bar(cls, orientation, scroll) { 15 | this.orientation = orientation; 16 | this.scroll = scroll; 17 | this.screen = this.total = this.size = 1; 18 | this.pos = 0; 19 | 20 | this.node = document.createElement("div"); 21 | this.node.className = cls + "-" + orientation; 22 | this.inner = this.node.appendChild(document.createElement("div")); 23 | 24 | var self = this; 25 | CodeMirror.on(this.inner, "mousedown", function(e) { 26 | if (e.which != 1) return; 27 | CodeMirror.e_preventDefault(e); 28 | var axis = self.orientation == "horizontal" ? "pageX" : "pageY"; 29 | var start = e[axis], startpos = self.pos; 30 | function done() { 31 | CodeMirror.off(document, "mousemove", move); 32 | CodeMirror.off(document, "mouseup", done); 33 | } 34 | function move(e) { 35 | if (e.which != 1) return done(); 36 | self.moveTo(startpos + (e[axis] - start) * (self.total / self.size)); 37 | } 38 | CodeMirror.on(document, "mousemove", move); 39 | CodeMirror.on(document, "mouseup", done); 40 | }); 41 | 42 | CodeMirror.on(this.node, "click", function(e) { 43 | CodeMirror.e_preventDefault(e); 44 | var innerBox = self.inner.getBoundingClientRect(), where; 45 | if (self.orientation == "horizontal") 46 | where = e.clientX < innerBox.left ? -1 : e.clientX > innerBox.right ? 1 : 0; 47 | else 48 | where = e.clientY < innerBox.top ? -1 : e.clientY > innerBox.bottom ? 1 : 0; 49 | self.moveTo(self.pos + where * self.screen); 50 | }); 51 | 52 | function onWheel(e) { 53 | var moved = CodeMirror.wheelEventPixels(e)[self.orientation == "horizontal" ? "x" : "y"]; 54 | var oldPos = self.pos; 55 | self.moveTo(self.pos + moved); 56 | if (self.pos != oldPos) CodeMirror.e_preventDefault(e); 57 | } 58 | CodeMirror.on(this.node, "mousewheel", onWheel); 59 | CodeMirror.on(this.node, "DOMMouseScroll", onWheel); 60 | } 61 | 62 | Bar.prototype.setPos = function(pos, force) { 63 | if (pos < 0) pos = 0; 64 | if (pos > this.total - this.screen) pos = this.total - this.screen; 65 | if (!force && pos == this.pos) return false; 66 | this.pos = pos; 67 | this.inner.style[this.orientation == "horizontal" ? "left" : "top"] = 68 | (pos * (this.size / this.total)) + "px"; 69 | return true 70 | }; 71 | 72 | Bar.prototype.moveTo = function(pos) { 73 | if (this.setPos(pos)) this.scroll(pos, this.orientation); 74 | } 75 | 76 | var minButtonSize = 10; 77 | 78 | Bar.prototype.update = function(scrollSize, clientSize, barSize) { 79 | var sizeChanged = this.screen != clientSize || this.total != scrollSize || this.size != barSize 80 | if (sizeChanged) { 81 | this.screen = clientSize; 82 | this.total = scrollSize; 83 | this.size = barSize; 84 | } 85 | 86 | var buttonSize = this.screen * (this.size / this.total); 87 | if (buttonSize < minButtonSize) { 88 | this.size -= minButtonSize - buttonSize; 89 | buttonSize = minButtonSize; 90 | } 91 | this.inner.style[this.orientation == "horizontal" ? "width" : "height"] = 92 | buttonSize + "px"; 93 | this.setPos(this.pos, sizeChanged); 94 | }; 95 | 96 | function SimpleScrollbars(cls, place, scroll) { 97 | this.addClass = cls; 98 | this.horiz = new Bar(cls, "horizontal", scroll); 99 | place(this.horiz.node); 100 | this.vert = new Bar(cls, "vertical", scroll); 101 | place(this.vert.node); 102 | this.width = null; 103 | } 104 | 105 | SimpleScrollbars.prototype.update = function(measure) { 106 | if (this.width == null) { 107 | var style = window.getComputedStyle ? window.getComputedStyle(this.horiz.node) : this.horiz.node.currentStyle; 108 | if (style) this.width = parseInt(style.height); 109 | } 110 | var width = this.width || 0; 111 | 112 | var needsH = measure.scrollWidth > measure.clientWidth + 1; 113 | var needsV = measure.scrollHeight > measure.clientHeight + 1; 114 | this.vert.node.style.display = needsV ? "block" : "none"; 115 | this.horiz.node.style.display = needsH ? "block" : "none"; 116 | 117 | if (needsV) { 118 | this.vert.update(measure.scrollHeight, measure.clientHeight, 119 | measure.viewHeight - (needsH ? width : 0)); 120 | this.vert.node.style.bottom = needsH ? width + "px" : "0"; 121 | } 122 | if (needsH) { 123 | this.horiz.update(measure.scrollWidth, measure.clientWidth, 124 | measure.viewWidth - (needsV ? width : 0) - measure.barLeft); 125 | this.horiz.node.style.right = needsV ? width + "px" : "0"; 126 | this.horiz.node.style.left = measure.barLeft + "px"; 127 | } 128 | 129 | return {right: needsV ? width : 0, bottom: needsH ? width : 0}; 130 | }; 131 | 132 | SimpleScrollbars.prototype.setScrollTop = function(pos) { 133 | this.vert.setPos(pos); 134 | }; 135 | 136 | SimpleScrollbars.prototype.setScrollLeft = function(pos) { 137 | this.horiz.setPos(pos); 138 | }; 139 | 140 | SimpleScrollbars.prototype.clear = function() { 141 | var parent = this.horiz.node.parentNode; 142 | parent.removeChild(this.horiz.node); 143 | parent.removeChild(this.vert.node); 144 | }; 145 | 146 | CodeMirror.scrollbarModel.simple = function(place, scroll) { 147 | return new SimpleScrollbars("CodeMirror-simplescroll", place, scroll); 148 | }; 149 | CodeMirror.scrollbarModel.overlay = function(place, scroll) { 150 | return new SimpleScrollbars("CodeMirror-overlayscroll", place, scroll); 151 | }; 152 | }); 153 | -------------------------------------------------------------------------------- /www/examples/channel.affe: -------------------------------------------------------------------------------- 1 | ## Channels 2 | # 3 | # We use channels as a basic example of the various concepts availble in Affe 4 | 5 | ## Prelude 6 | # Let's assume the existence of strings 7 | type string 8 | 9 | # Channels are affine. 10 | # This means that a channel can be used at most once. 11 | # It can't be aliased and used by two different functions, 12 | # but it can be "dropped", which means it can stay unused 13 | # 14 | # Affe supports three kinds: 15 | # - `un` : Unrestricted, can be used arbitrarely 16 | # - `aff` : Affine, can be used at most once 17 | # - `lin` : Must be used exactly once 18 | type channel : aff 19 | 20 | # We can open a channel at a particular addresse/file/.. 21 | val open : string -> channel 22 | 23 | # We can close a channel explicitely 24 | val close : channel -> unit 25 | 26 | # We can send and receive data from a channel 27 | # Since the channel can not be aliased, this takes the handle 28 | # on the channel, and then return it again 29 | val send : int -> channel -> channel 30 | val receive : channel -> int * channel 31 | 32 | ## Basic programs on channels 33 | 34 | # Open a channel, wait for a message, send it back 35 | let echo_once s = 36 | let ch = open s in 37 | let (msg, ch) = receive ch in 38 | let ch = send msg ch in 39 | let () = close ch in # This `close` is optional, since channels are affines. 40 | # let x = send msg ch in # This would fail 41 | () 42 | 43 | # A common function on channels 44 | let with_channel s f = 45 | let ch = open s in 46 | let ch = f ch in 47 | close ch 48 | 49 | # The type of `with_channel` is 50 | # ∀^a. string -> (channel -{^a}> channel) -> unit 51 | # The annotation on the arrow indicate the linearity. 52 | # It's time to study arrows more closely. 53 | 54 | 55 | ## Interlude on arrows 56 | # 57 | # Let us consider a function that applies a closure on a range of integer 58 | 59 | let iter_integers = 60 | let rec aux f i j = 61 | match i = j with { 62 | | True -> () 63 | | False -> 64 | let () = f i in 65 | aux f (i+1) j 66 | } 67 | in 68 | aux 69 | 70 | # This function takes a closure of type `int -{^a}> unit` 71 | # Where `^a` is a *kind* variable that must respect the constraints `^a < unₙ` 72 | # 73 | # Indeed, the closure is called multiple time. if it captured anything linear, 74 | # it could use it multiple time! 75 | 76 | # We can try to send multiple integers by uncommenting the following code: 77 | 78 | # let send_integers s = 79 | # let ch = open s in 80 | # let k msg = let _unused = send msg ch in () in 81 | # iter_integers k 0 10 82 | 83 | # We get an error indicating than the function `k` is `affine`, as it captures 84 | # the channel `ch` which is affine, and thus can not be passed to `iter_integers` 85 | -------------------------------------------------------------------------------- /www/examples/intro.affe: -------------------------------------------------------------------------------- 1 | ## Hello 2 | 3 | let s = 42 -------------------------------------------------------------------------------- /www/examples/sessions.affe: -------------------------------------------------------------------------------- 1 | ## Session types 2 | # 3 | # This follow the encoding by Luca Padovani in 4 | # A simple library implementation of binary sessions 5 | # See http://www.di.unito.it/~padovani/Software/FuSe/FuSe.html 6 | 7 | # The either type is useful for choices 8 | type ('a: 'k, 'b: 'k) either = Left of 'a | Right of 'b 9 | 10 | ## Session type primitives 11 | # 12 | # These should be defined in term of lower level network primitives. 13 | # Here, we just state them without any implemnetation 14 | 15 | # First, a typed channel. 16 | # `lin` specifies that this channel must be used linearly. 17 | # This is the only linearity annotation in the whole file 18 | type ('a : _, 'b: _) st : lin 19 | 20 | type empty 21 | 22 | # The various functions on channels. See Padonvani's paper for the 23 | # explanations of the encoding 24 | val receive: 25 | \ ('a:_)('b:_)('m:'k). 26 | ('m * ('a, 'b) st, empty) st -> 'm * ('a, 'b) st 27 | val send : 28 | \ ('a:_)('b:_)('m:'k). 29 | 'm -> (empty, 'm * ('a, 'b) st) st -{'k}> ('b, 'a) st 30 | val create : 31 | \ ('a:_) ('b:_). 32 | unit -> ('a, 'b) st * ('b, 'a) st 33 | val close : (empty, empty) st -> unit 34 | val select : 35 | \ ('a:_)('b:_)('m:_). 36 | (('a, 'b) st -> 'm) -> (empty, 'm) st -> ('b, 'a) st 37 | val branch : \ ('m:_). ('m, empty) st -> 'm 38 | 39 | ## Protocol implementation 40 | # 41 | # These directly follow the basic examples. 42 | 43 | let op_client ep x y = 44 | let ep = send x ep in 45 | let ep = send y ep in 46 | let (result, ep) = receive ep in 47 | let u = close ep in 48 | result 49 | 50 | let add_service ep = 51 | let (x, ep) = receive ep in 52 | let (y, ep) = receive ep in 53 | let ep = send (x + y) ep in 54 | close ep 55 | 56 | let dec_service ep = 57 | let (x, ep) = receive ep in 58 | let ep = send (x - 1) ep in 59 | close ep 60 | 61 | let math_service ep = 62 | let b = branch ep in 63 | match b with { 64 | | Left x -> add_service x 65 | | Right x -> dec_service x 66 | } 67 | 68 | let main1 () = 69 | let (a, b) = create () in 70 | let () = math_service a in 71 | let b = select Left b in 72 | op_client b 1 2 73 | 74 | let main2 () = 75 | let (a, b) = create () in 76 | let () = math_service a in 77 | let ep = select Right b in 78 | let ep = send 4 ep in 79 | let (result, ep) = receive ep in 80 | let () = close ep in 81 | result -------------------------------------------------------------------------------- /www/examples/sudoku.affe: -------------------------------------------------------------------------------- 1 | ## Sudoku solver 2 | # 3 | # One efficient way to represent a sudoku board is to use a matrix 4 | # where each cell contains a set of acceptable integers. 5 | # The algorithms will then pick a number, and propagate the changes 6 | # in the various cells by mutating the board. 7 | # Unfortunately, solving sudoku might ocasionally involve some 8 | # backtracking. At this point, the board must be copied. 9 | 10 | ## 1 We state the various primitive functions we need 11 | val array_init : 12 | \ 'k ('a : _). int -> (int -{'k}> 'a) -{'k}> 'a array 13 | val array_length : \ 'k ('a:_). &('k, 'a array) -> int 14 | val array_for_all : 15 | \ 'k 'k2 ('a: _) . 16 | ('a -{'k2}> bool) -> &('k, 'a array) -{'k2}> bool 17 | val array_get : \ 'k ('a:_). &('k, 'a array) * int -> 'a 18 | val array_set : \ 'k ('a:_). &!('k, 'a array) * int * 'a -> unit 19 | val not : bool -> bool 20 | val and : bool -> bool -> bool 21 | 22 | ## 2 We import the hybrid arrays (see cow.affe for more details) 23 | let get (x, i) = x.(i) 24 | let copy a = array_init (array_length a) (fun i -> a.(i)) 25 | let set (a, i, x) = 26 | let a2 = copy a in 27 | let x = (&!a2).(i) <- x in 28 | a2 29 | let set_mut (a, i, x) = a.(i) <- x 30 | 31 | ## 3 We state a notion of integer sets 32 | 33 | type intset 34 | val empty : intset 35 | val add : intset -> int -> intset 36 | val rm : intset -> int -> intset 37 | val iter_set : \ 'k . (int -{'k}> unit) -> intset -{'k}> unit 38 | val cardinal : intset -> int 39 | val print : \ 'k . &('k,intset array) -> unit 40 | 41 | ## 4 Various utilities functions 42 | 43 | # Size of the board 44 | let size = 9 45 | 46 | # Hybrid matrices operations 47 | let get x (i, j) = get (x, i*size+j) 48 | let set_mut x (i, j) v = set_mut (x, i*size+j, v) 49 | let set x (i, j) v = set (x, i*size+j, v) 50 | 51 | # the for loop function 52 | let for = 53 | let rec aux i j f = 54 | match i > j with { 55 | | True -> () 56 | | False -> 57 | let () = f i in 58 | aux (i+1) j f 59 | } 60 | in aux 61 | 62 | ## 5 Finally, we can solve the sudoku! 63 | 64 | # A full cell with all numbers from 1 to 9 65 | let full_cell = 66 | let rec f i xset = 67 | match i < 0 with { 68 | | True -> xset 69 | | False -> f (i - 1) (add xset i) 70 | } 71 | in 72 | f (size - 1) empty 73 | 74 | # A cell with only a single number 75 | let singleton n = add empty n 76 | 77 | ## The next 3 functions aims to propagate changes on the board. 78 | # They take a *mutable* borrow of the board, and make a series of 79 | # mutable modifications to it. 80 | 81 | # Remove the number `n` from the line after `(i0,j0)` 82 | let remove_line i0 j0 g n = 83 | for (j0+1) (size - 1) (fun j -> 84 | let cell = rm (get &&g (i0 , j)) n in 85 | set_mut &&!g (i0, j) cell 86 | ) 87 | 88 | # Remove the number `n` from the column after `(i0,j0)` 89 | let remove_column i0 j0 g n = 90 | for (i0+1) (size - 1) (fun i -> 91 | let cell = rm (get &&g (i , j0)) n in 92 | set_mut &&!g (i , j0) cell 93 | ) 94 | 95 | # Remove the number `n` from the square containing `(i0,j0)` 96 | let remove_square i0 j0 g n = 97 | let pos_i = i0 / 3 in 98 | let pos_j = j0 / 3 in 99 | for (3*pos_i) (3*(pos_i+1) - 1) (fun i -> 100 | for (3*pos_j) (3*(pos_j+1) - 1) (fun j -> 101 | match and (i = i0) (j = j0) with { 102 | | False -> 103 | let cell = rm (get &&g (i , j)) n in 104 | set_mut &&!g (i , j) cell 105 | | True -> 106 | () 107 | } 108 | ) 109 | ) 110 | 111 | # The general function that propagate solving decisions. 112 | # Note the reuse of the mutable borrow in sequence. 113 | # This is perfectly allowed, since no reference to the borrow 114 | # is kept. 115 | let remove i j g n = 116 | let () = remove_line i j &&!g n in 117 | let () = remove_column i j &&!g n in 118 | let () = remove_square i j &&!g n in 119 | () 120 | 121 | let is_valid g = 122 | array_for_all (fun x -> cardinal x > 0) g 123 | 124 | let is_solved g = 125 | array_for_all (fun x -> cardinal x = 1) g 126 | 127 | let next_pos (i, j) = 128 | match j < (size - 1) with { 129 | | True -> (i, j + 1) 130 | | False -> (i + 1, 0) 131 | } 132 | 133 | # The recursive function that solves the sudoku. 134 | # It walks over each cell, branches off by picking 135 | # one of the possible number for that cell, doing an 136 | # immutable modification of the cell, propagating the change, 137 | # and calling the function recursively. 138 | # 139 | # The `try_solution` captures an *immutable* borrow of the current 140 | # board, which allows it to be called multiple times, for each 141 | let solve = 142 | let rec solve i j g = 143 | match is_solved &g with { 144 | | True -> print &g 145 | | False -> 146 | let s = get &g (i,j) in 147 | let (new_i, new_j) = next_pos (i,j) in 148 | let try_solution n = 149 | let new_g = set &g (i,j) (singleton n) in 150 | let () = remove i j &!new_g n in 151 | match is_valid &new_g with { 152 | | True -> solve new_i new_j new_g 153 | | False -> () 154 | } 155 | in 156 | iter_set try_solution s 157 | } 158 | in solve -------------------------------------------------------------------------------- /www/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | language 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 |
22 |
23 |
24 |

25 | Run 27 | Clear log 29 | Clear editor 31 |
32 |
33 |
34 |
35 |
36 |

LANG

37 |
38 |
39 |

List of examples

40 |
41 |
42 |
43 | 44 | 45 | -------------------------------------------------------------------------------- /www/lib/codemirror.css: -------------------------------------------------------------------------------- 1 | /* BASICS */ 2 | 3 | .CodeMirror { 4 | /* Set height, width, borders, and global font properties here */ 5 | font-family: monospace; 6 | height: 300px; 7 | color: black; 8 | direction: ltr; 9 | } 10 | 11 | /* PADDING */ 12 | 13 | .CodeMirror-lines { 14 | padding: 4px 0; /* Vertical padding around content */ 15 | } 16 | .CodeMirror pre { 17 | padding: 0 4px; /* Horizontal padding of content */ 18 | } 19 | 20 | .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler { 21 | background-color: white; /* The little square between H and V scrollbars */ 22 | } 23 | 24 | /* GUTTER */ 25 | 26 | .CodeMirror-gutters { 27 | border-right: 1px solid #ddd; 28 | background-color: #f7f7f7; 29 | white-space: nowrap; 30 | } 31 | .CodeMirror-linenumbers {} 32 | .CodeMirror-linenumber { 33 | padding: 0 3px 0 5px; 34 | min-width: 20px; 35 | text-align: right; 36 | color: #999; 37 | white-space: nowrap; 38 | } 39 | 40 | .CodeMirror-guttermarker { color: black; } 41 | .CodeMirror-guttermarker-subtle { color: #999; } 42 | 43 | /* CURSOR */ 44 | 45 | .CodeMirror-cursor { 46 | border-left: 1px solid black; 47 | border-right: none; 48 | width: 0; 49 | } 50 | /* Shown when moving in bi-directional text */ 51 | .CodeMirror div.CodeMirror-secondarycursor { 52 | border-left: 1px solid silver; 53 | } 54 | .cm-fat-cursor .CodeMirror-cursor { 55 | width: auto; 56 | border: 0 !important; 57 | background: #7e7; 58 | } 59 | .cm-fat-cursor div.CodeMirror-cursors { 60 | z-index: 1; 61 | } 62 | .cm-fat-cursor-mark { 63 | background-color: rgba(20, 255, 20, 0.5); 64 | -webkit-animation: blink 1.06s steps(1) infinite; 65 | -moz-animation: blink 1.06s steps(1) infinite; 66 | animation: blink 1.06s steps(1) infinite; 67 | } 68 | .cm-animate-fat-cursor { 69 | width: auto; 70 | border: 0; 71 | -webkit-animation: blink 1.06s steps(1) infinite; 72 | -moz-animation: blink 1.06s steps(1) infinite; 73 | animation: blink 1.06s steps(1) infinite; 74 | background-color: #7e7; 75 | } 76 | @-moz-keyframes blink { 77 | 0% {} 78 | 50% { background-color: transparent; } 79 | 100% {} 80 | } 81 | @-webkit-keyframes blink { 82 | 0% {} 83 | 50% { background-color: transparent; } 84 | 100% {} 85 | } 86 | @keyframes blink { 87 | 0% {} 88 | 50% { background-color: transparent; } 89 | 100% {} 90 | } 91 | 92 | /* Can style cursor different in overwrite (non-insert) mode */ 93 | .CodeMirror-overwrite .CodeMirror-cursor {} 94 | 95 | .cm-tab { display: inline-block; text-decoration: inherit; } 96 | 97 | .CodeMirror-rulers { 98 | position: absolute; 99 | left: 0; right: 0; top: -50px; bottom: -20px; 100 | overflow: hidden; 101 | } 102 | .CodeMirror-ruler { 103 | border-left: 1px solid #ccc; 104 | top: 0; bottom: 0; 105 | position: absolute; 106 | } 107 | 108 | /* DEFAULT THEME */ 109 | 110 | .cm-s-default .cm-header {color: blue;} 111 | .cm-s-default .cm-quote {color: #090;} 112 | .cm-negative {color: #d44;} 113 | .cm-positive {color: #292;} 114 | .cm-header, .cm-strong {font-weight: bold;} 115 | .cm-em {font-style: italic;} 116 | .cm-link {text-decoration: underline;} 117 | .cm-strikethrough {text-decoration: line-through;} 118 | 119 | .cm-s-default .cm-keyword {color: #708;} 120 | .cm-s-default .cm-atom {color: #219;} 121 | .cm-s-default .cm-number {color: #164;} 122 | .cm-s-default .cm-def {color: #00f;} 123 | .cm-s-default .cm-variable, 124 | .cm-s-default .cm-punctuation, 125 | .cm-s-default .cm-property, 126 | .cm-s-default .cm-operator {} 127 | .cm-s-default .cm-variable-2 {color: #05a;} 128 | .cm-s-default .cm-variable-3, .cm-s-default .cm-type {color: #085;} 129 | .cm-s-default .cm-comment {color: #a50;} 130 | .cm-s-default .cm-string {color: #a11;} 131 | .cm-s-default .cm-string-2 {color: #f50;} 132 | .cm-s-default .cm-meta {color: #555;} 133 | .cm-s-default .cm-qualifier {color: #555;} 134 | .cm-s-default .cm-builtin {color: #30a;} 135 | .cm-s-default .cm-bracket {color: #997;} 136 | .cm-s-default .cm-tag {color: #170;} 137 | .cm-s-default .cm-attribute {color: #00c;} 138 | .cm-s-default .cm-hr {color: #999;} 139 | .cm-s-default .cm-link {color: #00c;} 140 | 141 | .cm-s-default .cm-error {color: #f00;} 142 | .cm-invalidchar {color: #f00;} 143 | 144 | .CodeMirror-composing { border-bottom: 2px solid; } 145 | 146 | /* Default styles for common addons */ 147 | 148 | div.CodeMirror span.CodeMirror-matchingbracket {color: #0b0;} 149 | div.CodeMirror span.CodeMirror-nonmatchingbracket {color: #a22;} 150 | .CodeMirror-matchingtag { background: rgba(255, 150, 0, .3); } 151 | .CodeMirror-activeline-background {background: #e8f2ff;} 152 | 153 | /* STOP */ 154 | 155 | /* The rest of this file contains styles related to the mechanics of 156 | the editor. You probably shouldn't touch them. */ 157 | 158 | .CodeMirror { 159 | position: relative; 160 | overflow: hidden; 161 | background: white; 162 | } 163 | 164 | .CodeMirror-scroll { 165 | overflow: scroll !important; /* Things will break if this is overridden */ 166 | /* 30px is the magic margin used to hide the element's real scrollbars */ 167 | /* See overflow: hidden in .CodeMirror */ 168 | margin-bottom: -30px; margin-right: -30px; 169 | padding-bottom: 30px; 170 | height: 100%; 171 | outline: none; /* Prevent dragging from highlighting the element */ 172 | position: relative; 173 | } 174 | .CodeMirror-sizer { 175 | position: relative; 176 | border-right: 30px solid transparent; 177 | } 178 | 179 | /* The fake, visible scrollbars. Used to force redraw during scrolling 180 | before actual scrolling happens, thus preventing shaking and 181 | flickering artifacts. */ 182 | .CodeMirror-vscrollbar, .CodeMirror-hscrollbar, .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler { 183 | position: absolute; 184 | z-index: 6; 185 | display: none; 186 | } 187 | .CodeMirror-vscrollbar { 188 | right: 0; top: 0; 189 | overflow-x: hidden; 190 | overflow-y: scroll; 191 | } 192 | .CodeMirror-hscrollbar { 193 | bottom: 0; left: 0; 194 | overflow-y: hidden; 195 | overflow-x: scroll; 196 | } 197 | .CodeMirror-scrollbar-filler { 198 | right: 0; bottom: 0; 199 | } 200 | .CodeMirror-gutter-filler { 201 | left: 0; bottom: 0; 202 | } 203 | 204 | .CodeMirror-gutters { 205 | position: absolute; left: 0; top: 0; 206 | min-height: 100%; 207 | z-index: 3; 208 | } 209 | .CodeMirror-gutter { 210 | white-space: normal; 211 | height: 100%; 212 | display: inline-block; 213 | vertical-align: top; 214 | margin-bottom: -30px; 215 | } 216 | .CodeMirror-gutter-wrapper { 217 | position: absolute; 218 | z-index: 4; 219 | background: none !important; 220 | border: none !important; 221 | } 222 | .CodeMirror-gutter-background { 223 | position: absolute; 224 | top: 0; bottom: 0; 225 | z-index: 4; 226 | } 227 | .CodeMirror-gutter-elt { 228 | position: absolute; 229 | cursor: default; 230 | z-index: 4; 231 | } 232 | .CodeMirror-gutter-wrapper ::selection { background-color: transparent } 233 | .CodeMirror-gutter-wrapper ::-moz-selection { background-color: transparent } 234 | 235 | .CodeMirror-lines { 236 | cursor: text; 237 | min-height: 1px; /* prevents collapsing before first draw */ 238 | } 239 | .CodeMirror pre { 240 | /* Reset some styles that the rest of the page might have set */ 241 | -moz-border-radius: 0; -webkit-border-radius: 0; border-radius: 0; 242 | border-width: 0; 243 | background: transparent; 244 | font-family: inherit; 245 | font-size: inherit; 246 | margin: 0; 247 | white-space: pre; 248 | word-wrap: normal; 249 | line-height: inherit; 250 | color: inherit; 251 | z-index: 2; 252 | position: relative; 253 | overflow: visible; 254 | -webkit-tap-highlight-color: transparent; 255 | -webkit-font-variant-ligatures: contextual; 256 | font-variant-ligatures: contextual; 257 | } 258 | .CodeMirror-wrap pre { 259 | word-wrap: break-word; 260 | white-space: pre-wrap; 261 | word-break: normal; 262 | } 263 | 264 | .CodeMirror-linebackground { 265 | position: absolute; 266 | left: 0; right: 0; top: 0; bottom: 0; 267 | z-index: 0; 268 | } 269 | 270 | .CodeMirror-linewidget { 271 | position: relative; 272 | z-index: 2; 273 | padding: 0.1px; /* Force widget margins to stay inside of the container */ 274 | } 275 | 276 | .CodeMirror-widget {} 277 | 278 | .CodeMirror-rtl pre { direction: rtl; } 279 | 280 | .CodeMirror-code { 281 | outline: none; 282 | } 283 | 284 | /* Force content-box sizing for the elements where we expect it */ 285 | .CodeMirror-scroll, 286 | .CodeMirror-sizer, 287 | .CodeMirror-gutter, 288 | .CodeMirror-gutters, 289 | .CodeMirror-linenumber { 290 | -moz-box-sizing: content-box; 291 | box-sizing: content-box; 292 | } 293 | 294 | .CodeMirror-measure { 295 | position: absolute; 296 | width: 100%; 297 | height: 0; 298 | overflow: hidden; 299 | visibility: hidden; 300 | } 301 | 302 | .CodeMirror-cursor { 303 | position: absolute; 304 | pointer-events: none; 305 | } 306 | .CodeMirror-measure pre { position: static; } 307 | 308 | div.CodeMirror-cursors { 309 | visibility: hidden; 310 | position: relative; 311 | z-index: 3; 312 | } 313 | div.CodeMirror-dragcursors { 314 | visibility: visible; 315 | } 316 | 317 | .CodeMirror-focused div.CodeMirror-cursors { 318 | visibility: visible; 319 | } 320 | 321 | .CodeMirror-selected { background: #d9d9d9; } 322 | .CodeMirror-focused .CodeMirror-selected { background: #d7d4f0; } 323 | .CodeMirror-crosshair { cursor: crosshair; } 324 | .CodeMirror-line::selection, .CodeMirror-line > span::selection, .CodeMirror-line > span > span::selection { background: #d7d4f0; } 325 | .CodeMirror-line::-moz-selection, .CodeMirror-line > span::-moz-selection, .CodeMirror-line > span > span::-moz-selection { background: #d7d4f0; } 326 | 327 | .cm-searching { 328 | background-color: #ffa; 329 | background-color: rgba(255, 255, 0, .4); 330 | } 331 | 332 | /* Used to force a border model for a node */ 333 | .cm-force-border { padding-right: .1px; } 334 | 335 | @media print { 336 | /* Hide the cursor when printing */ 337 | .CodeMirror div.CodeMirror-cursors { 338 | visibility: hidden; 339 | } 340 | } 341 | 342 | /* See issue #2901 */ 343 | .cm-tab-wrap-hack:after { content: ''; } 344 | 345 | /* Help users use markselection to safely style text background */ 346 | span.CodeMirror-selectedtext { background: none; } 347 | -------------------------------------------------------------------------------- /www/mode/affe/affe.js: -------------------------------------------------------------------------------- 1 | (function(mod) { 2 | if (typeof exports == "object" && typeof module == "object") // CommonJS 3 | mod(require("../../lib/codemirror")); 4 | else if (typeof define == "function" && define.amd) // AMD 5 | define(["../../lib/codemirror"], mod); 6 | else // Plain browser env 7 | mod(CodeMirror); 8 | })(function(CodeMirror) { 9 | "use strict"; 10 | 11 | function RegExpPrepare (s) { 12 | return s.replace(/[-\/\\^$*+?.()|[\]{}]/g, '\\$&'); 13 | }; 14 | 15 | var keywords = [ 16 | "type", "fun", "val", "match", "of", "include", "fix", 17 | "rec", "let", "in", "for","all", "un", "aff", "lin" 18 | ]; 19 | 20 | var op = [ 21 | "=", ";", ":", ".", ",", "|", "\u2200", 22 | "*", "/", "+", "-", "%", ">", "<", "->", "<-", "\\" 23 | ]; 24 | var op2 = [ 25 | "-{", "}>", "&&!", "&&", "&!", "&" 26 | ]; 27 | 28 | function mkre (l) { 29 | return '(?:' + l.map(RegExpPrepare).join('|') + ')' 30 | }; 31 | 32 | var tyRE = /['^][a-z_'A-Z0-9]*[₀₁₂₃₄₅₆₇₈₉]*/u; 33 | var smallRE = /[a-z_][a-z_'A-Z0-9]*/; 34 | var largeRE = /[A-Z][a-z_'A-Z0-9]*/; 35 | var intRE = /[0-9]+/; 36 | 37 | var mode = { 38 | // The start state contains the rules that are intially used 39 | start: [ 40 | {regex: /\(\*/, token: "comment", next: "comment"}, 41 | {regex: /\##.*/, token: "comment-2"}, 42 | {regex: /\#.*/, token: "comment"}, 43 | {regex: new RegExp (mkre(keywords) + '\\b'), token: "keyword"}, 44 | {regex: new RegExp (mkre(op2)), token: "builtin"}, 45 | {regex: new RegExp (mkre(op)), token: "operator"}, 46 | {regex: /"(?:[^\\]|\\.)*?(?:"|$)/, token: "string"}, 47 | 48 | // A next property will cause the mode to move to a different state 49 | // indent and dedent properties guide autoindentation 50 | {regex: /[\{\[\(]/, token: "bracket", indent: true}, 51 | {regex: /[\}\]\)]/, token: "bracket", dedent: true}, 52 | {regex: new RegExp(smallRE), token: "variable"}, 53 | {regex: new RegExp(largeRE), token: "variable-2"}, 54 | {regex: new RegExp(tyRE), token: "type"}, 55 | {regex: new RegExp(intRE, 'i'), token: "number"}, 56 | ], 57 | // The multi-line comment state. 58 | comment: [ 59 | {regex: /.*?\*\)/, token: "comment", next: "start"}, 60 | {regex: /.*/, token: "comment"} 61 | ], 62 | // The meta property contains global information about the mode. It 63 | // can contain properties like lineComment, which are supported by 64 | // all modes, and also directives like dontIndentStates, which are 65 | // specific to simple modes. 66 | meta: { 67 | dontIndentStates: ["comment"], 68 | lineComment: "#" 69 | } 70 | }; 71 | 72 | CodeMirror.defineSimpleMode("affe", mode); 73 | CodeMirror.defineMIME("text/x-affe", "affe"); 74 | 75 | }); 76 | -------------------------------------------------------------------------------- /www/script.js: -------------------------------------------------------------------------------- 1 | var filename = "" 2 | var edit = undefined; 3 | var term = undefined; 4 | 5 | function loadfile(fn) { 6 | window.location.hash = fn; 7 | dir = "examples/"; 8 | filename = fn; 9 | $.ajax({ 10 | type : "GET", 11 | url : dir + fn, 12 | dataType : 'text', 13 | success : function (data) {edit.setValue(data);} 14 | }); 15 | } 16 | 17 | $(function() { 18 | // Creation of editors. 19 | edit = CodeMirror(document.getElementById("edit"), { 20 | lineNumbers : true, 21 | lineWrapping : true, 22 | theme : "solarized", 23 | scrollbarStyle : "simple" 24 | }); 25 | 26 | edit.on('cursorActivity', 27 | function(instance){ 28 | var pos = instance.getCursor(); 29 | $( "#pos" ).text((pos.line+1)+','+pos.ch); 30 | }); 31 | 32 | term = CodeMirror(document.getElementById("term"), { 33 | lineWrapping : true, 34 | readOnly : false, 35 | theme : "solarized", 36 | scrollbarStyle : "simple" 37 | }); 38 | 39 | // Loading default file in the editor. 40 | var s = location.hash.substring(1) ; 41 | if (s === "") { s = "intro.affe"; }; 42 | loadfile(s); 43 | 44 | // Making things resizable. 45 | $( "#west" ).resizable({ 46 | handles : "e", 47 | minWidth : 400, 48 | maxWidth : (document.body.clientWidth - 400) 49 | }); 50 | 51 | $( "#edit" ).resizable({ 52 | handles : "s", 53 | minHeight : 100, 54 | maxHeight : (document.body.clientHeight - 120), 55 | resize : 56 | function( event, ui ) { 57 | $( "#term" ).css("height", "calc(100% - "+ui.size.height+"px - 3ex)"); 58 | term.refresh(); 59 | edit.refresh(); 60 | } 61 | }); 62 | }); 63 | 64 | 65 | // var worker_handler = new Object (); 66 | 67 | function clear_term() { 68 | term.setValue('') 69 | } 70 | 71 | function add_to_term(s) { 72 | var doc = term.getDoc(); 73 | var line = doc.lastLine(); 74 | var pos = { 75 | line: line, 76 | ch: doc.getLine(line).length 77 | // set the character position to the end of the line 78 | } 79 | doc.replaceRange(s, pos); // adds a new line 80 | } 81 | function flush_term() { 82 | var doc = term.getDoc(); 83 | term.scrollIntoView(doc.getCursor()); 84 | } 85 | 86 | // worker.onmessage = 87 | // function (m) { 88 | // if (m.data.typ != 'result') add_to_term(m.data.result); 89 | // else add_to_term(m.data.result); 90 | // } 91 | 92 | // function ASYNCH (action_name, action_args, cont) { 93 | // worker_handler[action_name] = cont; 94 | // worker.postMessage ({fname: action_name, args: action_args}); 95 | // } 96 | 97 | function eval() { 98 | var s = edit.getValue(); 99 | Affe.eval (filename, s); 100 | } 101 | -------------------------------------------------------------------------------- /www/style.css: -------------------------------------------------------------------------------- 1 | /* Colors from Solarized (http://ethanschoonover.com/solarized) */ 2 | .CodeMirror { 3 | height : 100%; 4 | background-color : #073642; 5 | font-weight : bold; 6 | font-size: 18px; 7 | } 8 | 9 | .cm-s-solarized .CodeMirror-gutters { 10 | background-color : #002b36; 11 | border : none; 12 | } 13 | 14 | .CodeMirror-simplescroll-vertical { 15 | background-color : #002b36; 16 | width : 14px; 17 | } 18 | 19 | .CodeMirror-simplescroll-vertical div { 20 | border : none; 21 | border-left : 4px solid #002b36; 22 | background-color : #586e75; 23 | } 24 | 25 | html, body { 26 | padding : 0px; 27 | margin : 0px; 28 | height : 100%; 29 | } 30 | 31 | h1 { 32 | text-align : center; 33 | } 34 | 35 | p { 36 | text-align : justify; 37 | } 38 | 39 | a { 40 | color : #268bd2; 41 | text-decoration : none; 42 | } 43 | 44 | a:hover { 45 | color : #dc322f; 46 | } 47 | 48 | a.file { 49 | color : #b58900; 50 | } 51 | 52 | a.file:hover { 53 | color : #dc322f; 54 | } 55 | 56 | #text { 57 | padding-left : 20px; 58 | padding-right : 20px; 59 | } 60 | 61 | #west { 62 | width : 800px; 63 | height : 100%; 64 | float : left; 65 | overflow : hidden; 66 | border-right : 4px solid #002b36; 67 | } 68 | 69 | #edit { 70 | width : 100%; 71 | height : 70%; 72 | border-bottom : 4px solid #002b36; 73 | } 74 | 75 | #panel { 76 | width : 100%; 77 | height : 3ex; 78 | background-color : #002b36; 79 | font-weight : bold; 80 | margin : 0px; 81 | padding : 0px; 82 | } 83 | 84 | #panel a { 85 | color : #93a1a1; 86 | margin-left : 30px; 87 | } 88 | 89 | #panel a:hover { 90 | color : #dc322f; 91 | } 92 | 93 | #pos { 94 | margin : 0px; 95 | padding : 0px; 96 | margin-left : 6px; 97 | font-weight : bold; 98 | float : left; 99 | width : 80px; 100 | color : #49626a; 101 | } 102 | 103 | #term { 104 | width : 100%; 105 | height : calc(30% - 3ex); 106 | } 107 | 108 | #east { 109 | overflow : auto; 110 | height : 100%; 111 | background-color : #fdf6e3; 112 | color : #657b83; 113 | font-weight : bold; 114 | } 115 | 116 | .ui-resizable-e { 117 | cursor : ew-resize; 118 | } 119 | 120 | .ui-resizable-s { 121 | cursor : ns-resize; 122 | } 123 | 124 | .error { 125 | color : #d33682; 126 | } 127 | -------------------------------------------------------------------------------- /www/theme/solarized.css: -------------------------------------------------------------------------------- 1 | /* 2 | Solarized theme for code-mirror 3 | http://ethanschoonover.com/solarized 4 | */ 5 | 6 | /* 7 | Solarized color palette 8 | http://ethanschoonover.com/solarized/img/solarized-palette.png 9 | */ 10 | 11 | .solarized.base03 { color: #002b36; } 12 | .solarized.base02 { color: #073642; } 13 | .solarized.base01 { color: #586e75; } 14 | .solarized.base00 { color: #657b83; } 15 | .solarized.base0 { color: #839496; } 16 | .solarized.base1 { color: #93a1a1; } 17 | .solarized.base2 { color: #eee8d5; } 18 | .solarized.base3 { color: #fdf6e3; } 19 | .solarized.solar-yellow { color: #b58900; } 20 | .solarized.solar-orange { color: #cb4b16; } 21 | .solarized.solar-red { color: #dc322f; } 22 | .solarized.solar-magenta { color: #d33682; } 23 | .solarized.solar-violet { color: #6c71c4; } 24 | .solarized.solar-blue { color: #268bd2; } 25 | .solarized.solar-cyan { color: #2aa198; } 26 | .solarized.solar-green { color: #859900; } 27 | 28 | /* Color scheme for code-mirror */ 29 | 30 | .cm-s-solarized { 31 | line-height: 1.45em; 32 | color-profile: sRGB; 33 | rendering-intent: auto; 34 | } 35 | .cm-s-solarized.cm-s-dark { 36 | color: #839496; 37 | background-color: #002b36; 38 | text-shadow: #002b36 0 1px; 39 | } 40 | .cm-s-solarized.cm-s-light { 41 | background-color: #fdf6e3; 42 | color: #657b83; 43 | text-shadow: #eee8d5 0 1px; 44 | } 45 | 46 | .cm-s-solarized .CodeMirror-widget { 47 | text-shadow: none; 48 | } 49 | 50 | .cm-s-solarized .cm-header { color: #586e75; } 51 | .cm-s-solarized .cm-quote { color: #93a1a1; } 52 | 53 | .cm-s-solarized .cm-keyword { color: #cb4b16; } 54 | .cm-s-solarized .cm-atom { color: #d33682; } 55 | .cm-s-solarized .cm-number { color: #d33682; } 56 | .cm-s-solarized .cm-def { color: #2aa198; } 57 | 58 | .cm-s-solarized .cm-variable { color: #839496; } 59 | .cm-s-solarized .cm-variable-2 { color: #b58900; } 60 | .cm-s-solarized .cm-variable-3, .cm-s-solarized .cm-type { color: #6c71c4; } 61 | 62 | .cm-s-solarized .cm-property { color: #2aa198; } 63 | .cm-s-solarized .cm-operator { color: #6c71c4; } 64 | 65 | .cm-s-solarized .cm-comment { color: #586e75; font-style:italic; } 66 | .cm-s-solarized .cm-comment-2 { 67 | font-size:120%; 68 | color: #88AAB5; 69 | font-style:italic; 70 | } 71 | 72 | .cm-s-solarized .cm-string { color: #859900; } 73 | .cm-s-solarized .cm-string-2 { color: #b58900; } 74 | 75 | .cm-s-solarized .cm-meta { color: #859900; } 76 | .cm-s-solarized .cm-qualifier { color: #b58900; } 77 | .cm-s-solarized .cm-builtin { color: #d33682; } 78 | .cm-s-solarized .cm-bracket { color: #cb4b16; } 79 | .cm-s-solarized .CodeMirror-matchingbracket { color: #859900; } 80 | .cm-s-solarized .CodeMirror-nonmatchingbracket { color: #dc322f; } 81 | .cm-s-solarized .cm-tag { color: #93a1a1; } 82 | .cm-s-solarized .cm-attribute { color: #2aa198; } 83 | .cm-s-solarized .cm-hr { 84 | color: transparent; 85 | border-top: 1px solid #586e75; 86 | display: block; 87 | } 88 | .cm-s-solarized .cm-link { color: #93a1a1; cursor: pointer; } 89 | .cm-s-solarized .cm-special { color: #6c71c4; } 90 | .cm-s-solarized .cm-em { 91 | color: #999; 92 | text-decoration: underline; 93 | text-decoration-style: dotted; 94 | } 95 | .cm-s-solarized .cm-error, 96 | .cm-s-solarized .cm-invalidchar { 97 | color: #586e75; 98 | border-bottom: 1px dotted #dc322f; 99 | } 100 | 101 | .cm-s-solarized.cm-s-dark div.CodeMirror-selected { background: #073642; } 102 | .cm-s-solarized.cm-s-dark.CodeMirror ::selection { background: rgba(7, 54, 66, 0.99); } 103 | .cm-s-solarized.cm-s-dark .CodeMirror-line::-moz-selection, .cm-s-dark .CodeMirror-line > span::-moz-selection, .cm-s-dark .CodeMirror-line > span > span::-moz-selection { background: rgba(7, 54, 66, 0.99); } 104 | 105 | .cm-s-solarized.cm-s-light div.CodeMirror-selected { background: #eee8d5; } 106 | .cm-s-solarized.cm-s-light .CodeMirror-line::selection, .cm-s-light .CodeMirror-line > span::selection, .cm-s-light .CodeMirror-line > span > span::selection { background: #eee8d5; } 107 | .cm-s-solarized.cm-s-light .CodeMirror-line::-moz-selection, .cm-s-ligh .CodeMirror-line > span::-moz-selection, .cm-s-ligh .CodeMirror-line > span > span::-moz-selection { background: #eee8d5; } 108 | 109 | /* Editor styling */ 110 | 111 | 112 | 113 | /* Little shadow on the view-port of the buffer view */ 114 | .cm-s-solarized.CodeMirror { 115 | -moz-box-shadow: inset 7px 0 12px -6px #000; 116 | -webkit-box-shadow: inset 7px 0 12px -6px #000; 117 | box-shadow: inset 7px 0 12px -6px #000; 118 | } 119 | 120 | /* Remove gutter border */ 121 | .cm-s-solarized .CodeMirror-gutters { 122 | border-right: 0; 123 | } 124 | 125 | /* Gutter colors and line number styling based of color scheme (dark / light) */ 126 | 127 | /* Dark */ 128 | .cm-s-solarized.cm-s-dark .CodeMirror-gutters { 129 | background-color: #073642; 130 | } 131 | 132 | .cm-s-solarized.cm-s-dark .CodeMirror-linenumber { 133 | color: #586e75; 134 | text-shadow: #021014 0 -1px; 135 | } 136 | 137 | /* Light */ 138 | .cm-s-solarized.cm-s-light .CodeMirror-gutters { 139 | background-color: #eee8d5; 140 | } 141 | 142 | .cm-s-solarized.cm-s-light .CodeMirror-linenumber { 143 | color: #839496; 144 | } 145 | 146 | /* Common */ 147 | .cm-s-solarized .CodeMirror-linenumber { 148 | padding: 0 5px; 149 | } 150 | .cm-s-solarized .CodeMirror-guttermarker-subtle { color: #586e75; } 151 | .cm-s-solarized.cm-s-dark .CodeMirror-guttermarker { color: #ddd; } 152 | .cm-s-solarized.cm-s-light .CodeMirror-guttermarker { color: #cb4b16; } 153 | 154 | .cm-s-solarized .CodeMirror-gutter .CodeMirror-gutter-text { 155 | color: #586e75; 156 | } 157 | 158 | /* Cursor */ 159 | .cm-s-solarized .CodeMirror-cursor { border-left: 1px solid #819090; } 160 | 161 | /* Fat cursor */ 162 | .cm-s-solarized.cm-s-light.cm-fat-cursor .CodeMirror-cursor { background: #77ee77; } 163 | .cm-s-solarized.cm-s-light .cm-animate-fat-cursor { background-color: #77ee77; } 164 | .cm-s-solarized.cm-s-dark.cm-fat-cursor .CodeMirror-cursor { background: #586e75; } 165 | .cm-s-solarized.cm-s-dark .cm-animate-fat-cursor { background-color: #586e75; } 166 | 167 | /* Active line */ 168 | .cm-s-solarized.cm-s-dark .CodeMirror-activeline-background { 169 | background: rgba(255, 255, 255, 0.06); 170 | } 171 | .cm-s-solarized.cm-s-light .CodeMirror-activeline-background { 172 | background: rgba(0, 0, 0, 0.06); 173 | } 174 | -------------------------------------------------------------------------------- /zoo/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zoo) 3 | (virtual_modules zoo) 4 | (wrapped false) 5 | (libraries fmt containers) 6 | ) 7 | -------------------------------------------------------------------------------- /zoo/native/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zoo_native) 3 | (implements zoo) 4 | (libraries unix linenoise) 5 | ) 6 | -------------------------------------------------------------------------------- /zoo/native/zoo.ml: -------------------------------------------------------------------------------- 1 | (* This file contains all the common code used by the languages implemented in the PL Zoo. *) 2 | 3 | type location = 4 | | Location of Lexing.position * Lexing.position (** delimited location *) 5 | | Nowhere (** no location *) 6 | 7 | type 'a located = { data : 'a ; loc : location } 8 | 9 | let make_location loc1 loc2 = Location (loc1, loc2) 10 | 11 | let location_of_lex lex = 12 | Location (Lexing.lexeme_start_p lex, Lexing.lexeme_end_p lex) 13 | 14 | let locate ?(loc=Nowhere) x = { data = x; loc = loc } 15 | 16 | (** Exception [Error (loc, err, msg)] indicates an error of type [err] with error message 17 | [msg], occurring at location [loc]. *) 18 | exception Error of (location * string * string) 19 | 20 | (** [error ~loc ~kind] raises an error of the given [kind]. The [kfprintf] magic allows 21 | one to write [msg] using a format string. *) 22 | let error ?(kind="Error") ?(loc=Nowhere) = 23 | let k _ = 24 | let msg = Format.flush_str_formatter () in 25 | raise (Error (loc, kind, msg)) 26 | in 27 | Format.kfprintf k Format.str_formatter 28 | 29 | let print_parens ?(max_level=9999) ?(at_level=0) ppf = 30 | if max_level < at_level then 31 | begin 32 | Format.fprintf ppf "(@[" ; 33 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@])") ppf 34 | end 35 | else 36 | begin 37 | Format.fprintf ppf "@[" ; 38 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@]") ppf 39 | end 40 | 41 | let print_location loc ppf = 42 | match loc with 43 | | Nowhere -> 44 | Format.fprintf ppf "unknown location" 45 | | Location (begin_pos, end_pos) -> 46 | let begin_char = begin_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 47 | let end_char = end_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 48 | let begin_line = begin_pos.Lexing.pos_lnum in 49 | let filename = begin_pos.Lexing.pos_fname in 50 | 51 | if String.length filename != 0 then 52 | Format.fprintf ppf "file %S, line %d, charaters %d-%d" filename begin_line begin_char end_char 53 | else 54 | Format.fprintf ppf "line %d, characters %d-%d" (begin_line - 1) begin_char end_char 55 | 56 | (** A fatal error reported by the toplevel. *) 57 | let fatal_error msg = error ~kind:"Fatal error" msg 58 | 59 | (** A syntax error reported by the toplevel *) 60 | let syntax_error ?loc msg = error ~kind:"Syntax error" ?loc msg 61 | 62 | (** Print a message at a given location [loc] of message type [msg_type]. *) 63 | let print_message ?(loc=Nowhere) msg_type = 64 | match loc with 65 | | Location _ -> 66 | Format.eprintf "%s at %t:@\n" msg_type (print_location loc) ; 67 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@.") Format.err_formatter 68 | | Nowhere -> 69 | Format.eprintf "%s: " msg_type ; 70 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@.") Format.err_formatter 71 | 72 | (** Print the caught error *) 73 | let print_error (loc, err_type, msg) = print_message ~loc err_type "%s" msg 74 | 75 | let print_info msg = 76 | Format.printf msg 77 | 78 | type filename = string 79 | 80 | module type LANGUAGE = 81 | sig 82 | val name : string 83 | type command 84 | type environment 85 | val options : (Arg.key * Arg.spec * Arg.doc) list 86 | val initial_environment : environment 87 | val read_more : string -> bool 88 | val file_parser : (Lexing.lexbuf -> command list) option 89 | val toplevel_parser : (Lexing.lexbuf -> command) option 90 | val exec : 91 | (environment -> filename -> environment) -> 92 | environment -> command -> environment 93 | end 94 | 95 | module Main (L : LANGUAGE) = 96 | struct 97 | 98 | module History = struct 99 | let filename = Sys.getenv "HOME" ^ "/." ^ L.name ^ ".history" 100 | 101 | let load () = ignore (LNoise.history_load ~filename) 102 | 103 | (* let res = function Ok x -> x | Error s -> error "%s" s *) 104 | let add s = 105 | LNoise.history_add s |> ignore ; 106 | LNoise.history_save ~filename |> ignore ; 107 | end 108 | 109 | 110 | (** Should the interactive shell be run? *) 111 | let interactive_shell = ref true 112 | 113 | (** The usage message. *) 114 | let usage = 115 | match L.file_parser with 116 | | Some _ -> "Usage: " ^ L.name ^ " [option] ... [file] ..." 117 | | None -> "Usage:" ^ L.name ^ " [option] ..." 118 | 119 | (** A list of files to be loaded and run. *) 120 | let files = ref [] 121 | 122 | (** Add a file to the list of files to be loaded, and record whether it should 123 | be processed in interactive mode. *) 124 | let add_file filename = (files := filename :: !files) 125 | 126 | (** Command-line options *) 127 | let options = Arg.align ([ 128 | ("-v", 129 | Arg.Unit (fun () -> 130 | print_endline (L.name ^ " " ^ "(" ^ Sys.os_type ^ ")"); 131 | exit 0), 132 | " Print language information and exit"); 133 | ("-n", 134 | Arg.Clear interactive_shell, 135 | " Do not run the interactive toplevel"); 136 | ("-l", 137 | Arg.String (fun str -> add_file str), 138 | " Load into the initial environment") 139 | ] @ 140 | L.options) 141 | 142 | (** Treat anonymous arguments as files to be run. *) 143 | let anonymous str = 144 | add_file str; 145 | interactive_shell := false 146 | 147 | (** Parse the contents from a file, using a given [parser]. *) 148 | let read_file parser fn = 149 | try 150 | let fh = open_in fn in 151 | let lex = Lexing.from_channel fh in 152 | lex.Lexing.lex_curr_p <- {lex.Lexing.lex_curr_p with Lexing.pos_fname = fn}; 153 | try 154 | let terms = parser lex in 155 | close_in fh; 156 | terms 157 | with 158 | (* Close the file in case of any parsing errors. *) 159 | Error err -> close_in fh ; raise (Error err) 160 | with 161 | (* Any errors when opening or closing a file are fatal. *) 162 | Sys_error msg -> fatal_error "%s" msg 163 | 164 | (** Parse input from toplevel, using the given [parser]. *) 165 | let read_toplevel parser () = 166 | let prompt = L.name ^ "> " 167 | and prompt_more = String.make (String.length L.name) ' ' ^ "> " in 168 | match LNoise.linenoise prompt with 169 | | None -> exit 0 170 | | Some s0 -> 171 | History.add s0; 172 | let rec aux acc = 173 | if L.read_more acc then match LNoise.linenoise prompt_more with 174 | | None -> exit 0 175 | | Some s -> 176 | History.add s; 177 | aux (acc ^ s) 178 | else begin 179 | parser @@ Lexing.from_string (acc ^ "\n") 180 | end 181 | in 182 | aux s0 183 | 184 | (** Parser wrapper that catches syntax-related errors and converts them to errors. *) 185 | let wrap_syntax_errors parser lex = 186 | try[@warning "-52"] 187 | parser lex 188 | with 189 | | Failure _ -> 190 | syntax_error ~loc:(location_of_lex lex) "unrecognised symbol" 191 | | _ -> 192 | syntax_error ~loc:(location_of_lex lex) "syntax error" 193 | 194 | (** Load directives from the given file. *) 195 | let rec use_file ctx filename = 196 | match L.file_parser with 197 | | Some f -> 198 | let cmds = read_file (wrap_syntax_errors f) filename in 199 | List.fold_left (L.exec use_file) ctx cmds 200 | | None -> 201 | fatal_error "Cannot load files, only interactive shell is available" 202 | 203 | (** Interactive toplevel *) 204 | let toplevel ctx = 205 | let eof = match Sys.os_type with 206 | | "Unix" | "Cygwin" -> "Ctrl-D" 207 | | "Win32" -> "Ctrl-Z" 208 | | _ -> "EOF" 209 | in 210 | let toplevel_parser = 211 | match L.toplevel_parser with 212 | | Some p -> p 213 | | None -> fatal_error "I am sorry but this language has no interactive toplevel." 214 | in 215 | Format.printf "%s -- programming languages zoo@." L.name ; 216 | Format.printf "Type %s to exit@." eof ; 217 | try 218 | let ctx = ref ctx in 219 | while true do 220 | try 221 | let cmd = read_toplevel (wrap_syntax_errors toplevel_parser) () in 222 | ctx := L.exec use_file !ctx cmd 223 | with 224 | | Error err -> print_error err 225 | | Sys.Break -> prerr_endline "Interrupted." 226 | done 227 | with End_of_file -> () 228 | 229 | (** Main program *) 230 | let main () = 231 | LNoise.set_multiline true; 232 | History.load () ; 233 | (* Intercept Ctrl-C by the user *) 234 | LNoise.catch_break true; 235 | (* Parse the arguments. *) 236 | Arg.parse options anonymous usage; 237 | (* Files were listed in the wrong order, so we reverse them *) 238 | files := List.rev !files; 239 | (* Set the maximum depth of pretty-printing, after which it prints ellipsis. *) 240 | Format.set_max_boxes 42 ; 241 | Format.set_ellipsis_text "..." ; 242 | Format.set_margin 80 ; 243 | Format.set_max_indent 30 ; 244 | try 245 | (* Run and load all the specified files. *) 246 | let ctx = List.fold_left use_file L.initial_environment !files in 247 | if !interactive_shell then toplevel ctx 248 | with 249 | Error err -> print_error err; exit 1 250 | end 251 | 252 | (* 253 | MIT License 254 | 255 | Copyright © 2016 Andrej Bauer, Matija Pretnar 256 | 257 | Permission is hereby granted, free of charge, to any person obtaining a copy 258 | of this software and associated documentation files (the "Software"), to deal 259 | in the Software without restriction, including without limitation the rights 260 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 261 | copies of the Software, and to permit persons to whom the Software is 262 | furnished to do so, subject to the following conditions: 263 | 264 | The above copyright notice and this permission notice shall be included in all 265 | copies or substantial portions of the Software. 266 | 267 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 268 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 269 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 270 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 271 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 272 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 273 | SOFTWARE. 274 | 275 | *) 276 | -------------------------------------------------------------------------------- /zoo/web/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zoo_web) 3 | (implements zoo) 4 | (private_modules zoo_web) 5 | (libraries js_of_ocaml js_of_ocaml-tyxml) 6 | (preprocess (pps js_of_ocaml-ppx)) 7 | ) -------------------------------------------------------------------------------- /zoo/web/zoo.ml: -------------------------------------------------------------------------------- 1 | (* This file contains all the common code used by the languages implemented in the PL Zoo. *) 2 | 3 | type location = 4 | | Location of Lexing.position * Lexing.position (** delimited location *) 5 | | Nowhere (** no location *) 6 | 7 | type 'a located = { data : 'a ; loc : location } 8 | 9 | let make_location loc1 loc2 = Location (loc1, loc2) 10 | 11 | let location_of_lex lex = 12 | Location (Lexing.lexeme_start_p lex, Lexing.lexeme_end_p lex) 13 | 14 | let locate ?(loc=Nowhere) x = { data = x; loc = loc } 15 | 16 | (** Exception [Error (loc, err, msg)] indicates an error of type [err] with error message 17 | [msg], occurring at location [loc]. *) 18 | exception Error of (location * string * string) 19 | 20 | (** [error ~loc ~kind] raises an error of the given [kind]. The [kfprintf] magic allows 21 | one to write [msg] using a format string. *) 22 | let error ?(kind="Error") ?(loc=Nowhere) = 23 | let k _ = 24 | let msg = Format.flush_str_formatter () in 25 | raise (Error (loc, kind, msg)) 26 | in 27 | Format.kfprintf k Format.str_formatter 28 | 29 | let print_parens ?(max_level=9999) ?(at_level=0) ppf = 30 | if max_level < at_level then 31 | begin 32 | Format.fprintf ppf "(@[" ; 33 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@])") ppf 34 | end 35 | else 36 | begin 37 | Format.fprintf ppf "@[" ; 38 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@]") ppf 39 | end 40 | 41 | let print_location loc ppf = 42 | match loc with 43 | | Nowhere -> 44 | Format.fprintf ppf "unknown location" 45 | | Location (begin_pos, end_pos) -> 46 | let begin_char = begin_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 47 | let end_char = end_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 48 | let begin_line = begin_pos.Lexing.pos_lnum in 49 | let filename = begin_pos.Lexing.pos_fname in 50 | 51 | if String.length filename != 0 then 52 | Format.fprintf ppf "file %S, line %d, charaters %d-%d" filename begin_line begin_char end_char 53 | else 54 | Format.fprintf ppf "line %d, characters %d-%d" (begin_line - 1) begin_char end_char 55 | 56 | (** A fatal error reported by the toplevel. *) 57 | let fatal_error msg = error ~kind:"Fatal error" msg 58 | 59 | (** A syntax error reported by the toplevel *) 60 | let syntax_error ?loc msg = error ~kind:"Syntax error" ?loc msg 61 | 62 | (** Print a message at a given location [loc] of message type [msg_type]. *) 63 | let print_message ?(loc=Nowhere) msg_type fmt = 64 | let ppf = Zoo_web.term in 65 | match loc with 66 | | Location _ -> 67 | Format.fprintf ppf ("%s at %t:@."^^fmt^^"@.") msg_type (print_location loc) 68 | | Nowhere -> 69 | Format.fprintf ppf ("%s: "^^fmt^^"@.") msg_type 70 | 71 | (** Print the caught error *) 72 | let print_error (loc, err_type, msg) = print_message ~loc err_type "%s" msg 73 | 74 | let print_info msg = 75 | Format.fprintf Zoo_web.term msg 76 | 77 | type filename = string 78 | 79 | module type LANGUAGE = 80 | sig 81 | val name : string 82 | type command 83 | type environment 84 | val options : (Arg.key * Arg.spec * Arg.doc) list 85 | val initial_environment : environment 86 | val read_more : string -> bool 87 | val file_parser : (Lexing.lexbuf -> command list) option 88 | val toplevel_parser : (Lexing.lexbuf -> command) option 89 | val exec : 90 | (environment -> filename -> environment) -> 91 | environment -> command -> environment 92 | end 93 | 94 | module Main (L : LANGUAGE) = 95 | struct 96 | 97 | (** Parse the contents from a file, using a given [parser]. *) 98 | let read_file parser (fn, str) = 99 | let lex = Lexing.from_string (str ^"\n") in 100 | lex.Lexing.lex_curr_p <- {lex.Lexing.lex_curr_p with Lexing.pos_fname = fn}; 101 | let terms = parser lex in 102 | terms 103 | 104 | (** Parser wrapper that catches syntax-related errors and converts them to errors. *) 105 | let wrap_syntax_errors parser lex = 106 | try[@warning "-52"] 107 | parser lex 108 | with 109 | | Failure _ -> 110 | syntax_error ~loc:(location_of_lex lex) "unrecognised symbol" 111 | | _ -> 112 | syntax_error ~loc:(location_of_lex lex) "syntax error" 113 | 114 | (** Load directives from the given file. *) 115 | let use_file ctx (filename, content) = 116 | match L.file_parser with 117 | | Some f -> 118 | let cmds = read_file (wrap_syntax_errors f) (filename, content) in 119 | List.fold_left 120 | (L.exec (fun _ _ -> fatal_error "Cannot load files in the web toplevel")) 121 | ctx cmds 122 | | None -> 123 | fatal_error "Cannot load files, only interactive shell is available" 124 | 125 | 126 | let eval (name, s) = 127 | let name = Js_of_ocaml.Js.to_string name in 128 | let s = Js_of_ocaml.Js.to_string s in 129 | begin try 130 | Zoo_web.clear_term (); 131 | Zoo_web.add_to_term "(* Starting typing *)\n"; 132 | let _ = use_file L.initial_environment (name, s) in 133 | () 134 | with 135 | | Error err -> print_error err 136 | | _e -> 137 | error "Uncaught exception" 138 | end ; 139 | Zoo_web.add_to_term "(* Finished typing *)\n"; 140 | () 141 | 142 | let load_files l = 143 | let open Js_of_ocaml_tyxml.Tyxml_js in 144 | 145 | let elem s = 146 | Html.(li [a ~a:[a_class ["file"]; a_href ("#"^s); a_title s; 147 | a_onclick (fun _ -> Zoo_web.load_file s; false);] 148 | [txt s]]) 149 | in 150 | let l = Html.ul (List.map elem l) in 151 | Register.id ~keep:true "examples" [l] 152 | 153 | let main () = 154 | Zoo_web.set_lang_name L.name; 155 | Js_of_ocaml.Js.export "Affe" (object%js 156 | method eval name s = eval (name, s) 157 | end) 158 | 159 | end 160 | 161 | (* 162 | MIT License 163 | 164 | Copyright © 2016 Andrej Bauer, Matija Pretnar 165 | 166 | Permission is hereby granted, free of charge, to any person obtaining a copy 167 | of this software and associated documentation files (the "Software"), to deal 168 | in the Software without restriction, including without limitation the rights 169 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 170 | copies of the Software, and to permit persons to whom the Software is 171 | furnished to do so, subject to the following conditions: 172 | 173 | The above copyright notice and this permission notice shall be included in all 174 | copies or substantial portions of the Software. 175 | 176 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 177 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 178 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 179 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 180 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 181 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 182 | SOFTWARE. 183 | 184 | *) 185 | -------------------------------------------------------------------------------- /zoo/web/zoo_web.ml: -------------------------------------------------------------------------------- 1 | open Js_of_ocaml 2 | open Js_of_ocaml_tyxml.Tyxml_js 3 | 4 | let set_lang_name name = 5 | Dom_html.document##.title := Js.string name; 6 | Register.id ~keep:false "lang" [Html.txt name] 7 | 8 | let load_file s : unit = 9 | Js.Unsafe.fun_call (Js.Unsafe.js_expr "loadfile") 10 | [|Js.Unsafe.inject @@ Js.string s|] 11 | 12 | let clear_term () : unit = 13 | Js.Unsafe.fun_call (Js.Unsafe.js_expr "clear_term") 14 | [||] 15 | 16 | let add_to_term s : unit = 17 | Js.Unsafe.fun_call (Js.Unsafe.js_expr "add_to_term") 18 | [|Js.Unsafe.inject @@ Js.string s|] 19 | let flush_term () : unit = 20 | Js.Unsafe.fun_call (Js.Unsafe.js_expr "flush_term") 21 | [||] 22 | 23 | let term = 24 | let t = Format.make_formatter 25 | (fun s pos len -> 26 | let s = String.sub s pos len in 27 | add_to_term s) 28 | flush_term 29 | in 30 | Format.pp_set_max_boxes t 42 ; 31 | Format.pp_set_ellipsis_text t "..." ; 32 | Format.pp_set_margin t 60 ; 33 | Format.pp_set_max_indent t 30 ; 34 | t 35 | -------------------------------------------------------------------------------- /zoo/zoo.mli: -------------------------------------------------------------------------------- 1 | (* Stolen from the plzoo *) 2 | 3 | (** Source code locations. *) 4 | type location 5 | 6 | (** A datum tagged with a source code location *) 7 | type 'a located = private { data : 'a ; loc : location } 8 | 9 | (** Tag a datum with an (optional) location. *) 10 | val locate : ?loc:location -> 'a -> 'a located 11 | 12 | (** Convert a [Lexing.lexbuf] location to a [location] *) 13 | val location_of_lex : Lexing.lexbuf -> location 14 | 15 | (** [make_location p1 p2] creates a location which starts at [p1] and ends at [p2]. *) 16 | val make_location : Lexing.position -> Lexing.position -> location 17 | 18 | (** Print a location *) 19 | val print_location : location -> Format.formatter -> unit 20 | 21 | (** [error ~kind ~loc msg] raises an exception which is caught by the toplevel and 22 | prints the given message. *) 23 | val error : 24 | ?kind:string -> ?loc:location -> ('a, Format.formatter, unit, 'b) format4 -> 'a 25 | 26 | (** Print miscellaneous information *) 27 | val print_info : ('a, Format.formatter, unit, unit) format4 -> 'a 28 | 29 | (** Print an expression, possibly placing parentheses around it. We always 30 | print things at a given "level" [at_level]. If the level exceeds the 31 | maximum allowed level [max_level] then the expression should be parenthesized. 32 | 33 | Let us consider an example. When printing nested applications, we should print [App 34 | (App (e1, e2), e3)] as ["e1 e2 e3"] and [App(e1, App(e2, e3))] as ["e1 (e2 e3)"]. So 35 | if we assign level 1 to applications, then during printing of [App (e1, e2)] we should 36 | print [e1] at [max_level] 1 and [e2] at [max_level] 0. 37 | *) 38 | val print_parens : ?max_level:int -> ?at_level:int -> 39 | Format.formatter -> ('a, Format.formatter, unit, unit) format4 -> 'a 40 | 41 | type filename = string 42 | 43 | (** The definition of a programming language *) 44 | module type LANGUAGE = 45 | sig 46 | (** The name of the language (used for prompt) *) 47 | val name : string 48 | 49 | (** The type of top-level commands *) 50 | type command 51 | 52 | (** The runtime environment *) 53 | type environment 54 | 55 | (** Additional command-line options *) 56 | val options : (Arg.key * Arg.spec * Arg.doc) list 57 | 58 | (** The initial runtime environment *) 59 | val initial_environment : environment 60 | 61 | (** Given the interactive input so far, should we read more? *) 62 | val read_more : string -> bool 63 | 64 | (** A parser for parsing entire files *) 65 | val file_parser : (Lexing.lexbuf -> command list) option 66 | 67 | (** A parser for parsing one toplevel command *) 68 | val toplevel_parser : (Lexing.lexbuf -> command) option 69 | 70 | (** Execute a toplevel command in the given environment and 71 | return the new environment. *) 72 | val exec : 73 | (environment -> filename -> environment) -> 74 | environment -> command -> environment 75 | end 76 | 77 | (** Create a language from its definition. *) 78 | module Main (L : LANGUAGE) : sig 79 | (** The main program *) 80 | val main : unit -> unit 81 | end 82 | 83 | (* 84 | 85 | MIT License 86 | 87 | Copyright © 2016 Andrej Bauer, Matija Pretnar 88 | 89 | Permission is hereby granted, free of charge, to any person obtaining a copy 90 | of this software and associated documentation files (the "Software"), to deal 91 | in the Software without restriction, including without limitation the rights 92 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 93 | copies of the Software, and to permit persons to whom the Software is 94 | furnished to do so, subject to the following conditions: 95 | 96 | The above copyright notice and this permission notice shall be included in all 97 | copies or substantial portions of the Software. 98 | 99 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 100 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 101 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 102 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 103 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 104 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 105 | SOFTWARE. 106 | 107 | *) 108 | --------------------------------------------------------------------------------