From f657c71753d0570039636d379991c79a7cb0f3cd Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 27 Sep 2019 14:55:09 +0200 Subject: [PATCH 01/39] Merge done and repo build with no error --- src/passes/4-typer/dune | 1 + src/passes/4-typer/solver.ml | 716 ++++++++++++++++++ src/passes/4-typer/typer.ml | 16 + src/passes/4-typer/typer.ml.old | 879 +++++++++++++++++++++++ src/passes/operators/dune | 1 + src/passes/operators/operators.ml | 60 ++ src/typesystem/core.ml | 60 ++ src/typesystem/dune | 14 + src/typesystem/shorthands.ml | 62 ++ src/typesystem/typesystem.ml | 2 + src/union_find/.PartitionMain.tag | 0 src/union_find/.links | 1 + src/union_find/LICENSE | 21 + src/union_find/Makefile.cfg | 4 + src/union_find/Partition.mli | 64 ++ src/union_find/Partition0.ml | 47 ++ src/union_find/Partition1.ml | 69 ++ src/union_find/Partition2.ml | 115 +++ src/union_find/Partition3.ml | 86 +++ src/union_find/PartitionMain.ml | 40 ++ src/union_find/README.md | 39 + src/union_find/build.sh | 14 + src/union_find/clean.sh | 3 + src/union_find/dune | 16 + src/union_find/union_find.ml | 2 + vendors/ligo-utils/simple-utils/trace.ml | 1 + 26 files changed, 2333 insertions(+) create mode 100644 src/passes/4-typer/solver.ml create mode 100644 src/passes/4-typer/typer.ml.old create mode 100644 src/typesystem/core.ml create mode 100644 src/typesystem/dune create mode 100644 src/typesystem/shorthands.ml create mode 100644 src/typesystem/typesystem.ml create mode 100644 src/union_find/.PartitionMain.tag create mode 100644 src/union_find/.links create mode 100644 src/union_find/LICENSE create mode 100644 src/union_find/Makefile.cfg create mode 100644 src/union_find/Partition.mli create mode 100644 src/union_find/Partition0.ml create mode 100644 src/union_find/Partition1.ml create mode 100644 src/union_find/Partition2.ml create mode 100644 src/union_find/Partition3.ml create mode 100644 src/union_find/PartitionMain.ml create mode 100644 src/union_find/README.md create mode 100755 src/union_find/build.sh create mode 100755 src/union_find/clean.sh create mode 100644 src/union_find/dune create mode 100644 src/union_find/union_find.ml diff --git a/src/passes/4-typer/dune b/src/passes/4-typer/dune index 0ee58cc43..ec35ab2ce 100644 --- a/src/passes/4-typer/dune +++ b/src/passes/4-typer/dune @@ -7,6 +7,7 @@ ast_simplified ast_typed operators + union_find ) (preprocess (pps ppx_let) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml new file mode 100644 index 000000000..890d067e3 --- /dev/null +++ b/src/passes/4-typer/solver.ml @@ -0,0 +1,716 @@ +open Trace + +module Core = Typesystem.Core + +module Wrap = struct + module I = Ast_simplified + module O = Core + + type constraints = O.type_constraint list + + (* let add_type state t = *) + (* let constraints = Wrap.variable type_name t in *) + (* let%bind state' = aggregate_constraints state constraints in *) + (* ok state' in *) + (* let return_add_type ?(state = state) expr t = *) + (* let%bind state' = add_type state t in *) + (* return expr state' in *) + + let rec type_expression_to_type_value : I.type_expression -> O.type_value = fun te -> + match te with + | T_tuple types -> + P_constant (C_tuple, List.map type_expression_to_type_value types) + | T_sum kvmap -> + P_constant (C_variant, Map.String.to_list @@ Map.String.map type_expression_to_type_value kvmap) + | T_record kvmap -> + P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value kvmap) + | T_function (arg , ret) -> + P_constant (C_arrow, List.map type_expression_to_type_value [ arg ; ret ]) + | T_variable type_name -> P_variable type_name + | T_constant (type_name , args) -> + let csttag = Core.(match type_name with + | "arrow" -> C_arrow + | "option" -> C_option + | "tuple" -> C_tuple + | "map" -> C_map + | "list" -> C_list + | "set" -> C_set + | "unit" -> C_unit + | "bool" -> C_bool + | "string" -> C_string + | _ -> failwith "TODO") + in + P_constant (csttag, List.map type_expression_to_type_value args) + + (** TODO *) + let type_declaration : I.declaration -> constraints = fun td -> + match td with + | Declaration_type (name , te) -> + let pattern = type_expression_to_type_value te in + [C_equation (P_variable (name) , pattern)] (* TODO: this looks wrong. If this is a type declaration, it should not set any constraints. *) + | Declaration_constant (name, te, _) ->( + match te with + | Some (exp) -> + let pattern = type_expression_to_type_value exp in + [C_equation (P_variable (name) , pattern)] (* TODO: this looks wrong. If this is a type declaration, it should not set any constraints. *) + | None -> + (** TODO *) + [] + ) + + (* TODO: this should be renamed to failwith_ *) + let failwith : unit -> (constraints * O.type_variable) = fun () -> + let type_name = Core.fresh_type_variable () in + [] , type_name + + let variable : I.name -> I.type_expression -> (constraints * O.type_variable) = fun _name expr -> + let pattern = type_expression_to_type_value expr in + let type_name = Core.fresh_type_variable () in + [C_equation (P_variable (type_name) , pattern)] , type_name + + let literal : I.type_expression -> (constraints * O.type_variable) = fun t -> + let pattern = type_expression_to_type_value t in + let type_name = Core.fresh_type_variable () in + [C_equation (P_variable (type_name) , pattern)] , type_name + + (* + let literal_bool : unit -> (constraints * O.type_variable) = fun () -> + let pattern = type_expression_to_type_value I.t_bool in + let type_name = Core.fresh_type_variable () in + [C_equation (P_variable (type_name) , pattern)] , type_name + + let literal_string : unit -> (constraints * O.type_variable) = fun () -> + let pattern = type_expression_to_type_value I.t_string in + let type_name = Core.fresh_type_variable () in + [C_equation (P_variable (type_name) , pattern)] , type_name + *) + + let tuple : I.type_expression list -> (constraints * O.type_variable) = fun tys -> + let patterns = List.map type_expression_to_type_value tys in + let pattern = O.(P_constant (C_tuple , patterns)) in + let type_name = Core.fresh_type_variable () in + [C_equation (P_variable (type_name) , pattern)] , type_name + + (* let t_tuple = ('label:int, 'v) … -> record ('label : 'v) … *) + (* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *) + (* let t_record = ('label:string, 'v) … -> record ('label : 'v) … with independent choices for each 'label and 'v *) + (* let t_variable = t_of_var_in_env *) + (* let t_access_int = record ('label:int , 'v) … -> 'label:int -> 'v *) + (* let t_access_string = record ('label:string , 'v) … -> 'label:string -> 'v *) + + module Prim_types = struct + open Typesystem.Shorthands + + let t_cons = forall "v" @@ fun v -> v --> list v --> list v (* was: list *) + let t_setcons = forall "v" @@ fun v -> v --> set v --> set v (* was: set *) + let t_mapcons = forall2 "k" "v" @@ fun k v -> (k * v) --> map k v --> map k v (* was: map *) + let t_failwith = forall "a" @@ fun a -> a + (* let t_literal_t = t *) + let t_literal_bool = bool + let t_literal_string = string + let t_access_map = forall2 "k" "v" @@ fun k v -> map k v --> k --> v + let t_application = forall2 "a" "b" @@ fun a b -> (a --> b) --> a --> b + let t_look_up = forall2 "ind" "v" @@ fun ind v -> map ind v --> ind --> option v + let t_sequence = forall "b" @@ fun b -> unit --> b --> b + let t_loop = bool --> unit --> unit + end + + (* TODO: I think we should take an I.expression for the base+label *) + let access_label ~base ~label : (constraints * O.type_variable) = + let base' = type_expression_to_type_value base in + let expr_type = Core.fresh_type_variable () in + [O.C_access_label (base' , label , expr_type)] , expr_type + + let access_int ~base ~index = access_label ~base ~label:(L_int index) + let access_string ~base ~property = access_label ~base ~label:(L_string property) + + let access_map : base:I.type_expression -> key:I.type_expression -> (constraints * O.type_variable) = + let mk_map_type key_type element_type = + O.P_constant O.(C_map , [P_variable element_type; P_variable key_type]) in + fun ~base ~key -> + let key_type = Core.fresh_type_variable () in + let element_type = Core.fresh_type_variable () in + let base' = type_expression_to_type_value base in + let key' = type_expression_to_type_value key in + let base_expected = mk_map_type key_type element_type in + let expr_type = Core.fresh_type_variable () in + O.[C_equation (base' , base_expected); + C_equation (key' , P_variable key_type); + C_equation (P_variable expr_type , P_variable element_type)] , expr_type + + let constructor + : I.type_expression -> I.type_expression -> I.type_expression -> (constraints * O.type_variable) + = fun t_arg c_arg sum -> + let t_arg = type_expression_to_type_value t_arg in + let c_arg = type_expression_to_type_value c_arg in + let sum = type_expression_to_type_value sum in + let whole_expr = Core.fresh_type_variable () in + [ + C_equation (P_variable (whole_expr) , sum) ; + C_equation (t_arg , c_arg) + ] , whole_expr + + let record : I.type_expression I.type_name_map -> (constraints * O.type_variable) = fun fields -> + let record_type = type_expression_to_type_value (I.t_record fields) in + let whole_expr = Core.fresh_type_variable () in + [C_equation (P_variable whole_expr , record_type)] , whole_expr + + let collection : O.constant_tag -> I.type_expression list -> (constraints * O.type_variable) = + fun ctor element_tys -> + let elttype = O.P_variable (Core.fresh_type_variable ()) in + let aux elt = + let elt' = type_expression_to_type_value elt + in O.C_equation (elttype , elt') in + let equations = List.map aux element_tys in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (P_variable whole_expr , O.P_constant (ctor , [elttype])) + ] @ equations , whole_expr + + let list = collection O.C_list + let set = collection O.C_set + + let map : (I.type_expression * I.type_expression) list -> (constraints * O.type_variable) = + fun kv_tys -> + let k_type = O.P_variable (Core.fresh_type_variable ()) in + let v_type = O.P_variable (Core.fresh_type_variable ()) in + let aux_k (k , _v) = + let k' = type_expression_to_type_value k in + O.C_equation (k_type , k') in + let aux_v (_k , v) = + let v' = type_expression_to_type_value v in + O.C_equation (v_type , v') in + let equations_k = List.map aux_k kv_tys in + let equations_v = List.map aux_v kv_tys in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type])) + ] @ equations_k @ equations_v , whole_expr + + let application : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + fun f arg -> + let whole_expr = Core.fresh_type_variable () in + let f' = type_expression_to_type_value f in + let arg' = type_expression_to_type_value arg in + O.[ + C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr])) + ] , whole_expr + + let look_up : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + fun ds ind -> + let ds' = type_expression_to_type_value ds in + let ind' = type_expression_to_type_value ind in + let whole_expr = Core.fresh_type_variable () in + let v = Core.fresh_type_variable () in + O.[ + C_equation (ds' , P_constant (C_map, [ind' ; P_variable v])) ; + C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v])) + ] , whole_expr + + let sequence : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + fun a b -> + let a' = type_expression_to_type_value a in + let b' = type_expression_to_type_value b in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (a' , P_constant (C_unit , [])) ; + C_equation (b' , P_variable whole_expr) + ] , whole_expr + + let loop : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + fun expr body -> + let expr' = type_expression_to_type_value expr in + let body' = type_expression_to_type_value body in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (expr' , P_constant (C_bool , [])) ; + C_equation (body' , P_constant (C_unit , [])) ; + C_equation (P_variable whole_expr , P_constant (C_unit , [])) + ] , whole_expr + + let let_in : I.type_expression -> I.type_expression option -> I.type_expression -> (constraints * O.type_variable) = + fun rhs rhs_tv_opt result -> + let rhs' = type_expression_to_type_value rhs in + let result' = type_expression_to_type_value result in + let rhs_tv_opt' = match rhs_tv_opt with + None -> [] + | Some annot -> O.[C_equation (rhs' , type_expression_to_type_value annot)] in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (result' , P_variable whole_expr) + ] @ rhs_tv_opt', whole_expr + + let assign : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + fun v e -> + let v' = type_expression_to_type_value v in + let e' = type_expression_to_type_value e in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (v' , e') ; + C_equation (P_variable whole_expr , P_constant (C_unit , [])) + ] , whole_expr + + let annotation : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + fun e annot -> + let e' = type_expression_to_type_value e in + let annot' = type_expression_to_type_value annot in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (e' , annot') ; + C_equation (e' , P_variable whole_expr) + ] , whole_expr + + let matching : I.type_expression list -> (constraints * O.type_variable) = + fun es -> + let whole_expr = Core.fresh_type_variable () in + let type_values = (List.map type_expression_to_type_value es) in + let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values + in cs, whole_expr + + let fresh_binder () = + Core.fresh_type_variable () + + let lambda + : I.type_expression -> + I.type_expression option -> + I.type_expression option -> + (constraints * O.type_variable) = + fun fresh arg body -> + let whole_expr = Core.fresh_type_variable () in + let unification_arg = Core.fresh_type_variable () in + let unification_body = Core.fresh_type_variable () in + let arg' = match arg with + None -> [] + | Some arg -> O.[C_equation (P_variable unification_arg , type_expression_to_type_value arg)] in + let body' = match body with + None -> [] + | Some body -> O.[C_equation (P_variable unification_body , type_expression_to_type_value body)] + in O.[ + C_equation (type_expression_to_type_value fresh , P_variable unification_arg) ; + C_equation (P_variable whole_expr , + P_constant (C_arrow , [P_variable unification_arg ; + P_variable unification_body])) + ] @ arg' @ body' , whole_expr + +end + +(* begin unionfind *) + +module TV = +struct + type t = Core.type_variable + let compare = String.compare + let to_string = (fun s -> s) +end + +module UF = Union_find.Partition0.Make(TV) + +type unionfind = UF.t + +let empty = UF.empty (* DEMO *) +let representative_toto = UF.repr "toto" empty (* DEMO *) +let merge x y = UF.equiv x y (* DEMO *) + +(* end unionfind *) + +(* representant for an equivalence class of type variables *) +module TypeVariable = String +module TypeVariableMap = Map.Make(TypeVariable) + + +(* + +Components: +* assignments (passive data structure). + Now: just a map from unification vars to types (pb: what about partial types?) + maybe just local assignments (allow only vars as children of pair(α,β)) +* constraint propagation: (buch of constraints) → (new constraints * assignments) + * sub-component: constraint selector (worklist / dynamic queries) + * sub-sub component: constraint normalizer: remove dupes and give structure + right now: union-find of unification vars + later: better database-like organisation of knowledge + * sub-sub component: lazy selector (don't re-try all selectors every time) + For now: just re-try everytime + * sub-component: propagation rule + For now: break pair(a, b) = pair(c, d) into a = c, b = d +* generalizer + For now: ? + +Workflow: + Start with empty assignments and structured database + Receive a new constraint + For each normalizer: + Use the pre-selector to see if it can be applied + Apply the normalizer, get some new items to insert in the structured database + For each propagator: + Use the selector to query the structured database and see if it can be applied + Apply the propagator, get some new constraints and assignments + Add the new assignments to the data structure. + + At some point (when?) + For each generalizer: + Use the generalizer's selector to see if it can be applied + Apply the generalizer to produce a new type, possibly with some ∀s injected + +*) + +open Core + +type structured_dbs = { + all_constraints : type_constraint_simpl list ; + aliases : unionfind ; + (* assignments (passive data structure). + Now: just a map from unification vars to types (pb: what about partial types?) + maybe just local assignments (allow only vars as children of pair(α,β)) *) + assignments : c_constructor_simpl TypeVariableMap.t ; + grouped_by_variable : constraints TypeVariableMap.t ; (* map from (unionfind) variables to constraints containing them *) + cycle_detection_toposort : unit ; (* example of structured db that we'll add later *) +} + +and constraints = { + constructor : c_constructor_simpl list ; + tc : c_typeclass_simpl list ; +} + +and c_constructor_simpl = { + tv : type_variable; + c_tag : constant_tag; + tv_list : type_variable list; +} +(* copy-pasted from core.ml *) +and c_const = (type_variable * type_value) +and c_equation = (type_value * type_value) +and c_typeclass_simpl = { + tc : typeclass ; + args : type_variable list ; +} +and type_constraint_simpl = + SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) + | SC_Alias of (type_variable * type_variable) (* α = β *) + | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) + +module UnionFindWrapper = struct + (* TODO: API for the structured db, to access it modulo unification variable aliases. *) + let get_constraints_related_to : type_variable -> structured_dbs -> constraints = + fun variable dbs -> + let variable , aliases = UF.get_or_set variable dbs.aliases in + let dbs = { dbs with aliases } in + match TypeVariableMap.find_opt variable dbs.grouped_by_variable with + Some l -> l + | None -> { + constructor = [] ; + tc = [] ; + } + let add_constraints_related_to : type_variable -> constraints -> structured_dbs -> structured_dbs = + fun variable c dbs -> + (* let (variable_repr , _height) , aliases = UF.get_or_set variable dbs.aliases in + let dbs = { dbs with aliases } in *) + let variable_repr , aliases = UF.get_or_set variable dbs.aliases in + let dbs = { dbs with aliases } in + let grouped_by_variable = TypeVariableMap.update variable_repr (function + None -> Some c + | Some x -> Some { + constructor = c.constructor @ x.constructor ; + tc = c.tc @ x.tc ; + }) + dbs.grouped_by_variable + in + let dbs = { dbs with grouped_by_variable } in + dbs + let merge_variables : type_variable -> type_variable -> structured_dbs -> structured_dbs = + fun variable_a variable_b dbs -> + let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in + let dbs = { dbs with aliases } in + let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in + let dbs = { dbs with aliases } in + let default d = function None -> d | Some y -> y in + let get_constraints ab = + TypeVariableMap.find_opt ab dbs.grouped_by_variable + |> default { constructor = [] ; tc = [] } in + let constraints_a = get_constraints variable_repr_a in + let constraints_b = get_constraints variable_repr_b in + let all_constraints = { + (* TODO: should be a Set.union, not @ *) + constructor = constraints_a.constructor @ constraints_b.constructor ; + tc = constraints_a.tc @ constraints_b.tc ; + } in + let grouped_by_variable = + TypeVariableMap.add variable_repr_a all_constraints dbs.grouped_by_variable in + let dbs = { dbs with grouped_by_variable} in + let grouped_by_variable = + TypeVariableMap.remove variable_repr_b dbs.grouped_by_variable in + let dbs = { dbs with grouped_by_variable} in + dbs +end + +(* sub-sub component: constraint normalizer: remove dupes and give structure + * right now: union-find of unification vars + * later: better database-like organisation of knowledge *) + +(* Each normalizer returns a *) +type ('a , 'b) normalizer = structured_dbs -> 'a -> (structured_dbs * 'b list) + +let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + ({ dbs with all_constraints = new_constraint :: dbs.all_constraints } , [new_constraint]) + +let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + let store_constraint tvars constraints = + let aux dbs (tvar : type_variable) = + UnionFindWrapper.add_constraints_related_to tvar constraints dbs + in List.fold_left aux dbs tvars + in + let merge_constraints a b = + UnionFindWrapper.merge_variables a b dbs in + let dbs = match new_constraint with + SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; tc = []} + | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; tc = [c]} + | SC_Alias (a , b) -> merge_constraints a b + in (dbs , [new_constraint]) + +(* Stores the first assinment ('a = ctor('b, …)) seen *) +let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + match new_constraint with + | SC_Constructor ({tv ; c_tag = _ ; tv_list = _} as c) -> + let assignments = TypeVariableMap.update tv (function None -> Some c | e -> e) dbs.assignments in + let dbs = {dbs with assignments} in + (dbs , [new_constraint]) + | _ -> + (dbs , [new_constraint]) + +let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + match new_constraint with + | C_equation (P_forall _, P_forall _) -> failwith "TODO" + | C_equation ((P_forall _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) + | C_equation (P_forall _, P_constant _) -> failwith "TODO" + | C_equation (P_variable _, P_forall _) -> failwith "TODO" + | C_equation (P_variable a, P_variable b) -> (dbs , [SC_Alias (a, b)]) + | C_equation (P_variable a, P_constant (c_tag, args)) -> + let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in + let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in + (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars}] @ List.flatten recur) + | C_equation (P_constant _, P_forall _) -> failwith "TODO" + | C_equation ((P_constant _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) + | C_equation ((P_constant _ as a), (P_constant _ as b)) -> + (* break down c(args) = c'(args') into 'a = c(args) and 'a = c'(args') *) + let fresh = Core.fresh_type_variable () in + let (dbs , cs1) = normalizer_simpl dbs (C_equation (P_variable fresh, a)) in + let (dbs , cs2) = normalizer_simpl dbs (C_equation (P_variable fresh, b)) in + (dbs , cs1 @ cs2) (* TODO: O(n) concatenation! *) + | C_typeclass (args, tc) -> + (* break down TC(args) into TC('a, …) and ('a = arg) … *) + let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in + let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in + (dbs, [SC_Typeclass { tc ; args = fresh_vars }] @ List.flatten recur) + | C_access_label (tv, label, result) -> let _todo = ignore (tv, label, result) in failwith "TODO" + +type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list } +let lift_state_list_monad ~state ~list = { state ; list } +let lift f = + fun { state ; list } -> + let (new_state , new_lists) = List.fold_map_acc f state list in + { state = new_state ; list = List.flatten new_lists } + +(* TODO: move this to the List module *) +let named_fold_left f ~acc ~lst = List.fold_left (fun acc lst -> f ~acc ~lst) acc lst + +(* TODO: place the list of normalizers in a map *) +(* (\* cons for heterogeneous lists *\) + * type 'b f = { f : 'a . ('a -> 'b) -> 'a -> 'b } + * type ('hd , 'tl) hcons = { hd : 'hd ; tl : 'tl ; map : 'b . 'b f -> ('b , 'tl) hcons } + * let (+::) hd tl = { hd ; tl ; map = fun x -> } + * + * let list_of_normalizers = + * normalizer_simpl +:: + * normalizer_all_constraints +:: + * normalizer_assignments +:: + * normalizer_grouped_by_variable +:: + * () *) + +module Fun = struct let id x = x end (* in stdlib as of 4.08, we're in 4.07 for now *) + +let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad = + fun new_constraint dbs -> + Fun.id + @@ lift normalizer_grouped_by_variable + @@ lift normalizer_assignments + @@ lift normalizer_all_constraints + @@ lift normalizer_simpl + @@ lift_state_list_monad ~state:dbs ~list:[new_constraint] + +(* sub-sub component: lazy selector (don't re-try all selectors every time) + * For now: just re-try everytime *) + +type todo = unit +let todo : todo = () +type 'old_constraint_type selector_input = 'old_constraint_type (* some info about the constraint just added, so that we know what to look for *) +type 'selector_output selector_outputs = + WasSelected of 'selector_output list + | WasNotSelected +type new_constraints = type_constraint list +type new_assignments = c_constructor_simpl list + +type ('old_constraint_type, 'selector_output) selector = 'old_constraint_type selector_input -> structured_dbs -> 'selector_output selector_outputs + +(* selector / propagation rule for breaking down composite types + * For now: do something with ('a = 'b) constraints. + + Or maybe this one should be a normalizer. *) + +(* selector / propagation rule for breaking down composite types + * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) + +type output_break_ctor = < a_k_var : c_constructor_simpl ; a_k'_var' : c_constructor_simpl > +let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = + (* find two rules with the shape a = k(var …) and a = k'(var' …) *) + fun todo dbs -> + match todo with + SC_Constructor c -> + let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in + let cs_pairs = List.map (fun x -> object method a_k_var = c method a_k'_var' = x end) other_cs in + WasSelected cs_pairs + | SC_Alias _ -> WasNotSelected (* TODO: ??? *) + | SC_Typeclass _ -> WasNotSelected + +type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments + +let propagator_break_ctor : output_break_ctor propagator = + fun selected dbs -> + let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) + let a = selected#a_k_var in + let b = selected#a_k'_var' in + (* produce constraints: *) + + (* a.tv = b.tv *) + let eq1 = C_equation (P_variable a.tv, P_variable b.tv) in + (* a.c_tag = b.c_tag *) + if a.c_tag <> b.c_tag then + failwith "type error: incompatible types, not same ctor (TODO error message)" + else + (* a.tv_list = b.tv_list *) + if List.length a.tv_list <> List.length b.tv_list then + failwith "type error: incompatible types, not same length (TODO error message)" + else + let eqs3 = List.map2 (fun aa bb -> C_equation (P_variable aa, P_variable bb)) a.tv_list b.tv_list in + let eqs = eq1 :: eqs3 in + (eqs , []) (* no new assignments *) + +let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_output propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = + fun selector propagator -> + fun todo dbs -> + match selector todo dbs with + WasSelected selected_outputs -> + (* Call the propagation rule *) + let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in + let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in + (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) + (List.flatten new_constraints , List.flatten new_assignments) + | WasNotSelected -> + ([] , []) + +let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor + +let select_and_propagate_all' : type_constraint_simpl selector_input -> structured_dbs -> 'todo_result = + fun new_constraint dbs -> + let (new_constraints, new_assignments) = select_and_propagate_break_ctor new_constraint dbs in + let assignments = List.fold_left (fun acc ({tv;c_tag=_;tv_list=_} as ele) -> TypeVariableMap.update tv (function None -> Some ele | x -> x) acc) dbs.assignments new_assignments in + let dbs = { dbs with assignments } in + (* let blah2 = select_ … in … *) + (* We should try each selector in turn. If multiple selectors work, what should we do? *) + (new_constraints , dbs) + +let rec select_and_propagate_all : type_constraint selector_input list -> structured_dbs -> 'todo_result = + fun new_constraints dbs -> + match new_constraints with + | [] -> dbs + | new_constraint :: tl -> + let { state = dbs ; list = modified_constraints } = normalizers new_constraint dbs in + let (new_constraints' , dbs) = + List.fold_left + (fun (nc , dbs) c -> + let (new_constraints' , dbs) = select_and_propagate_all' c dbs in + (new_constraints' @ nc , dbs)) + ([] , dbs) + modified_constraints in + let new_constraints = new_constraints' @ tl in + select_and_propagate_all new_constraints dbs + +(* sub-component: constraint selector (worklist / dynamic queries) *) + +(* constraint propagation: (buch of constraints) → (new constraints * assignments) *) + + + + + +(* Below is a draft *) + +type state = { + (* when α-renaming x to y, we put them in the same union-find class *) + unification_vars : unionfind ; + + (* assigns a value to the representant in the unionfind *) + assignments : type_value TypeVariableMap.t ; + + (* constraints related to a type variable *) + constraints : constraints TypeVariableMap.t ; +} + +let initial_state : state = { + unification_vars = UF.empty ; + constraints = TypeVariableMap.empty ; + assignments = TypeVariableMap.empty ; +} + +(* let replace_var_in_state = fun (v : type_variable) (state : state) -> *) +(* let aux_tv : type_value -> _ = function *) +(* | P_forall (w , cs , tval) -> failwith "TODO" *) +(* | P_variable (w) -> *) +(* if w = v then *) +(* (*…*) *) +(* else *) +(* (*…*) *) +(* | P_constant (c , args) -> failwith "TODO" *) +(* | P_access_label (tv , label) -> failwith "TODO" in *) +(* let aux_tc tc = *) +(* List.map (fun l -> List.map aux_tv l) tc in *) +(* let aux : type_constraint -> _ = function *) +(* | C_equation (l , r) -> C_equation (aux_tv l , aux_tv r) *) +(* | C_typeclass (l , rs) -> C_typeclass (List.map aux_tv l , aux_tc rs) *) +(* in List.map aux state *) + +(* let check_equal a b = failwith "TODO" + * let check_same_length l1 l2 = failwith "TODO" + * + * let rec unify : type_value * type_value -> type_constraint list result = function + * | (P_variable v , P_constant (y , argsy)) -> + * failwith "TODO: replace v with the constant everywhere." + * | (P_constant (x , argsx) , P_variable w) -> + * failwith "TODO: " + * | (P_variable v , P_variable w) -> + * failwith "TODO: replace v with w everywhere" + * | (P_constant (x , argsx) , P_constant (y , argsy)) -> + * let%bind () = check_equal x y in + * let%bind () = check_same_length argsx argsy in + * let%bind _ = bind_map_list unify (List.combine argsx argsy) in + * ok [] + * | _ -> failwith "TODO" *) + +(* (\* unify a and b, possibly produce new constraints *\) *) +(* let () = ignore (a,b) in *) +(* ok [] *) + +(* This is the solver *) +let aggregate_constraints : state -> type_constraint list -> state result = fun state newc -> + (* TODO: Iterate over constraints *) + (* TODO: try to unify things: + if we have a = X and b = Y, try to unify X and Y *) + let _todo = ignore (state, newc) in + failwith "TODO" +(*let { constraints ; eqv } = state in + ok { constraints = constraints @ newc ; eqv }*) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 391239506..efa65ae1b 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -8,6 +8,8 @@ module SMap = O.SMap module Environment = O.Environment +module Solver = Solver + type environment = Environment.t module Errors = struct @@ -216,6 +218,7 @@ module Errors = struct ] in error ~data title message end + open Errors let rec type_program (p:I.program) : O.program result = @@ -238,6 +241,9 @@ and type_declaration env : I.declaration -> (environment * O.declaration option) let env' = Environment.add_type type_name tv env in ok (env', None) | Declaration_constant (name , tv_opt , expression) -> ( + (* + Determine the type of the expression and add it to the environment + *) let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind ae' = trace (constant_declaration_error name expression tv'_opt) @@ @@ -340,6 +346,10 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t bind_map_list aux lst in ok (O.Match_variant (lst' , variant)) +(* + Recursively search the type_expression and return a result containing the + type_value at the leaves +*) and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = let return tv' = ok (make_t tv' (Some t)) in match t with @@ -782,6 +792,9 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_address s -> ok (Literal_address s) | Literal_operation s -> ok (Literal_operation s) +(* + Tranform a Ast_typed expression into an ast_simplified matching +*) let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let open I in let return e = ok e in @@ -849,6 +862,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let%bind result = untype_expression result in return (e_let_in (binder , (Some tv)) rhs result) +(* + Tranform a Ast_typed matching into an ast_simplified matching +*) and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> let open I in match m with diff --git a/src/passes/4-typer/typer.ml.old b/src/passes/4-typer/typer.ml.old new file mode 100644 index 000000000..dfd99cbbe --- /dev/null +++ b/src/passes/4-typer/typer.ml.old @@ -0,0 +1,879 @@ +open Trace + +module I = Ast_simplified +module O = Ast_typed +open O.Combinators + +module SMap = O.SMap + +module Environment = O.Environment + +type environment = Environment.t + +module Errors = struct + let unbound_type_variable (e:environment) (n:string) () = + let title = (thunk "unbound type variable") in + let message () = "" in + let data = [ + ("variable" , fun () -> Format.asprintf "%s" n) ; + (* TODO: types don't have srclocs for now. *) + (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) + ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) + ] in + error ~data title message () + + let unbound_variable (e:environment) (n:string) (loc:Location.t) () = + let title = (thunk "unbound variable") in + let message () = "" in + let data = [ + ("variable" , fun () -> Format.asprintf "%s" n) ; + ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "match with no cases") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let unbound_constructor (e:environment) (n:string) (loc:Location.t) () = + let title = (thunk "unbound constructor") in + let message () = "" in + let data = [ + ("constructor" , fun () -> Format.asprintf "%s" n) ; + ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let unrecognized_constant (n:string) (loc:Location.t) () = + let title = (thunk "unrecognized constant") in + let message () = "" in + let data = [ + ("constant" , fun () -> Format.asprintf "%s" n) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () = + let title () = "wrong arity" in + let message () = "" in + let data = [ + ("function" , fun () -> Format.asprintf "%s" n) ; + ("expected" , fun () -> Format.asprintf "%d" expected) ; + ("actual" , fun () -> Format.asprintf "%d" actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () = + let title () = "matching tuple of different size" in + let message () = "" in + let data = [ + ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ; + ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + (* TODO: this should be a trace_info? *) + let program_error (p:I.program) () = + let message () = "" in + let title = (thunk "typing program") in + let data = [ + ("program" , fun () -> Format.asprintf "%a" I.PP.program p) + ] in + error ~data title message () + + let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_expression option) () = + let title = (thunk "typing constant declaration") in + let message () = "" in + let data = [ + ("constant" , fun () -> Format.asprintf "%s" name) ; + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("expected" , fun () -> + match expected with + None -> "(no annotation for the expected type)" + | Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) + ] in + error ~data title message () + + let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_expression -> Location.t -> unit -> _ = + fun ?(msg = "") ~expected ~actual loc () -> + let title = (thunk "typing match") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let needs_annotation (e : I.expression) (case : string) () = + let title = (thunk "this expression must be annotated with its type") in + let message () = Format.asprintf "%s needs an annotation" case in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp e.location) + ] in + error ~data title message () + + let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () = + let title = (thunk "type error") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%s" expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual); + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () = + let title = (thunk "type error") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual); + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_expression) (loc:Location.t) () = + let title = (thunk "invalid tuple index") in + let message () = "" in + let data = [ + ("index" , fun () -> Format.asprintf "%d" index) ; + ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_expression t) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_record_access (field : string) (ae : I.expression) (t : O.type_expression) (loc:Location.t) () = + let title = (thunk "invalid record field") in + let message () = "" in + let data = [ + ("field" , fun () -> Format.asprintf "%s" field) ; + ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_expression t) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let not_supported_yet (message : string) (ae : I.expression) () = + let title = (thunk "not supported yet") in + let message () = message in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) + ] in + error ~data title message () + + let not_supported_yet_untranspile (message : string) (ae : O.expression) () = + let title = (thunk "not supported yet") in + let message () = message in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae) + ] in + error ~data title message () + + let constant_error loc lst tv_opt = + let title () = "typing constant" in + let message () = "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp loc ) ; + ("argument_types" , fun () -> Format.asprintf "%a" PP_helpers.(list_sep Ast_typed.PP.type_expression (const " , ")) lst) ; + ("type_opt" , fun () -> Format.asprintf "%a" PP_helpers.(option Ast_typed.PP.type_expression) tv_opt) ; + ] in + error ~data title message +end +open Errors + +let rec type_program (p:I.program) : O.program result = + let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = + let%bind ed' = (bind_map_location (type_declaration e)) d in + let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in + let (e', d') = Location.unwrap ed' in + match d' with + | None -> ok (e', acc) + | Some d' -> ok (e', loc ed' d' :: acc) + in + let%bind (_, lst) = + trace (fun () -> program_error p ()) @@ + bind_fold_list aux (Environment.full_empty, []) p in + ok @@ List.rev lst + +and type_declaration env : I.declaration -> (environment * O.declaration option) result = function + | Declaration_type (type_name , type_expression) -> + let%bind tv = evaluate_type env type_expression in + let env' = Environment.add_type type_name tv env in + ok (env', None) + | Declaration_constant (name , tv_opt , expression) -> ( + let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in + let%bind ae' = + trace (constant_declaration_error name expression tv'_opt) @@ + type_expression ?tv_opt:tv'_opt env expression in + let env' = Environment.add_ez_ae name ae' env in + ok (env', Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) + ) + +and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_expression -> i I.matching -> I.expression -> Location.t -> o O.matching result = + fun f e t i ae loc -> match i with + | Match_bool {match_true ; match_false} -> + let%bind _ = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_bool t in + let%bind match_true = f e match_true in + let%bind match_false = f e match_false in + ok (O.Match_bool {match_true ; match_false}) + | Match_option {match_none ; match_some} -> + let%bind t_opt = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_option t in + let%bind match_none = f e match_none in + let (n, b) = match_some in + let n' = n, t_opt in + let e' = Environment.add_ez_binder n t_opt e in + let%bind b' = f e' b in + ok (O.Match_option {match_none ; match_some = (n', b')}) + | Match_list {match_nil ; match_cons} -> + let%bind t_list = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_list t in + let%bind match_nil = f e match_nil in + let (hd, tl, b) = match_cons in + let e' = Environment.add_ez_binder hd t_list e in + let e' = Environment.add_ez_binder tl t e' in + let%bind b' = f e' b in + ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) + | Match_tuple (lst, b) -> + let%bind t_tuple = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_tuple t in + let%bind lst' = + generic_try (match_tuple_wrong_arity t_tuple lst loc) + @@ (fun () -> List.combine lst t_tuple) in + let aux prev (name, tv) = Environment.add_ez_binder name tv prev in + let e' = List.fold_left aux e lst' in + let%bind b' = f e' b in + ok (O.Match_tuple (lst, b')) + | Match_variant lst -> + let%bind variant_opt = + let aux acc ((constructor_name , _) , _) = + let%bind (_ , variant) = + trace_option (unbound_constructor e constructor_name loc) @@ + Environment.get_constructor constructor_name e in + let%bind acc = match acc with + | None -> ok (Some variant) + | Some variant' -> ( + trace (type_error + ~msg:"in match variant" + ~expected:variant + ~actual:variant' + ~expression:ae + loc + ) @@ + Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () -> + ok (Some variant) + ) in + ok acc in + trace (simple_info "in match variant") @@ + bind_fold_list aux None lst in + let%bind variant = + trace_option (match_empty_variant i loc) @@ + variant_opt in + let%bind () = + let%bind variant_cases' = + trace (match_error ~expected:i ~actual:t loc) + @@ Ast_typed.Combinators.get_t_sum variant in + let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in + let match_cases = List.map (Function.compose fst fst) lst in + let test_case = fun c -> + Assert.assert_true (List.mem c match_cases) + in + let%bind () = + trace_strong (match_missing_case i loc) @@ + bind_iter_list test_case variant_cases in + let%bind () = + trace_strong (match_redundant_case i loc) @@ + Assert.assert_true List.(length variant_cases = length match_cases) in + ok () + in + let%bind lst' = + let aux ((constructor_name , name) , b) = + let%bind (constructor , _) = + trace_option (unbound_constructor e constructor_name loc) @@ + Environment.get_constructor constructor_name e in + let e' = Environment.add_ez_binder name constructor e in + let%bind b' = f e' b in + ok ((constructor_name , name) , b') + in + bind_map_list aux lst in + ok (O.Match_variant (lst' , variant)) + +and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result = + let return tv' = ok (make_t tv' (Some t)) in + match t with + | T_function (a, b) -> + let%bind a' = evaluate_type e a in + let%bind b' = evaluate_type e b in + return (T_function (a', b')) + | T_tuple lst -> + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + return (T_tuple lst') + | T_sum m -> + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + return (T_sum m) + | T_record m -> + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + return (T_record m) + | T_variable name -> + let%bind tv = + trace_option (unbound_type_variable e name) + @@ Environment.get_type_opt name e in + ok tv + | T_constant (cst, lst) -> + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + return (T_constant(cst, lst')) + +and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression -> O.annotated_expression result = fun e ?tv_opt ae -> + let module L = Logger.Stateful() in + let return expr tv = + let%bind () = + match tv_opt with + | None -> ok () + | Some tv' -> O.assert_type_expression_eq (tv' , tv) in + let location = Location.get_location ae in + ok @@ make_a_e ~location expr tv e in + let main_error = + let title () = "typing expression" in + let content () = "" in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp @@ Location.get_location ae) ; + ("misc" , fun () -> L.get ()) ; + ] in + error ~data title content in + trace main_error @@ + match Location.unwrap ae with + (* Basic *) + | E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword" + | E_variable name -> + let%bind tv' = + trace_option (unbound_variable e name ae.location) + @@ Environment.get_opt name e in + return (E_variable name) tv'.type_expression + | E_literal (Literal_bool b) -> + return (E_literal (Literal_bool b)) (t_bool ()) + | E_literal Literal_unit | E_skip -> + return (E_literal (Literal_unit)) (t_unit ()) + | E_literal (Literal_string s) -> ( + L.log (Format.asprintf "literal_string option type: %a" PP_helpers.(option O.PP.type_expression) tv_opt) ; + match Option.map Ast_typed.get_type' tv_opt with + | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) + | _ -> return (E_literal (Literal_string s)) (t_string ()) + ) + | E_literal (Literal_bytes s) -> + return (E_literal (Literal_bytes s)) (t_bytes ()) + | E_literal (Literal_int n) -> + return (E_literal (Literal_int n)) (t_int ()) + | E_literal (Literal_nat n) -> + return (E_literal (Literal_nat n)) (t_nat ()) + | E_literal (Literal_timestamp n) -> + return (E_literal (Literal_timestamp n)) (t_timestamp ()) + | E_literal (Literal_tez n) -> + return (E_literal (Literal_tez n)) (t_tez ()) + | E_literal (Literal_address s) -> + return (e_address s) (t_address ()) + | E_literal (Literal_operation op) -> + return (e_operation op) (t_operation ()) + (* Tuple *) + | E_tuple lst -> + let%bind lst' = bind_list @@ List.map (type_expression e) lst in + let tv_lst = List.map get_type_annotation lst' in + return (E_tuple lst') (t_tuple tv_lst ()) + | E_accessor (ae', path) -> + let%bind e' = type_expression e ae' in + let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = + match a with + | Access_tuple index -> ( + let%bind tpl_tv = get_t_tuple prev.type_annotation in + let%bind tv = + generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) + @@ (fun () -> List.nth tpl_tv index) in + return (E_tuple_accessor (prev , index)) tv + ) + | Access_record property -> ( + let%bind r_tv = get_t_record prev.type_annotation in + let%bind tv = + generic_try (bad_record_access property ae' prev.type_annotation ae.location) + @@ (fun () -> SMap.find property r_tv) in + return (E_record_accessor (prev , property)) tv + ) + | Access_map ae' -> ( + let%bind ae'' = type_expression e ae' in + let%bind (k , v) = get_t_map prev.type_annotation in + let%bind () = + Ast_typed.assert_type_expression_eq (k , get_type_annotation ae'') in + return (E_look_up (prev , ae'')) v + ) + in + trace (simple_info "accessing") @@ + bind_fold_list aux e' path + + (* Sum *) + | E_constructor (c, expr) -> + let%bind (c_tv, sum_tv) = + let error = + let title () = "no such constructor" in + let content () = + Format.asprintf "%s in:\n%a\n" + c O.Environment.PP.full_environment e + in + error title content in + trace_option error @@ + Environment.get_constructor c e in + let%bind expr' = type_expression e expr in + let%bind _assert = O.assert_type_expression_eq (expr'.type_annotation, c_tv) in + return (E_constructor (c , expr')) sum_tv + (* Record *) + | E_record m -> + let aux prev k expr = + let%bind expr' = type_expression e expr in + ok (SMap.add k expr' prev) + in + let%bind m' = bind_fold_smap aux (ok SMap.empty) m in + return (E_record m') (t_record (SMap.map get_type_annotation m') ()) + (* Data-structure *) + | E_list lst -> + let%bind lst' = bind_map_list (type_expression e) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in + ok (Some c') in + let%bind init = match tv_opt with + | None -> ok None + | Some ty -> + let%bind ty' = get_t_list ty in + ok (Some ty') in + let%bind ty = + let%bind opt = bind_fold_list aux init + @@ List.map get_type_annotation lst' in + trace_option (needs_annotation ae "empty list") opt in + ok (t_list ty ()) + in + return (E_list lst') tv + | E_set lst -> + let%bind lst' = bind_map_list (type_expression e) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in + ok (Some c') in + let%bind init = match tv_opt with + | None -> ok None + | Some ty -> + let%bind ty' = get_t_set ty in + ok (Some ty') in + let%bind ty = + let%bind opt = bind_fold_list aux init + @@ List.map get_type_annotation lst' in + trace_option (needs_annotation ae "empty set") opt in + ok (t_set ty ()) + in + return (E_set lst') tv + | E_map lst -> + let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in + ok (Some c') in + let%bind key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_map key_type value_type ()) + in + return (E_map lst') tv + | E_lambda { + binder ; + input_type ; + output_type ; + result ; + } -> ( + let%bind input_type = + let%bind input_type = + (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *) + let default_action e () = fail @@ (needs_annotation e "the returned value") in + match input_type with + | Some ty -> ok ty + | None -> ( + match Location.unwrap result with + | I.E_let_in li -> ( + match Location.unwrap li.rhs with + | I.E_variable name when name = (fst binder) -> ( + match snd li.binder with + | Some ty -> ok ty + | None -> default_action li.rhs () + ) + | _ -> default_action li.rhs () + ) + | _ -> default_action result () + ) + in + evaluate_type e input_type in + let%bind output_type = + bind_map_option (evaluate_type e) output_type + in + let e' = Environment.add_ez_binder (fst binder) input_type e in + let%bind result = type_expression ?tv_opt:output_type e' result in + let output_type = result.type_annotation in + return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ()) + ) + | E_constant (name, lst) -> + let%bind lst' = bind_list @@ List.map (type_expression e) lst in + let tv_lst = List.map get_type_annotation lst' in + let%bind (name', tv) = + type_constant name tv_lst tv_opt ae.location in + return (E_constant (name' , lst')) tv + | E_application (f, arg) -> + let%bind f' = type_expression e f in + let%bind arg = type_expression e arg in + let%bind tv = match f'.type_annotation.type_expression' with + | T_function (param, result) -> + let%bind _ = O.assert_type_expression_eq (param, arg.type_annotation) in + ok result + | _ -> + fail @@ type_error_approximate + ~expected:"should be a function type" + ~expression:f + ~actual:f'.type_annotation + f'.location + in + return (E_application (f' , arg)) tv + | E_look_up dsi -> + let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in + let%bind (src, dst) = get_t_map ds.type_annotation in + let%bind _ = O.assert_type_expression_eq (ind.type_annotation, src) in + return (E_look_up (ds , ind)) (t_option dst ()) + (* Advanced *) + | E_matching (ex, m) -> ( + let%bind ex' = type_expression e ex in + match m with + (* Special case for assert-like failwiths. TODO: CLEAN THIS. *) + | I.Match_bool { match_false ; match_true } when I.is_e_failwith match_true -> ( + let%bind fw = I.get_e_failwith match_true in + let%bind fw' = type_expression e fw in + let%bind mf' = type_expression e match_false in + let t = get_type_annotation ex' in + let%bind () = + trace_strong (match_error ~expected:m ~actual:t ae.location) + @@ assert_t_bool t in + let%bind () = + trace_strong (match_error + ~msg:"matching not-unit on an assert" + ~expected:m + ~actual:t + ae.location) + @@ assert_t_unit (get_type_annotation mf') in + let mt' = make_a_e + (E_constant ("ASSERT_INFERRED" , [ex' ; fw'])) + (t_unit ()) + e + in + let m' = O.Match_bool { match_true = mt' ; match_false = mf' } in + return (O.E_matching (ex' , m')) (t_unit ()) + ) + | _ -> ( + let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae ae.location in + let tvs = + let aux (cur:O.value O.matching) = + match cur with + | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] + | Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ] + | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] + | Match_tuple (_ , match_tuple) -> [ match_tuple ] + | Match_variant (lst , _) -> List.map snd lst in + List.map get_type_annotation @@ aux m' in + let aux prec cur = + let%bind () = + match prec with + | None -> ok () + | Some cur' -> Ast_typed.assert_type_expression_eq (cur , cur') in + ok (Some cur) in + let%bind tv_opt = bind_fold_list aux None tvs in + let%bind tv = + trace_option (match_empty_variant m ae.location) @@ + tv_opt in + return (O.E_matching (ex', m')) tv + ) + ) + | E_sequence (a , b) -> + let%bind a' = type_expression e a in + let%bind b' = type_expression e b in + let a'_type_annot = get_type_annotation a' in + let%bind () = + trace_strong (type_error + ~msg:"first part of the sequence should be of unit type" + ~expected:(O.t_unit ()) + ~actual:a'_type_annot + ~expression:a + a'.location) @@ + Ast_typed.assert_type_expression_eq (t_unit () , a'_type_annot) in + return (O.E_sequence (a' , b')) (get_type_annotation b') + | E_loop (expr , body) -> + let%bind expr' = type_expression e expr in + let%bind body' = type_expression e body in + let t_expr' = get_type_annotation expr' in + let%bind () = + trace_strong (type_error + ~msg:"while condition isn't of type bool" + ~expected:(O.t_bool ()) + ~actual:t_expr' + ~expression:expr + expr'.location) @@ + Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in + let t_body' = get_type_annotation body' in + let%bind () = + trace_strong (type_error + ~msg:"while body isn't of unit type" + ~expected:(O.t_unit ()) + ~actual:t_body' + ~expression:body + body'.location) @@ + Ast_typed.assert_type_expression_eq (t_unit () , t_body') in + return (O.E_loop (expr' , body')) (t_unit ()) + | E_assign (name , path , expr) -> + let%bind typed_name = + let%bind ele = Environment.get_trace name e in + ok @@ make_n_t name ele.type_expression in + let%bind (assign_tv , path') = + let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path -> + match cur_path with + | Access_tuple index -> ( + let%bind tpl = get_t_tuple prec_tv in + let%bind tv' = + trace_option (bad_tuple_index index ae prec_tv ae.location) @@ + List.nth_opt tpl index in + ok (tv' , prec_path @ [O.Access_tuple index]) + ) + | Access_record property -> ( + let%bind m = get_t_record prec_tv in + let%bind tv' = + trace_option (bad_record_access property ae prec_tv ae.location) @@ + Map.String.find_opt property m in + ok (tv' , prec_path @ [O.Access_record property]) + ) + | Access_map _ -> + fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae + in + bind_fold_list aux (typed_name.type_expression , []) path in + let%bind expr' = type_expression e expr in + let t_expr' = get_type_annotation expr' in + let%bind () = + trace_strong (type_error + ~msg:"type of the expression to assign doesn't match left-hand-side" + ~expected:assign_tv + ~actual:t_expr' + ~expression:expr + expr'.location) @@ + Ast_typed.assert_type_expression_eq (assign_tv , t_expr') in + return (O.E_assign (typed_name , path' , expr')) (t_unit ()) + | E_let_in {binder ; rhs ; result} -> + let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in + let%bind rhs = type_expression ?tv_opt:rhs_tv_opt e rhs in + let e' = Environment.add_ez_declaration (fst binder) rhs e in + let%bind result = type_expression e' result in + return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation + | E_annotation (expr , te) -> + let%bind tv = evaluate_type e te in + let%bind expr' = type_expression ~tv_opt:tv e expr in + let%bind type_annotation = + O.merge_annotation + (Some tv) + (Some expr'.type_annotation) + (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in + ok {expr' with type_annotation} + + +and type_constant (name:string) (lst:O.type_expression list) (tv_opt:O.type_expression option) (loc : Location.t) : (string * O.type_expression) result = + (* Constant poorman's polymorphism *) + let ct = Operators.Typer.constant_typers in + let%bind typer = + trace_option (unrecognized_constant name loc) @@ + Map.String.find_opt name ct in + trace (constant_error loc lst tv_opt) @@ + typer lst tv_opt + +let untype_type_expression (t:O.type_expression) : (I.type_expression) result = + match t.simplified with + | Some s -> ok s + | _ -> fail @@ internal_assertion_failure "trying to untype generated type" + +let untype_literal (l:O.literal) : I.literal result = + let open I in + match l with + | Literal_unit -> ok Literal_unit + | Literal_bool b -> ok (Literal_bool b) + | Literal_nat n -> ok (Literal_nat n) + | Literal_timestamp n -> ok (Literal_timestamp n) + | Literal_tez n -> ok (Literal_tez n) + | Literal_int n -> ok (Literal_int n) + | Literal_string s -> ok (Literal_string s) + | Literal_bytes b -> ok (Literal_bytes b) + | Literal_address s -> ok (Literal_address s) + | Literal_operation s -> ok (Literal_operation s) + +let rec untype_expression (e:O.annotated_expression) : (I.expression) result = + let open I in + let return e = ok e in + match e.expression with + | E_literal l -> + let%bind l = untype_literal l in + return (e_literal l) + | E_constant (n, lst) -> + let%bind lst' = bind_map_list untype_expression lst in + return (e_constant n lst') + | E_variable n -> + return (e_variable n) + | E_application (f, arg) -> + let%bind f' = untype_expression f in + let%bind arg' = untype_expression arg in + return (e_application f' arg') + | E_lambda {binder;input_type;output_type;result} -> + let%bind input_type = untype_type_expression input_type in + let%bind output_type = untype_type_expression output_type in + let%bind result = untype_expression result in + return (e_lambda binder (Some input_type) (Some output_type) result) + | E_tuple lst -> + let%bind lst' = bind_list + @@ List.map untype_expression lst in + return (e_tuple lst') + | E_tuple_accessor (tpl, ind) -> + let%bind tpl' = untype_expression tpl in + return (e_accessor tpl' [Access_tuple ind]) + | E_constructor (n, p) -> + let%bind p' = untype_expression p in + return (e_constructor n p') + | E_record r -> + let%bind r' = bind_smap + @@ SMap.map untype_expression r in + return (e_record r') + | E_record_accessor (r, s) -> + let%bind r' = untype_expression r in + return (e_accessor r' [Access_record s]) + | E_map m -> + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_map m') + | E_list lst -> + let%bind lst' = bind_map_list untype_expression lst in + return (e_list lst') + | E_set lst -> + let%bind lst' = bind_map_list untype_expression lst in + return (e_set lst') + | E_look_up dsi -> + let%bind (a , b) = bind_map_pair untype_expression dsi in + return (e_look_up a b) + | E_matching (ae, m) -> + let%bind ae' = untype_expression ae in + let%bind m' = untype_matching untype_expression m in + return (e_matching ae' m') + | E_failwith ae -> + let%bind ae' = untype_expression ae in + return (e_failwith ae') + | E_sequence _ + | E_loop _ + | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression + | E_let_in {binder;rhs;result} -> + let%bind tv = untype_type_expression rhs.type_annotation in + let%bind rhs = untype_expression rhs in + let%bind result = untype_expression result in + return (e_let_in (binder , (Some tv)) rhs result) + +and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> + let open I in + match m with + | Match_bool {match_true ; match_false} -> + let%bind match_true = f match_true in + let%bind match_false = f match_false in + ok @@ Match_bool {match_true ; match_false} + | Match_tuple (lst, b) -> + let%bind b = f b in + ok @@ Match_tuple (lst, b) + | Match_option {match_none ; match_some = (v, some)} -> + let%bind match_none = f match_none in + let%bind some = f some in + let match_some = fst v, some in + ok @@ Match_option {match_none ; match_some} + | Match_list {match_nil ; match_cons = (hd, tl, cons)} -> + let%bind match_nil = f match_nil in + let%bind cons = f cons in + let match_cons = hd, tl, cons in + ok @@ Match_list {match_nil ; match_cons} + | Match_variant (lst , _) -> + let aux ((a,b),c) = + let%bind c' = f c in + ok ((a,b),c') in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant lst' diff --git a/src/passes/operators/dune b/src/passes/operators/dune index 0bd5db43d..f2125905a 100644 --- a/src/passes/operators/dune +++ b/src/passes/operators/dune @@ -5,6 +5,7 @@ simple-utils tezos-utils ast_typed + typesystem mini_c ) (preprocess diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 47627a440..5eb1dfb91 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -219,6 +219,65 @@ module Typer = struct open Helpers.Typer open Ast_typed + module Operators_types = struct + open Typesystem.Shorthands + + let tc_subarg a b c = tc [a;b;c] [ (*TODO…*) ] + let tc_sizearg a = tc [a] [ [int] ] + let tc_packable a = tc [a] [ [int] ; [string] ; [bool] (*TODO…*) ] + let tc_timargs a b c = tc [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ] + let tc_divargs a b c = tc [a;b;c] [ (*TODO…*) ] + let tc_modargs a b c = tc [a;b;c] [ (*TODO…*) ] + let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ] + + let t_none = forall "a" @@ fun a -> option a + let t_sub = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => a --> b --> c (* TYPECLASS *) + let t_some = forall "a" @@ fun a -> a --> option a + let t_map_remove = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> map src dst + let t_map_add = forall2 "src" "dst" @@ fun src dst -> src --> dst --> map src dst --> map src dst + let t_map_update = forall2 "src" "dst" @@ fun src dst -> src --> option dst --> map src dst --> map src dst + let t_map_mem = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> bool + let t_map_find = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> dst + let t_map_find_opt = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> option dst + let t_map_fold = forall3 "src" "dst" "acc" @@ fun src dst acc -> ( ( (src * dst) * acc ) --> acc ) --> map src dst --> acc --> acc + let t_map_map = forall3 "k" "v" "result" @@ fun k v result -> ((k * v) --> result) --> map k v --> map k result + + (* TODO: the type of map_map_fold might be wrong, check it. *) + let t_map_map_fold = forall4 "k" "v" "acc" "dst" @@ fun k v acc dst -> ( ((k * v) * acc) --> acc * dst ) --> map k v --> (k * v) --> (map k dst * acc) + let t_map_iter = forall2 "k" "v" @@ fun k v -> ( (k * v) --> unit ) --> map k v --> unit + let t_size = forall_tc "c" @@ fun c -> [tc_sizearg c] => c --> nat (* TYPECLASS *) + let t_slice = nat --> nat --> string --> string + let t_failwith = string --> unit + let t_get_force = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> dst + let t_int = nat --> int + let t_bytes_pack = forall_tc "a" @@ fun a -> [tc_packable a] => a --> bytes (* TYPECLASS *) + let t_bytes_unpack = forall_tc "a" @@ fun a -> [tc_packable a] => bytes --> a (* TYPECLASS *) + let t_hash256 = bytes --> bytes + let t_hash512 = bytes --> bytes + let t_blake2b = bytes --> bytes + let t_hash_key = key --> key_hash + let t_check_signature = key --> signature --> bytes --> bool + let t_sender = address + let t_source = address + let t_unit = unit + let t_amount = tez + let t_address = address + let t_now = timestamp + let t_transaction = forall "a" @@ fun a -> a --> tez --> contract a --> operation + let t_get_contract = forall "a" @@ fun a -> contract a + let t_abs = int --> nat + let t_cons = forall "a" @@ fun a -> a --> list a --> list a + let t_assertion = bool --> unit + let t_times = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => a --> b --> c (* TYPECLASS *) + let t_div = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => a --> b --> c (* TYPECLASS *) + let t_mod = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => a --> b --> c (* TYPECLASS *) + let t_add = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => a --> b --> c (* TYPECLASS *) + let t_set_mem = forall "a" @@ fun a -> a --> set a --> bool + let t_set_add = forall "a" @@ fun a -> a --> set a --> set a + let t_set_remove = forall "a" @@ fun a -> a --> set a --> set a + let t_not = bool --> bool + end + let none = typer_0 "NONE" @@ fun tv_opt -> match tv_opt with | None -> simple_fail "untyped NONE" @@ -647,6 +706,7 @@ module Typer = struct get_contract ; neg ; abs ; + cons ; now ; slice ; address ; diff --git a/src/typesystem/core.ml b/src/typesystem/core.ml new file mode 100644 index 000000000..69a5d413c --- /dev/null +++ b/src/typesystem/core.ml @@ -0,0 +1,60 @@ + type type_variable = string + + let fresh_type_variable : ?name:string -> unit -> type_variable = + let id = ref 0 in + let inc () = id := !id + 1 in + fun ?name () -> + inc () ; + match name with + | None -> "type_variable_" ^ (string_of_int !id) + | Some name -> "tv_" ^ name ^ "_" ^ (string_of_int !id) + + + type constant_tag = + | C_arrow (* * -> * -> * *) + | C_option (* * -> * *) + | C_tuple (* * … -> * *) + | C_record (* ( label , * ) … -> * *) + | C_variant (* ( label , * ) … -> * *) + | C_map (* * -> * -> * *) + | C_list (* * -> * *) + | C_set (* * -> * *) + | C_unit (* * *) + | C_bool (* * *) + | C_string (* * *) + | C_nat (* * *) + | C_tez (* * *) + | C_timestamp (* * *) + | C_int (* * *) + | C_address (* * *) + | C_bytes (* * *) + | C_key_hash (* * *) + | C_key (* * *) + | C_signature (* * *) + | C_operation (* * *) + | C_contract (* * -> * *) + + type label = + | L_int of int + | L_string of string + + type type_value = + | P_forall of (type_variable * type_constraint list * type_value) + | P_variable of type_variable + | P_constant of (constant_tag * type_value list) + + and simple_c_constructor = (constant_tag * type_variable list) (* non-empty list *) + and simple_c_constant = (constant_tag) (* for type constructors that do not take arguments *) + and c_const = (type_variable * type_value) + and c_equation = (type_value * type_value) + and c_typeclass = (type_value list * typeclass) + and c_access_label = (type_value * label * type_variable) + + and type_constraint = + (* | C_assignment of (type_variable * type_pattern) *) + | C_equation of c_equation (* TVA = TVB *) + | C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *) + | C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *) + (* | … *) + + and typeclass = type_value list list diff --git a/src/typesystem/dune b/src/typesystem/dune new file mode 100644 index 000000000..d5e1deaf6 --- /dev/null +++ b/src/typesystem/dune @@ -0,0 +1,14 @@ +(library + (name typesystem) + (public_name ligo.typesystem) + (libraries + simple-utils + tezos-utils + ast_typed + mini_c + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/typesystem/shorthands.ml b/src/typesystem/shorthands.ml new file mode 100644 index 000000000..2bf16dd9c --- /dev/null +++ b/src/typesystem/shorthands.ml @@ -0,0 +1,62 @@ +open Core + +let tc type_vars allowed_list = + Core.C_typeclass (type_vars , allowed_list) + +let forall binder f = + let () = ignore binder in + let freshvar = fresh_type_variable () in + P_forall (freshvar , [] , f (P_variable freshvar)) + +let forall_tc binder f = + let () = ignore binder in + let freshvar = fresh_type_variable () in + let (tc, ty) = f (P_variable freshvar) in + P_forall (freshvar , tc , ty) + +let forall2 a b f = + forall a @@ fun a' -> + forall b @@ fun b' -> + f a' b' + +let forall3 a b c f = + forall a @@ fun a' -> + forall b @@ fun b' -> + forall c @@ fun c' -> + f a' b' c' + +let forall4 a b c d f = + forall a @@ fun a' -> + forall b @@ fun b' -> + forall c @@ fun c' -> + forall d @@ fun d' -> + f a' b' c' d' + +let forall3_tc a b c f = + forall a @@ fun a' -> + forall b @@ fun b' -> + forall_tc c @@ fun c' -> + f a' b' c' + +let (-->) arg ret = P_constant (C_arrow , [arg; ret]) +let (=>) tc ty = (tc , ty) +let option t = P_constant (C_option , [t]) +let pair a b = P_constant (C_tuple , [a; b]) +let map k v = P_constant (C_map , [k; v]) +let unit = P_constant (C_unit , []) +let list t = P_constant (C_list , [t]) +let set t = P_constant (C_set , [t]) +let bool = P_constant (C_bool , []) +let string = P_constant (C_string , []) +let nat = P_constant (C_nat , []) +let tez = P_constant (C_tez , []) +let timestamp = P_constant (C_timestamp , []) +let int = P_constant (C_int , []) +let address = P_constant (C_address , []) +let bytes = P_constant (C_bytes , []) +let key = P_constant (C_key , []) +let key_hash = P_constant (C_key_hash , []) +let signature = P_constant (C_signature , []) +let operation = P_constant (C_operation , []) +let contract t = P_constant (C_contract , [t]) +let ( * ) a b = pair a b diff --git a/src/typesystem/typesystem.ml b/src/typesystem/typesystem.ml new file mode 100644 index 000000000..b97e373e9 --- /dev/null +++ b/src/typesystem/typesystem.ml @@ -0,0 +1,2 @@ +module Core = Core +module Shorthands = Shorthands diff --git a/src/union_find/.PartitionMain.tag b/src/union_find/.PartitionMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/src/union_find/.links b/src/union_find/.links new file mode 100644 index 000000000..b79d096bc --- /dev/null +++ b/src/union_find/.links @@ -0,0 +1 @@ +../OCaml-build/Makefile diff --git a/src/union_find/LICENSE b/src/union_find/LICENSE new file mode 100644 index 000000000..33a225af0 --- /dev/null +++ b/src/union_find/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Christian Rinderknecht + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/union_find/Makefile.cfg b/src/union_find/Makefile.cfg new file mode 100644 index 000000000..13c016eb6 --- /dev/null +++ b/src/union_find/Makefile.cfg @@ -0,0 +1,4 @@ +SHELL := dash +BFLAGS := -strict-sequence -w +A-48-4 +#OCAMLC := ocamlcp +#OCAMLOPT := ocamloptp diff --git a/src/union_find/Partition.mli b/src/union_find/Partition.mli new file mode 100644 index 000000000..657b3c007 --- /dev/null +++ b/src/union_find/Partition.mli @@ -0,0 +1,64 @@ +(** This module offers the abstract data type of a partition of + classes of equivalent items (Union & Find). *) + +(** The items are of type [Item.t], that is, they have to obey + a total order, but also they must be printable to ease + debugging. The signature [Item] is the input signature of + the functor {!Partition.Make}. *) +module type Item = + sig + (** Type of items *) + type t + + (** Same convention as {!Pervasives.compare} *) + val compare : t -> t -> int + + val to_string : t -> string + end + +(** The module signature [S] is the output signature of the functor + {!Partition.Make}. *) +module type S = + sig + type item + type partition + type t = partition + + (** {1 Creation} *) + + (** The value [empty] is an empty partition. *) + val empty : partition + + (** The value of [equiv i j p] is the partition [p] extended with + the equivalence of items [i] and [j]. If both [i] and [j] are + already known to be equivalent, then [equiv i j p == p]. *) + val equiv : item -> item -> partition -> partition + + (** The value of [alias i j p] is the partition [p] extended with + the fact that item [i] is an alias of item [j]. This is the + same as [equiv i j p], except that it is guaranteed that the + item [i] is not the representative of its equivalence class in + [alias i j p]. *) + val alias : item -> item -> partition -> partition + + (** {1 Projection} *) + + (** The value of the call [repr i p] is the representative of item + [i] in the partition [p]. The built-in exception [Not_found] + is raised if [i] is not in [p]. *) + val repr : item -> partition -> item + + (** The side-effect of the call [print p] is the printing of the + partition [p] on standard output, based on [Ord.to_string]. *) + val print : partition -> unit + + (** {1 Predicates} *) + + (** The value of [is_equiv i j p] is [true] if, and only if, the + items [i] and [j] belong to the same equivalence class in the + partition [p], that is, [i] and [j] have the same + representative. *) + val is_equiv : item -> item -> partition -> bool + end + +module Make (Ord : Item) : S with type item = Ord.t diff --git a/src/union_find/Partition0.ml b/src/union_find/Partition0.ml new file mode 100644 index 000000000..968bb8dd4 --- /dev/null +++ b/src/union_find/Partition0.ml @@ -0,0 +1,47 @@ +(* Naive persistent implementation of Union/Find: O(n^2) worst case *) + +module Make (Item: Partition.Item) = + struct + + type item = Item.t + type repr = item (** Class representatives *) + + let equal i j = Item.compare i j = 0 + + module ItemMap = Map.Make (Item) + + type height = int + + type partition = item ItemMap.t + type t = partition + + let empty = ItemMap.empty + + let rec repr item partition = + let parent = ItemMap.find item partition in + if equal parent item + then item + else repr parent partition + + let is_equiv (i: item) (j: item) (p: partition) = + equal (repr i p) (repr j p) + + let get_or_set (i: item) (p: partition) : item * partition = + try repr i p, p with Not_found -> i, ItemMap.add i i p + + let equiv (i: item) (j :item) (p: partition) : partition = + let ri, p = get_or_set i p in + let rj, p = get_or_set j p in + if equal ri rj then p else ItemMap.add ri rj p + + let alias = equiv + + (* Printing *) + + let print p = + let print src dst = + Printf.printf "%s -> %s\n" + (Item.to_string src) (Item.to_string dst) + in ItemMap.iter print p + + end diff --git a/src/union_find/Partition1.ml b/src/union_find/Partition1.ml new file mode 100644 index 000000000..764d98d49 --- /dev/null +++ b/src/union_find/Partition1.ml @@ -0,0 +1,69 @@ +(* Persistent implementation of Union/Find with height-balanced + forests and without path compression: O(n*log(n)). + + In the definition of type [t], the height component is that of the + source, that is, if [ItemMap.find i m = (j,h)], then [h] is the + height of [i] (_not_ [j]). +*) + +module Make (Item: Partition.Item) = + struct + + type item = Item.t + type repr = item (** Class representatives *) + + let equal i j = Item.compare i j = 0 + + module ItemMap = Map.Make (Item) + + type height = int + + type partition = (item * height) ItemMap.t + type t = partition + + let empty = ItemMap.empty + + let rec seek (i: item) (p: partition) : repr * height = + let j, _ as i' = ItemMap.find i p in + if equal i j then i' else seek j p + + let repr item partition = fst (seek item partition) + + let is_equiv (i: item) (j: item) (p: partition) = + equal (repr i p) (repr j p) + + let get_or_set (i: item) (p: partition) = + try seek i p, p with + Not_found -> let i' = i,0 in (i', ItemMap.add i i' p) + + let equiv (i: item) (j: item) (p: partition) : partition = + let (ri,hi), p = get_or_set i p in + let (rj,hj), p = get_or_set j p in + let add = ItemMap.add in + if equal ri rj + then p + else if hi > hj + then add rj (ri,hj) p + else add ri (rj,hi) (if hi < hj then p else add rj (rj,hj+1) p) + + let alias (i: item) (j: item) (p: partition) : partition = + let (ri,hi), p = get_or_set i p in + let (rj,hj), p = get_or_set j p in + let add = ItemMap.add in + if equal ri rj + then p + else if hi = hj || equal ri i + then add ri (rj,hi) @@ add rj (rj, max hj (hi+1)) p + else if hi < hj then add ri (rj,hi) p + else add rj (ri,hj) p + + (* Printing *) + + let print (p: partition) = + let print i (j,hi) = + let _,hj = ItemMap.find j p in + Printf.printf "%s,%d -> %s,%d\n" + (Item.to_string i) hi (Item.to_string j) hj + in ItemMap.iter print p + + end diff --git a/src/union_find/Partition2.ml b/src/union_find/Partition2.ml new file mode 100644 index 000000000..e1372b2fd --- /dev/null +++ b/src/union_find/Partition2.ml @@ -0,0 +1,115 @@ +(** Persistent implementation of the Union/Find algorithm with + height-balanced forests and without path compression. *) + +module Make (Item: Partition.Item) = + struct + + type item = Item.t + type repr = item (** Class representatives *) + + let equal i j = Item.compare i j = 0 + + type height = int + + (** Each equivalence class is implemented by a Catalan tree linked + upwardly and otherwise is a link to another node. Those trees + are height-balanced. The type [node] implements nodes in those + trees. *) + type node = + Root of height + (** The value of [Root h] denotes the root of a tree, that is, + the representative of the associated class. The height [h] + is that of the tree, so a tree reduced to its root alone has + heigh 0. *) + + | Link of item * height + (** If not a root, a node is a link to another node. Because the + links are upward, that is, bottom-up, and we seek a purely + functional implementation, we need to uncouple the nodes and + the items here, so the first component of [Link] is an item, + not a node. That is why the type [node] is not recursive, + and called [node], not [tree]: to become a traversable tree, + it needs to be complemented by the type [partition] below to + associate items back to nodes. In order to follow a path + upward in the tree until the root, we start from a link node + giving us the next item, then find the node corresponding to + the item thanks to [partition], and again until we arrive at + the root. + + The height component is that of the source of the link, that + is, [h] is the height of the node linking to the node [Link + (j,h)], _not_ of [j], except when [equal i j]. *) + + module ItemMap = Map.Make (Item) + + (** The type [partition] implements a partition of classes of + equivalent items by means of a map from items to nodes of type + [node] in trees. *) + type partition = node ItemMap.t + + type t = partition + + let empty = ItemMap.empty + + let root (item, height) = ItemMap.add item (Root height) + + let link (src, height) dst = ItemMap.add src (Link (dst, height)) + + let rec seek (i: item) (p: partition) : repr * height = + match ItemMap.find i p with + Root hi -> i,hi + | Link (j,_) -> seek j p + + let repr item partition = fst (seek item partition) + + let is_equiv (i: item) (j: item) (p: partition) = + equal (repr i p) (repr j p) + + let get_or_set (i: item) (p: partition) = + try seek i p, p with + Not_found -> let n = i,0 in (n, root n p) + + let equiv (i: item) (j: item) (p: partition) : partition = + let (ri,hi as ni), p = get_or_set i p in + let (rj,hj as nj), p = get_or_set j p in + if equal ri rj + then p + else if hi > hj + then link nj ri p + else link ni rj (if hi < hj then p else root (rj, hj+1) p) + + (** The call [alias i j p] results in the same partition as [equiv + i j p], except that [i] is not the representative of its class + in [alias i j p] (whilst it may be in [equiv i j p]). + + This property is irrespective of the heights of the + representatives of [i] and [j], that is, of the trees + implementing their classes. If [i] is not a representative of + its class before calling [alias], then the height criteria is + applied (which, without the constraint above, would yield a + height-balanced new tree). *) + let alias (i: item) (j: item) (p: partition) : partition = + let (ri,hi as ni), p = get_or_set i p in + let (rj,hj as nj), p = get_or_set j p in + if equal ri rj + then p + else if hi = hj || equal ri i + then link ni rj @@ root (rj, max hj (hi+1)) p + else if hi < hj then link ni rj p + else link nj ri p + + (** {1 Printing} *) + + let print (p: partition) = + let print i node = + let hi, hj, j = + match node with + Root hi -> hi,hi,i + | Link (j,hi) -> + match ItemMap.find j p with + Root hj | Link (_,hj) -> hi,hj,j in + Printf.printf "%s,%d -> %s,%d\n" + (Item.to_string i) hi (Item.to_string j) hj + in ItemMap.iter print p + + end diff --git a/src/union_find/Partition3.ml b/src/union_find/Partition3.ml new file mode 100644 index 000000000..593292025 --- /dev/null +++ b/src/union_find/Partition3.ml @@ -0,0 +1,86 @@ +(* Destructive implementation of union/find with height-balanced + forests but without path compression: O(n*log(n)). *) + +module Make (Item: Partition.Item) = + struct + + type item = Item.t + type repr = item (** Class representatives *) + + let equal i j = Item.compare i j = 0 + + type height = int + + (** Each equivalence class is implemented by a Catalan tree linked + upwardly and otherwise is a link to another node. Those trees + are height-balanced. The type [node] implements nodes in those + trees. *) + type node = {item: item; mutable height: int; mutable parent: node} + + module ItemMap = Map.Make (Item) + + (** The type [partition] implements a partition of classes of + equivalent items by means of a map from items to nodes of type + [node] in trees. *) + type partition = node ItemMap.t + + type t = partition + + let empty = ItemMap.empty + + (** The function [repr] is faster than a persistent implementation + in the worst case because, in the latter case, the cost is O(log n) + for accessing each node in the path to the root, whereas, in the + former, only the access to the first node in the path incurs a cost + of O(log n) -- the other nodes are accessed in constant time by + following the [next] field of type [node]. *) + let seek (i: item) (p: partition) : node = + let rec find_root node = + if node.parent == node then node else find_root node.parent + in find_root (ItemMap.find i p) + + let repr item partition = (seek item partition).item + + let is_equiv (i: item) (j: item) (p: partition) = + equal (repr i p) (repr j p) + + let get_or_set item (p: partition) = + try seek item p, p with + Not_found -> let rec loop = {item; height=0; parent=loop} + in loop, ItemMap.add item loop p + + let link src dst = src.parent <- dst + + let equiv (i: item) (j: item) (p: partition) : partition = + let ni,p = get_or_set i p in + let nj,p = get_or_set j p in + let hi,hj = ni.height, nj.height in + let () = + if not (equal ni.item nj.item) + then if hi > hj + then link nj ni + else (link ni nj; nj.height <- max hj (hi+1)) + in p + + let alias (i: item) (j: item) (p: partition) : partition = + let ni,p = get_or_set i p in + let nj,p = get_or_set j p in + let hi,hj = ni.height, nj.height in + let () = + if not (equal ni.item nj.item) + then if hi = hj || equal ni.item i + then (link ni nj; nj.height <- max hj (hi+1)) + else if hi < hj then link ni nj + else link nj ni + in p + + (* Printing *) + + let print p = + let print _ node = + Printf.printf "%s,%d -> %s,%d\n" + (Item.to_string node.item) node.height + (Item.to_string node.parent.item) node.parent.height + in ItemMap.iter print p + + end diff --git a/src/union_find/PartitionMain.ml b/src/union_find/PartitionMain.ml new file mode 100644 index 000000000..4e69dbd87 --- /dev/null +++ b/src/union_find/PartitionMain.ml @@ -0,0 +1,40 @@ +module Int = + struct + type t = int + let compare (i: int) (j: int) = Pervasives.compare i j + let to_string = string_of_int + end + +module Test (Part: Partition.S with type item = Int.t) = + struct + open Part + + let () = empty + |> equiv 4 3 + |> equiv 3 8 + |> equiv 6 5 + |> equiv 9 4 + |> equiv 2 1 + |> equiv 8 9 + |> equiv 5 0 + |> equiv 7 2 + |> equiv 6 1 + |> equiv 1 0 + |> equiv 6 7 + |> equiv 8 0 + |> equiv 7 7 + |> equiv 10 10 + |> print + end + + +module Test0 = Test (Partition0.Make(Int)) +let () = print_newline () + +module Test1 = Test (Partition1.Make(Int)) +let () = print_newline () + +module Test2 = Test (Partition2.Make(Int)) +let () = print_newline () + +module Test3 = Test (Partition3.Make(Int)) diff --git a/src/union_find/README.md b/src/union_find/README.md new file mode 100644 index 000000000..16c7b5bf9 --- /dev/null +++ b/src/union_find/README.md @@ -0,0 +1,39 @@ +# Some implementations in OCaml of the Union/Find algorithm + +All modules implementing Union/Find can be coerced by the same +signature `Partition.S`. + +Note the function `alias` which is equivalent to `equiv`, but not +symmetric: `alias x y` means that `x` is an alias of `y`, which +translates in the present context as `x` not being the representative +of the equivalence class containing the equivalence between `x` and +`y`. The function `alias` is useful when managing aliases during the +static analyses of programming languages, so the representatives of +the classes are always the original object. + +The module `PartitionMain` tests each with the same equivalence +relations. + +## `Partition0.ml` + +This is a naive, persistent implementation of Union/Find featuring an +asymptotic worst case cost of O(n^2). + +## `Partition1.ml` + +This is a persistent implementation of Union/Find with height-balanced +forests and without path compression, featuring an asymptotic worst +case cost of O(n*log(n)). + +## `Partition2.ml` + +This is an alternate version of `Partition1.ml`, using a different +data type. + +## `Partition3.ml` + +This is a destructive implementation of Union/Find with +height-balanced forests but without path compression, featuring an +asymptotic worst case of O(n*log(n)). In practice, though, this +implementation should be faster than the previous ones, due to a +smaller multiplicative constant term. diff --git a/src/union_find/build.sh b/src/union_find/build.sh new file mode 100755 index 000000000..8453429fa --- /dev/null +++ b/src/union_find/build.sh @@ -0,0 +1,14 @@ +#!/bin/sh +set -x +ocamlfind ocamlc -strict-sequence -w +A-48-4 -c Partition.mli +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition0.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition2.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition1.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition3.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition1.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition3.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition0.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Partition2.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PartitionMain.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PartitionMain.ml +ocamlfind ocamlopt -o PartitionMain.opt Partition0.cmx Partition1.cmx Partition2.cmx Partition3.cmx PartitionMain.cmx diff --git a/src/union_find/clean.sh b/src/union_find/clean.sh new file mode 100755 index 000000000..75ded7c50 --- /dev/null +++ b/src/union_find/clean.sh @@ -0,0 +1,3 @@ +#!/bin/sh + +\rm -f *.cmi *.cmo *.cmx *.o *.byte *.opt diff --git a/src/union_find/dune b/src/union_find/dune new file mode 100644 index 000000000..a4c27e725 --- /dev/null +++ b/src/union_find/dune @@ -0,0 +1,16 @@ +(library + (name union_find) + (public_name ligo.union_find) + (wrapped false) ;; TODO: do we need this? + (modules Partition0 Partition1 Partition2 Partition3 Partition Union_find) + (modules_without_implementation Partition) +;; (preprocess +;; (pps simple-utils.ppx_let_generalized) +;; ) +;; (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) + ) + +(test + (modules PartitionMain) + (libraries UnionFind) + (name PartitionMain)) diff --git a/src/union_find/union_find.ml b/src/union_find/union_find.ml new file mode 100644 index 000000000..17850f743 --- /dev/null +++ b/src/union_find/union_find.ml @@ -0,0 +1,2 @@ +module Partition = Partition +module Partition0 = Partition0 diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 329203a46..1ae5360dd 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -667,6 +667,7 @@ let bind_map_pair f (a, b) = bind_pair (f a, f b) + (** Wraps a call that might trigger an exception in a result. *) From e4e77da97cf93e002b3af2445c70aeb0bb42f38e Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Sat, 28 Sep 2019 01:56:09 +0200 Subject: [PATCH 02/39] add change for typer.ml --- src/passes/4-typer/typer.ml | 914 +++++++++++++++++++++--------------- 1 file changed, 526 insertions(+), 388 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index efa65ae1b..080d3bacb 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -36,33 +36,33 @@ module Errors = struct let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ = fun matching loc () -> - let title = (thunk "match with no cases") in - let message () = "" in - let data = [ - ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp loc) - ] in - error ~data title message () + let title = (thunk "match with no cases") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ = fun matching loc () -> - let title = (thunk "missing case in match") in - let message () = "" in - let data = [ - ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp loc) - ] in - error ~data title message () + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ = fun matching loc () -> - let title = (thunk "missing case in match") in - let message () = "" in - let data = [ - ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp loc) - ] in - error ~data title message () + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () let unbound_constructor (e:environment) (n:string) (loc:Location.t) () = let title = (thunk "unbound constructor") in @@ -129,14 +129,14 @@ module Errors = struct let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ = fun ?(msg = "") ~expected ~actual loc () -> - let title = (thunk "typing match") in - let message () = msg in - let data = [ - ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); - ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp loc) - ] in - error ~data title message () + let title = (thunk "typing match") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () let needs_annotation (e : I.expression) (case : string) () = let title = (thunk "this expression must be annotated with its type") in @@ -192,7 +192,7 @@ module Errors = struct error ~data title message () let not_supported_yet (message : string) (ae : I.expression) () = - let title = (thunk "not suported yet") in + let title = (thunk "not supported yet") in let message () = message in let data = [ ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; @@ -201,7 +201,7 @@ module Errors = struct error ~data title message () let not_supported_yet_untranspile (message : string) (ae : O.expression) () = - let title = (thunk "not suported yet") in + let title = (thunk "not supported yet") in let message () = message in let data = [ ("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae) @@ -221,6 +221,7 @@ end open Errors +let swap (a,b) = ok (b,a) let rec type_program (p:I.program) : O.program result = let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = let%bind ed' = (bind_map_location (type_declaration e)) d in @@ -235,53 +236,56 @@ let rec type_program (p:I.program) : O.program result = bind_fold_list aux (Environment.full_empty, []) p in ok @@ List.rev lst -and type_declaration env : I.declaration -> (environment * O.declaration option) result = function +(* + Extract pairs of (name,type) in the declaration and add it to the environment +*) +let rec type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function | Declaration_type (type_name , type_expression) -> - let%bind tv = evaluate_type env type_expression in - let env' = Environment.add_type type_name tv env in - ok (env', None) + let%bind tv = evaluate_type env type_expression in + let env' = Environment.add_type type_name tv env in + ok (env', state , None) | Declaration_constant (name , tv_opt , expression) -> ( (* Determine the type of the expression and add it to the environment *) let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in - let%bind ae' = + let%bind (ae' , state') = trace (constant_declaration_error name expression tv'_opt) @@ - type_expression ?tv_opt:tv'_opt env expression in + type_expression env state expression in let env' = Environment.add_ez_ae name ae' env in - ok (env', Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) + ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) ) -and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> I.expression -> Location.t -> o O.matching result = - fun f e t i ae loc -> match i with +and type_match : environment -> Solver.state -> O.type_expression -> 'i I.matching -> I.expression -> Location.t -> (O.value O.matching * Solver.state) result = + fun e state t i ae loc -> match i with | Match_bool {match_true ; match_false} -> let%bind _ = trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_bool t in - let%bind match_true = f e match_true in - let%bind match_false = f e match_false in - ok (O.Match_bool {match_true ; match_false}) - | Match_option {match_none ; match_some} -> + let%bind (match_true , state') = type_expression e state match_true in + let%bind (match_false , state'') = type_expression e state' match_false in + ok (O.Match_bool {match_true ; match_false} , state'') + | Match_option {match_none ; match_some} -> let%bind t_opt = trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_option t in - let%bind match_none = f e match_none in + let%bind (match_none , state') = type_expression e state match_none in let (n, b) = match_some in let n' = n, t_opt in let e' = Environment.add_ez_binder n t_opt e in - let%bind b' = f e' b in - ok (O.Match_option {match_none ; match_some = (n', b')}) - | Match_list {match_nil ; match_cons} -> + let%bind (b' , state'') = type_expression e' state' b in + ok (O.Match_option {match_none ; match_some = (n', b')} , state'') + | Match_list {match_nil ; match_cons} -> let%bind t_list = trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_list t in - let%bind match_nil = f e match_nil in + let%bind (match_nil , state') = type_expression e state match_nil in let (hd, tl, b) = match_cons in let e' = Environment.add_ez_binder hd t_list e in let e' = Environment.add_ez_binder tl t e' in - let%bind b' = f e' b in - ok (O.Match_list {match_nil ; match_cons = (((hd , t_list), (tl , t)), b')}) - | Match_tuple (lst, b) -> + let%bind (b' , state'') = type_expression e' state' b in + ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')} , state'') + | Match_tuple (lst, b) -> let%bind t_tuple = trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_tuple t in @@ -290,9 +294,9 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t @@ (fun () -> List.combine lst t_tuple) in let aux prev (name, tv) = Environment.add_ez_binder name tv prev in let e' = List.fold_left aux e lst' in - let%bind b' = f e' b in - ok (O.Match_tuple (lst, b')) - | Match_variant lst -> + let%bind (b' , state') = type_expression e' state b in + ok (O.Match_tuple (lst, b') , state') + | Match_variant lst -> let%bind variant_opt = let aux acc ((constructor_name , _) , _) = let%bind (_ , variant) = @@ -334,17 +338,17 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t Assert.assert_true List.(length variant_cases = length match_cases) in ok () in - let%bind lst' = - let aux ((constructor_name , name) , b) = + let%bind (state'' , lst') = + let aux state ((constructor_name , name) , b) = let%bind (constructor , _) = trace_option (unbound_constructor e constructor_name loc) @@ Environment.get_constructor constructor_name e in let e' = Environment.add_ez_binder name constructor e in - let%bind b' = f e' b in - ok ((constructor_name , name) , b') + let%bind (b' , state') = type_expression e' state b in + ok (state' , ((constructor_name , name) , b')) in - bind_map_list aux lst in - ok (O.Match_variant (lst' , variant)) + bind_fold_map_list aux state lst in + ok (O.Match_variant (lst' , variant) , state'') (* Recursively search the type_expression and return a result containing the @@ -354,242 +358,261 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = let return tv' = ok (make_t tv' (Some t)) in match t with | T_function (a, b) -> - let%bind a' = evaluate_type e a in - let%bind b' = evaluate_type e b in - return (T_function (a', b')) + let%bind a' = evaluate_type e a in + let%bind b' = evaluate_type e b in + return (T_function (a', b')) | T_tuple lst -> - let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in - return (T_tuple lst') + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + return (T_tuple lst') | T_sum m -> - let aux k v prev = - let%bind prev' = prev in - let%bind v' = evaluate_type e v in - ok @@ SMap.add k v' prev' - in - let%bind m = SMap.fold aux m (ok SMap.empty) in - return (T_sum m) + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + return (T_sum m) | T_record m -> - let aux k v prev = - let%bind prev' = prev in - let%bind v' = evaluate_type e v in - ok @@ SMap.add k v' prev' - in - let%bind m = SMap.fold aux m (ok SMap.empty) in - return (T_record m) + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + return (T_record m) | T_variable name -> - let%bind tv = - trace_option (unbound_type_variable e name) - @@ Environment.get_type_opt name e in - ok tv + let%bind tv = + trace_option (unbound_type_variable e name) + @@ Environment.get_type_opt name e in + ok tv | T_constant (cst, lst) -> - let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in - return (T_constant(cst, lst')) + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + return (T_constant(cst, lst')) -and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result = fun e ?tv_opt ae -> +and type_expression : environment -> Solver.state -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ae -> + let open Solver in let module L = Logger.Stateful() in - let return expr tv = - let%bind () = - match tv_opt with - | None -> ok () - | Some tv' -> O.assert_type_value_eq (tv' , tv) in + let return : _ -> Solver.state -> _ -> _ (* return of type_expression *) = fun expr state constraints type_name -> + let%bind new_state = aggregate_constraints state constraints in + let tv = t_variable type_name () in let location = ae.location in - ok @@ make_a_e ~location expr tv e in + let expr' = make_a_e ~location expr tv e in + ok @@ (expr' , new_state) in + let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in let main_error = let title () = "typing expression" in let content () = "" in let data = [ ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp @@ ae.location) ; ("misc" , fun () -> L.get ()) ; ] in error ~data title content in trace main_error @@ - match ae.expression with + match ae.expression' with + + (* TODO: this file should take care only of the order in which program fragments + are translated by Wrap.xyz + + TODO: produce an ordered list of sub-fragments, and use a common piece of code + to actually perform the recursive calls *) + (* Basic *) + | E_failwith expr -> ( + let%bind (expr', state') = type_expression e state expr in + let (constraints , expr_type) = Wrap.failwith () in + let expr'' = e_failwith expr' in + return expr'' state' constraints expr_type + ) | E_variable name -> - let%bind tv' = - trace_option (unbound_variable e name ae.location) - @@ Environment.get_opt name e in - return (E_variable name) tv'.type_value + let%bind tv' = + trace_option (unbound_variable e name ae.location) + @@ Environment.get_opt name e in + let (constraints , expr_type) = Wrap.variable name tv'.type_expression in + let expr' = e_variable name in + return (E_variable name) tv'.type_value | E_literal (Literal_bool b) -> - return (E_literal (Literal_bool b)) (t_bool ()) + return (E_literal (Literal_bool b)) (t_bool ()) | E_literal Literal_unit | E_skip -> - return (E_literal (Literal_unit)) (t_unit ()) + return (E_literal (Literal_unit)) (t_unit ()) | E_literal (Literal_string s) -> - return (E_literal (Literal_string s)) (t_string ()) + return (E_literal (Literal_string s)) (t_string ()) | E_literal (Literal_bytes s) -> - return (E_literal (Literal_bytes s)) (t_bytes ()) + return (E_literal (Literal_bytes s)) (t_bytes ()) | E_literal (Literal_int n) -> - return (E_literal (Literal_int n)) (t_int ()) + return (E_literal (Literal_int n)) (t_int ()) | E_literal (Literal_nat n) -> - return (E_literal (Literal_nat n)) (t_nat ()) + return (E_literal (Literal_nat n)) (t_nat ()) | E_literal (Literal_timestamp n) -> - return (E_literal (Literal_timestamp n)) (t_timestamp ()) + return (E_literal (Literal_timestamp n)) (t_timestamp ()) | E_literal (Literal_mutez n) -> - return (E_literal (Literal_mutez n)) (t_tez ()) + return (E_literal (Literal_mutez n)) (t_tez ()) | E_literal (Literal_address s) -> - return (e_address s) (t_address ()) + return (e_address s) (t_address ()) | E_literal (Literal_operation op) -> - return (e_operation op) (t_operation ()) + return (e_operation op) (t_operation ()) (* Tuple *) | E_tuple lst -> - let%bind lst' = bind_list @@ List.map (type_expression e) lst in - let tv_lst = List.map get_type_annotation lst' in - return (E_tuple lst') (t_tuple tv_lst ()) + let aux state hd = type_expression e state hd >>? swap in + let%bind (state', lst') = bind_fold_map_list aux state lst in + let tv_lst = List.map get_type_annotation lst' in + return (E_tuple lst') (t_tuple tv_lst ()) | E_accessor (ae', path) -> - let%bind e' = type_expression e ae' in - let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = - match a with - | Access_tuple index -> ( - let%bind tpl_tv = get_t_tuple prev.type_annotation in - let%bind tv = - generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) - @@ (fun () -> List.nth tpl_tv index) in - return (E_tuple_accessor (prev , index)) tv - ) - | Access_record property -> ( - let%bind r_tv = get_t_record prev.type_annotation in - let%bind tv = - generic_try (bad_record_access property ae' prev.type_annotation ae.location) - @@ (fun () -> SMap.find property r_tv) in - return (E_record_accessor (prev , property)) tv - ) - | Access_map ae' -> ( - let%bind ae'' = type_expression e ae' in - let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in - let%bind () = - Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in - return (E_look_up (prev , ae'')) v - ) - in - trace (simple_info "accessing") @@ - bind_fold_list aux e' path + let%bind e' = type_expression e ae' in + let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = + match a with + | Access_tuple index -> ( + let%bind tpl_tv = get_t_tuple prev.type_annotation in + let%bind tv = + generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) + @@ (fun () -> List.nth tpl_tv index) in + return (E_tuple_accessor (prev , index)) tv + ) + | Access_record property -> ( + let%bind r_tv = get_t_record prev.type_annotation in + let%bind tv = + generic_try (bad_record_access property ae' prev.type_annotation ae.location) + @@ (fun () -> SMap.find property r_tv) in + return (E_record_accessor (prev , property)) tv + ) + | Access_map ae' -> ( + let%bind ae'' = type_expression e ae' in + let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in + let%bind () = + Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in + return (E_look_up (prev , ae'')) v + ) + in + trace (simple_info "accessing") @@ + bind_fold_list aux e' path (* Sum *) | E_constructor (c, expr) -> - let%bind (c_tv, sum_tv) = - let error = - let title () = "no such constructor" in - let content () = - Format.asprintf "%s in:\n%a\n" - c O.Environment.PP.full_environment e - in - error title content in - trace_option error @@ - Environment.get_constructor c e in - let%bind expr' = type_expression e expr in - let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in - return (E_constructor (c , expr')) sum_tv + let%bind (c_tv, sum_tv) = + let error = + let title () = "no such constructor" in + let content () = + Format.asprintf "%s in:\n%a\n" + c O.Environment.PP.full_environment e + in + error title content in + trace_option error @@ + Environment.get_constructor c e in + let%bind (expr' , state') = type_expression e state expr in + let%bind _assert = O.assert_type_expression_eq (expr'.type_annotation, c_tv) in + let wrapped = Wrap.constructor expr'.type_annotation c_tv sum_tv in + return_wrapped (E_constructor (c , expr')) state' wrapped (* Record *) | E_record m -> - let aux prev k expr = - let%bind expr' = type_expression e expr in - ok (SMap.add k expr' prev) - in - let%bind m' = bind_fold_smap aux (ok SMap.empty) m in - return (E_record m') (t_record (SMap.map get_type_annotation m') ()) + let aux (acc, state) k expr = + let%bind (expr' , state') = type_expression e state expr in + ok (SMap.add k expr' acc , state') + in + let%bind (m' , state') = bind_fold_smap aux (ok (SMap.empty , state)) m in + let wrapped = Wrap.record (SMap.map get_type_annotation m') in + return_wrapped (E_record m') state' wrapped (* Data-structure *) | E_list lst -> - let%bind lst' = bind_map_list (type_expression e) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind init = match tv_opt with - | None -> ok None - | Some ty -> - let%bind ty' = get_t_list ty in - ok (Some ty') in - let%bind ty = - let%bind opt = bind_fold_list aux init + let%bind lst' = bind_map_list (type_expression e) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind init = match tv_opt with + | None -> ok None + | Some ty -> + let%bind ty' = get_t_list ty in + ok (Some ty') in + let%bind ty = + let%bind opt = bind_fold_list aux init @@ List.map get_type_annotation lst' in - trace_option (needs_annotation ae "empty list") opt in - ok (t_list ty ()) - in - return (E_list lst') tv + trace_option (needs_annotation ae "empty list") opt in + ok (t_list ty ()) + in + return (E_list lst') tv | E_set lst -> - let%bind lst' = bind_map_list (type_expression e) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind init = match tv_opt with - | None -> ok None - | Some ty -> - let%bind ty' = get_t_set ty in - ok (Some ty') in - let%bind ty = - let%bind opt = bind_fold_list aux init + let%bind lst' = bind_map_list (type_expression e) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind init = match tv_opt with + | None -> ok None + | Some ty -> + let%bind ty' = get_t_set ty in + ok (Some ty') in + let%bind ty = + let%bind opt = bind_fold_list aux init @@ List.map get_type_annotation lst' in - trace_option (needs_annotation ae "empty set") opt in - ok (t_set ty ()) - in - return (E_set lst') tv + trace_option (needs_annotation ae "empty set") opt in + ok (t_set ty ()) + in + return (E_set lst') tv | E_map lst -> - let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind key_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_map_key tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - let%bind value_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_map_value tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - ok (t_map key_type value_type ()) + let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") in - return (E_map lst') tv + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_map key_type value_type ()) + in + return (E_map lst') tv | E_big_map lst -> - let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind key_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_big_map_key tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - let%bind value_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_big_map_value tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - ok (t_big_map key_type value_type ()) + let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_big_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") in - return (E_big_map lst') tv + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_big_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_big_map key_type value_type ()) + in + return (E_big_map lst') tv | E_lambda { binder ; input_type ; @@ -626,31 +649,21 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) ) | E_constant (name, lst) -> - let%bind lst' = bind_list @@ List.map (type_expression e) lst in - let tv_lst = List.map get_type_annotation lst' in - let%bind (name', tv) = - type_constant name tv_lst tv_opt ae.location in - return (E_constant (name' , lst')) tv + let%bind lst' = bind_list @@ List.map (type_expression e) lst in + let tv_lst = List.map get_type_annotation lst' in + let%bind (name', tv) = + type_constant name tv_lst tv_opt ae.location in + return (E_constant (name' , lst')) tv | E_application (f, arg) -> - let%bind f' = type_expression e f in - let%bind arg = type_expression e arg in - let%bind tv = match f'.type_annotation.type_value' with - | T_function (param, result) -> - let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in - ok result - | _ -> - fail @@ type_error_approximate - ~expected:"should be a function type" - ~expression:f - ~actual:f'.type_annotation - f'.location - in - return (E_application (f' , arg)) tv + let%bind (f' , state') = type_expression e state f in + let%bind (arg , state'') = type_expression e state' arg in + let wrapped = Wrap.application f'.type_annotation arg.type_annotation in + return_wrapped (E_application (f' , arg)) state'' wrapped | E_look_up dsi -> - let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in - let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in - return (E_look_up (ds , ind)) (t_option dst ()) + let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in + let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in + return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) | E_matching (ex, m) -> ( let%bind ex' = type_expression e ex in @@ -677,40 +690,24 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (O.E_matching (ex', m')) tv ) | E_sequence (a , b) -> - let%bind a' = type_expression e a in - let%bind b' = type_expression e b in - let a'_type_annot = get_type_annotation a' in - let%bind () = - trace_strong (type_error - ~msg:"first part of the sequence should be of unit type" - ~expected:(O.t_unit ()) - ~actual:a'_type_annot - ~expression:a - a'.location) @@ - Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in - return (O.E_sequence (a' , b')) (get_type_annotation b') + let%bind (a' , state') = type_expression e state a in + let%bind (b' , state'') = type_expression e state' b in + let wrapped = Wrap.sequence a'.type_annotation b'.type_annotation in + return_wrapped (O.E_sequence (a' , b')) state'' wrapped | E_loop (expr , body) -> - let%bind expr' = type_expression e expr in - let%bind body' = type_expression e body in - let t_expr' = get_type_annotation expr' in - let%bind () = - trace_strong (type_error - ~msg:"while condition isn't of type bool" - ~expected:(O.t_bool ()) - ~actual:t_expr' - ~expression:expr - expr'.location) @@ - Ast_typed.assert_type_value_eq (t_bool () , t_expr') in - let t_body' = get_type_annotation body' in - let%bind () = - trace_strong (type_error - ~msg:"while body isn't of unit type" - ~expected:(O.t_unit ()) - ~actual:t_body' - ~expression:body - body'.location) @@ - Ast_typed.assert_type_value_eq (t_unit () , t_body') in - return (O.E_loop (expr' , body')) (t_unit ()) + let%bind (expr' , state') = type_expression e state expr in + let%bind (body' , state'') = type_expression e state' body in + let wrapped = Wrap.loop expr'.type_annotation body'.type_annotation in + return_wrapped (O.E_loop (expr' , body')) state'' wrapped + | E_let_in {binder ; rhs ; result} -> + let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in + (* TODO: the binder annotation should just be an annotation node *) + let%bind (rhs , state') = type_expression e state rhs in + let e' = Environment.add_ez_declaration (fst binder) rhs e in + let%bind (result , state'') = type_expression e' state' result in + let wrapped = + Wrap.let_in rhs.type_annotation rhs_tv_opt result.type_annotation in + return_wrapped (E_let_in {binder = fst binder; rhs; result}) state'' wrapped | E_assign (name , path , expr) -> let%bind typed_name = let%bind ele = Environment.get_trace name e in @@ -735,34 +732,103 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a | Access_map _ -> fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae in - bind_fold_list aux (typed_name.type_value , []) path in - let%bind expr' = type_expression e expr in - let t_expr' = get_type_annotation expr' in - let%bind () = - trace_strong (type_error - ~msg:"type of the expression to assign doesn't match left-hand-side" - ~expected:assign_tv - ~actual:t_expr' - ~expression:expr - expr'.location) @@ - Ast_typed.assert_type_value_eq (assign_tv , t_expr') in - return (O.E_assign (typed_name , path' , expr')) (t_unit ()) - | E_let_in {binder ; rhs ; result} -> - let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in - let%bind rhs = type_expression ?tv_opt:rhs_tv_opt e rhs in - let e' = Environment.add_ez_declaration (fst binder) rhs e in - let%bind result = type_expression e' result in - return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation + bind_fold_list aux (typed_name.type_expression , []) path in + let%bind (expr' , state') = type_expression e state expr in + let wrapped = Wrap.assign assign_tv expr'.type_annotation in + return_wrapped (O.E_assign (typed_name , path' , expr')) state' wrapped | E_annotation (expr , te) -> let%bind tv = evaluate_type e te in - let%bind expr' = type_expression ~tv_opt:tv e expr in - let%bind type_annotation = - O.merge_annotation - (Some tv) - (Some expr'.type_annotation) - (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in - ok {expr' with type_annotation} + let%bind (expr' , state') = type_expression e state expr in + let wrapped = Wrap.annotation expr'.type_annotation tv + (* TODO: we're probably discarding too much by using expr'.expression. + Previously: {expr' with type_annotation = the_explicit_type_annotation} + but then this case is not like the others and doesn't call return_wrapped, + which might do some necessary work *) + in return_wrapped expr'.expression state' wrapped + | E_matching (ex, m) -> ( + let%bind (ex' , state') = type_expression e state ex in + let%bind (m' , state'') = type_match e state' ex'.type_annotation m ae ae.location in + let tvs = + let aux (cur:O.value O.matching) = + match cur with + | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] + | Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ] + | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] + | Match_tuple (_ , match_tuple) -> [ match_tuple ] + | Match_variant (lst , _) -> List.map snd lst in + List.map get_type_annotation @@ aux m' in + let%bind () = match tvs with + [] -> fail @@ match_empty_variant m ae.location + | _ -> ok () in + (* constraints: + all the items of tvs should be equal to the first one + result = first item of tvs + *) + let wrapped = Wrap.matching tvs in + return_wrapped (O.E_matching (ex', m')) state'' wrapped + ) + + (* match m with *) + (* Special case for assert-like failwiths. TODO: CLEAN THIS. *) + (* | I.Match_bool { match_false ; match_true } when I.is_e_failwith match_true -> ( *) + (* let%bind fw = I.get_e_failwith match_true in *) + (* let%bind fw' = type_expression e fw in *) + (* let%bind mf' = type_expression e match_false in *) + (* let t = get_type_annotation ex' in *) + (* let%bind () = *) + (* trace_strong (match_error ~expected:m ~actual:t ae.location) *) + (* @@ assert_t_bool t in *) + (* let%bind () = *) + (* trace_strong (match_error *) + (* ~msg:"matching not-unit on an assert" *) + (* ~expected:m *) + (* ~actual:t *) + (* ae.location) *) + (* @@ assert_t_unit (get_type_annotation mf') in *) + (* let mt' = make_a_e *) + (* (E_constant ("ASSERT_INFERRED" , [ex' ; fw'])) *) + (* (t_unit ()) *) + (* e *) + (* in *) + (* let m' = O.Match_bool { match_true = mt' ; match_false = mf' } in *) + (* return (O.E_matching (ex' , m')) (t_unit ()) *) + (* ) *) + (* | _ -> ( … ) *) + + + | E_lambda { + binder ; + input_type ; + output_type ; + result ; + } -> ( + let%bind input_type' = bind_map_option (evaluate_type e) input_type in + let%bind output_type' = bind_map_option (evaluate_type e) output_type in + + let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in + let e' = Environment.add_ez_binder (fst binder) fresh e in + + let%bind (result , state') = type_expression e' state result in + let output_type = result.type_annotation in + let wrapped = Wrap.lambda fresh input_type' output_type' in + return_wrapped + (E_lambda {binder = fst binder;input_type=fresh;output_type;result}) + state' wrapped + ) + + | E_constant (name, lst) -> + let () = ignore (name , lst) in + Pervasives.failwith "TODO: E_constant" + (* + let%bind lst' = bind_list @@ List.map (type_expression e) lst in + let tv_lst = List.map get_type_annotation lst' in + let%bind (name', tv) = + type_constant name tv_lst tv_opt ae.location in + return (E_constant (name' , lst')) tv + *) + +(* Advanced *) and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result = (* Constant poorman's polymorphism *) @@ -777,7 +843,76 @@ let untype_type_value (t:O.type_value) : (I.type_expression) result = match t.simplified with | Some s -> ok s | _ -> fail @@ internal_assertion_failure "trying to untype generated type" +(* let type_statement : environment -> I.declaration -> Solver.state -> (environment * O.declaration * Solver.state) result = fun env declaration state -> *) +(* match declaration with *) +(* | I.Declaration_type td -> ( *) +(* let%bind (env', state', declaration') = type_declaration env state td in *) +(* let%bind toto = Solver.aggregate_constraints state' constraints in *) +(* let declaration' = match declaration' with None -> Pervasives.failwith "TODO" | Some x -> x in *) +(* ok (env' , declaration' , toto) *) +(* ) *) +(* | I.Declaration_constant ((_ , _ , expr) as cd) -> ( *) +(* let%bind state' = type_expression expr in *) +(* let constraints = constant_declaration cd in *) +(* Solver.aggregate_constraints state' constraints *) +(* ) *) +(* TODO: we ended up with two versions of type_program… ??? *) + +(* +Apply type_declaration on all the node of the AST_simplified from the root p +*) +let type_program (p:I.program) : (environment * Solver.state * O.program) result = + let env = Ast_typed.Environment.full_empty in + let state = Solver.initial_state in + let aux ((e : environment), (s : Solver.state) , (ds : O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = + let%bind (e' , s' , d'_opt) = type_declaration e s (Location.unwrap d) in + let ds' = match d'_opt with + | None -> ds + | Some d' -> ds @ [Location.wrap ~loc:(Location.get_location d) d'] (* take O(n) insted of O(1) *) + in + ok (e' , s' , ds') + in + let%bind (env' , state' , declarations) = + trace (fun () -> program_error p ()) @@ + bind_fold_list aux (env , state , []) p in + let () = ignore (env' , state') in + ok (env', state', declarations) + + (* + Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity + *) +let type_program' : I.program -> O.program result = fun p -> + let initial_state = Solver.initial_state in + let initial_env = Environment.full_empty in + let aux (env, state) (statement : I.declaration Location.wrap) = + let statement' = statement.wrap_content in (* TODO *) + let%bind (env' , state' , declaration') = type_declaration env state statement' in + let declaration'' = match declaration' with + None -> None + | Some x -> Some (Location.wrap ~loc:Location.(statement.location) x) in + ok ((env' , state') , declaration'') + in + let%bind ((env' , state') , p') = bind_fold_map_list aux (initial_env, initial_state) p in + let p' = List.fold_left (fun l e -> match e with None -> l | Some x -> x :: l) [] p' in + + (* here, maybe ensure that there are no invalid things in env' and state' ? *) + let () = ignore (env' , state') in + ok p' + +(* + Tranform a Ast_typed type_expression into an ast_simplified type_expression +*) +let untype_type_expression (t:O.type_expression) : (I.type_expression) result = + ok t +(* match t.simplified with *) +(* | Some s -> ok s *) +(* | _ -> fail @@ internal_assertion_failure "trying to untype generated type" *) + + +(* + Tranform a Ast_typed literal into an ast_simplified literal +*) let untype_literal (l:O.literal) : I.literal result = let open I in match l with @@ -800,17 +935,17 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let return e = ok e in match e.expression with | E_literal l -> - let%bind l = untype_literal l in - return (e_literal l) + let%bind l = untype_literal l in + return (e_literal l) | E_constant (n, lst) -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_constant n lst') + let%bind lst' = bind_map_list untype_expression lst in + return (e_constant n lst') | E_variable n -> - return (e_variable n) + return (e_variable n) | E_application (f, arg) -> - let%bind f' = untype_expression f in - let%bind arg' = untype_expression arg in - return (e_application f' arg') + let%bind f' = untype_expression f in + let%bind arg' = untype_expression arg in + return (e_application f' arg') | E_lambda {binder ; body} -> ( let%bind io = get_t_function e.type_annotation in let%bind (input_type , output_type) = bind_map_pair untype_type_value io in @@ -818,49 +953,52 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = return (e_lambda binder (Some input_type) (Some output_type) result) ) | E_tuple lst -> - let%bind lst' = bind_list - @@ List.map untype_expression lst in - return (e_tuple lst') + let%bind lst' = bind_list + @@ List.map untype_expression lst in + return (e_tuple lst') | E_tuple_accessor (tpl, ind) -> - let%bind tpl' = untype_expression tpl in - return (e_accessor tpl' [Access_tuple ind]) + let%bind tpl' = untype_expression tpl in + return (e_accessor tpl' [Access_tuple ind]) | E_constructor (n, p) -> - let%bind p' = untype_expression p in - return (e_constructor n p') + let%bind p' = untype_expression p in + return (e_constructor n p') | E_record r -> - let%bind r' = bind_smap - @@ SMap.map untype_expression r in - return (e_record r') + let%bind r' = bind_smap + @@ SMap.map untype_expression r in + return (e_record r') | E_record_accessor (r, s) -> - let%bind r' = untype_expression r in - return (e_accessor r' [Access_record s]) + let%bind r' = untype_expression r in + return (e_accessor r' [Access_record s]) | E_map m -> - let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (e_map m') + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_map m') | E_big_map m -> - let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (e_big_map m') + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_big_map m') | E_list lst -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_list lst') + let%bind lst' = bind_map_list untype_expression lst in + return (e_list lst') | E_set lst -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_set lst') + let%bind lst' = bind_map_list untype_expression lst in + return (e_set lst') | E_look_up dsi -> - let%bind (a , b) = bind_map_pair untype_expression dsi in - return (e_look_up a b) + let%bind (a , b) = bind_map_pair untype_expression dsi in + return (e_look_up a b) | E_matching (ae, m) -> - let%bind ae' = untype_expression ae in - let%bind m' = untype_matching untype_expression m in - return (e_matching ae' m') + let%bind ae' = untype_expression ae in + let%bind m' = untype_matching untype_expression m in + return (e_matching ae' m') + | E_failwith ae -> + let%bind ae' = untype_expression ae in + return (e_failwith ae') | E_sequence _ | E_loop _ | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression | E_let_in {binder;rhs;result} -> - let%bind tv = untype_type_value rhs.type_annotation in - let%bind rhs = untype_expression rhs in - let%bind result = untype_expression result in - return (e_let_in (binder , (Some tv)) rhs result) + let%bind tv = untype_type_value rhs.type_annotation in + let%bind rhs = untype_expression rhs in + let%bind result = untype_expression result in + return (e_let_in (binder , (Some tv)) rhs result) (* Tranform a Ast_typed matching into an ast_simplified matching @@ -869,25 +1007,25 @@ and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matchin let open I in match m with | Match_bool {match_true ; match_false} -> - let%bind match_true = f match_true in - let%bind match_false = f match_false in - ok @@ Match_bool {match_true ; match_false} + let%bind match_true = f match_true in + let%bind match_false = f match_false in + ok @@ Match_bool {match_true ; match_false} | Match_tuple (lst, b) -> - let%bind b = f b in - ok @@ Match_tuple (lst, b) + let%bind b = f b in + ok @@ Match_tuple (lst, b) | Match_option {match_none ; match_some = (v, some)} -> - let%bind match_none = f match_none in - let%bind some = f some in - let match_some = fst v, some in - ok @@ Match_option {match_none ; match_some} + let%bind match_none = f match_none in + let%bind some = f some in + let match_some = fst v, some in + ok @@ Match_option {match_none ; match_some} | Match_list {match_nil ; match_cons = (((hd_name , _) , (tl_name , _)), cons)} -> - let%bind match_nil = f match_nil in - let%bind cons = f cons in - let match_cons = hd_name , tl_name , cons in - ok @@ Match_list {match_nil ; match_cons} + let%bind match_nil = f match_nil in + let%bind cons = f cons in + let match_cons = hd_name , tl_name , cons in + ok @@ Match_list {match_nil ; match_cons} | Match_variant (lst , _) -> - let aux ((a,b),c) = - let%bind c' = f c in - ok ((a,b),c') in - let%bind lst' = bind_map_list aux lst in - ok @@ Match_variant lst' + let aux ((a,b),c) = + let%bind c' = f c in + ok ((a,b),c') in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant lst' From 271a524920c5549f400c5e274b7d71f61c6c74b4 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Mon, 23 Sep 2019 11:03:46 +0200 Subject: [PATCH 03/39] WIP; commenting --- src/passes/4-typer/typer.ml | 74 +++++++++++++++++++++++-------------- 1 file changed, 47 insertions(+), 27 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 080d3bacb..2ef40e5ec 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -424,33 +424,53 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let expr'' = e_failwith expr' in return expr'' state' constraints expr_type ) - | E_variable name -> - let%bind tv' = - trace_option (unbound_variable e name ae.location) - @@ Environment.get_opt name e in - let (constraints , expr_type) = Wrap.variable name tv'.type_expression in - let expr' = e_variable name in - return (E_variable name) tv'.type_value - | E_literal (Literal_bool b) -> - return (E_literal (Literal_bool b)) (t_bool ()) - | E_literal Literal_unit | E_skip -> - return (E_literal (Literal_unit)) (t_unit ()) - | E_literal (Literal_string s) -> - return (E_literal (Literal_string s)) (t_string ()) - | E_literal (Literal_bytes s) -> - return (E_literal (Literal_bytes s)) (t_bytes ()) - | E_literal (Literal_int n) -> - return (E_literal (Literal_int n)) (t_int ()) - | E_literal (Literal_nat n) -> - return (E_literal (Literal_nat n)) (t_nat ()) - | E_literal (Literal_timestamp n) -> - return (E_literal (Literal_timestamp n)) (t_timestamp ()) - | E_literal (Literal_mutez n) -> - return (E_literal (Literal_mutez n)) (t_tez ()) - | E_literal (Literal_address s) -> - return (e_address s) (t_address ()) - | E_literal (Literal_operation op) -> - return (e_operation op) (t_operation ()) + | E_variable name -> ( + let%bind tv' = + trace_option (unbound_variable e name ae.location) + @@ Environment.get_opt name e in + let (constraints , expr_type) = Wrap.variable name tv'.type_expression in + let expr' = e_variable name in + return expr' state constraints expr_type + ) + | E_literal (Literal_bool b) -> ( + return_wrapped (e_bool b) state @@ Wrap.literal (t_bool ()) + ) + | E_literal (Literal_string s) -> ( + return_wrapped (e_string s) state @@ Wrap.literal (t_string ()) + ) + | E_literal (Literal_bytes b) -> ( + return_wrapped (e_bytes b) state @@ Wrap.literal (t_bytes ()) + ) + | E_literal (Literal_int i) -> ( + return_wrapped (e_int i) state @@ Wrap.literal (t_int ()) + ) + | E_literal (Literal_nat n) -> ( + return_wrapped (e_nat n) state @@ Wrap.literal (t_nat ()) + ) + | E_literal (Literal_tez t) -> ( + return_wrapped (e_tez t) state @@ Wrap.literal (t_tez ()) + ) + | E_literal (Literal_address a) -> ( + return_wrapped (e_address a) state @@ Wrap.literal (t_address ()) + ) + | E_literal (Literal_timestamp t) -> ( + return_wrapped (e_timestamp t) state @@ Wrap.literal (t_timestamp ()) + ) + | E_literal (Literal_operation o) -> ( + return_wrapped (e_operation o) state @@ Wrap.literal (t_operation ()) + ) + | E_literal (Literal_unit) -> ( + return_wrapped (e_unit) state @@ Wrap.literal (t_unit ()) + ) + | E_skip -> ( + failwith "TODO: missing implementation for E_skip" + ) + (* | E_literal (Literal_string s) -> ( + * L.log (Format.asprintf "literal_string option type: %a" PP_helpers.(option O.PP.type_expression) tv_opt) ; + * match Option.map Ast_typed.get_type' tv_opt with + * | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) + * | _ -> return (E_literal (Literal_string s)) (t_string ()) + * ) *) (* Tuple *) | E_tuple lst -> let aux state hd = type_expression e state hd >>? swap in From fc80c627fd1f1a7f2e9fa3b63f8a223535cd1648 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 28 Sep 2019 19:59:56 +0100 Subject: [PATCH 04/39] WIP : instantiation of foralls in some cases --- src/passes/4-typer/solver.ml | 227 ++++++++++++++++++++++++++--------- src/passes/4-typer/typer.ml | 2 +- src/typesystem/core.ml | 9 +- src/typesystem/shorthands.ml | 4 +- 4 files changed, 181 insertions(+), 61 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 890d067e3..55b9cc60a 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -368,8 +368,9 @@ type structured_dbs = { } and constraints = { - constructor : c_constructor_simpl list ; - tc : c_typeclass_simpl list ; + constructor : c_constructor_simpl list ; (* List of ('a = constructor(args…)) constraints *) + poly : c_poly_simpl list ; (* List of ('a = forall 'b, some_type) constraints *) + tc : c_typeclass_simpl list ; (* List of (typeclass(args…)) constraints *) } and c_constructor_simpl = { @@ -384,9 +385,14 @@ and c_typeclass_simpl = { tc : typeclass ; args : type_variable list ; } +and c_poly_simpl = { + tv : type_variable ; + forall : p_forall ; +} and type_constraint_simpl = SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) | SC_Alias of (type_variable * type_variable) (* α = β *) + | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type, TODO: maybe type_value is too much and we want sth simpler? *) | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) module UnionFindWrapper = struct @@ -399,6 +405,7 @@ module UnionFindWrapper = struct Some l -> l | None -> { constructor = [] ; + poly = [] ; tc = [] ; } let add_constraints_related_to : type_variable -> constraints -> structured_dbs -> structured_dbs = @@ -411,7 +418,8 @@ module UnionFindWrapper = struct None -> Some c | Some x -> Some { constructor = c.constructor @ x.constructor ; - tc = c.tc @ x.tc ; + poly = c.poly @ x.poly ; + tc = c.tc @ x.tc ; }) dbs.grouped_by_variable in @@ -426,12 +434,13 @@ module UnionFindWrapper = struct let default d = function None -> d | Some y -> y in let get_constraints ab = TypeVariableMap.find_opt ab dbs.grouped_by_variable - |> default { constructor = [] ; tc = [] } in + |> default { constructor = [] ; poly = [] ; tc = [] } in let constraints_a = get_constraints variable_repr_a in let constraints_b = get_constraints variable_repr_b in let all_constraints = { (* TODO: should be a Set.union, not @ *) constructor = constraints_a.constructor @ constraints_b.constructor ; + poly = constraints_a.poly @ constraints_b.poly ; tc = constraints_a.tc @ constraints_b.tc ; } in let grouped_by_variable = @@ -456,18 +465,19 @@ let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_simpl) normalizer = fun dbs new_constraint -> - let store_constraint tvars constraints = - let aux dbs (tvar : type_variable) = - UnionFindWrapper.add_constraints_related_to tvar constraints dbs - in List.fold_left aux dbs tvars - in - let merge_constraints a b = - UnionFindWrapper.merge_variables a b dbs in - let dbs = match new_constraint with - SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; tc = []} - | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; tc = [c]} - | SC_Alias (a , b) -> merge_constraints a b - in (dbs , [new_constraint]) + let store_constraint tvars constraints = + let aux dbs (tvar : type_variable) = + UnionFindWrapper.add_constraints_related_to tvar constraints dbs + in List.fold_left aux dbs tvars + in + let merge_constraints a b = + UnionFindWrapper.merge_variables a b dbs in + let dbs = match new_constraint with + SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; poly = [] ; tc = []} + | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; poly = [] ; tc = [c]} + | SC_Poly ({tv; forall = _} as c) -> store_constraint [tv] {constructor = [] ; poly = [c] ; tc = []} + | SC_Alias (a , b) -> merge_constraints a b + in (dbs , [new_constraint]) (* Stores the first assinment ('a = ctor('b, …)) seen *) let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer = @@ -480,34 +490,90 @@ let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) nor | _ -> (dbs , [new_constraint]) +let type_level_eval : type_value -> type_value * type_constraint list = failwith "implemented in other branch" + +let check_applied ((reduced, _new_constraints) as x) = + let () = match reduced with + P_apply _ -> failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." (* TODO: report real error *) *) + | _ -> () + in x + + let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer = fun dbs new_constraint -> - match new_constraint with - | C_equation (P_forall _, P_forall _) -> failwith "TODO" - | C_equation ((P_forall _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) - | C_equation (P_forall _, P_constant _) -> failwith "TODO" - | C_equation (P_variable _, P_forall _) -> failwith "TODO" - | C_equation (P_variable a, P_variable b) -> (dbs , [SC_Alias (a, b)]) - | C_equation (P_variable a, P_constant (c_tag, args)) -> - let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in - let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in - let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in - (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars}] @ List.flatten recur) - | C_equation (P_constant _, P_forall _) -> failwith "TODO" - | C_equation ((P_constant _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) - | C_equation ((P_constant _ as a), (P_constant _ as b)) -> - (* break down c(args) = c'(args') into 'a = c(args) and 'a = c'(args') *) - let fresh = Core.fresh_type_variable () in - let (dbs , cs1) = normalizer_simpl dbs (C_equation (P_variable fresh, a)) in - let (dbs , cs2) = normalizer_simpl dbs (C_equation (P_variable fresh, b)) in - (dbs , cs1 @ cs2) (* TODO: O(n) concatenation! *) - | C_typeclass (args, tc) -> - (* break down TC(args) into TC('a, …) and ('a = arg) … *) - let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in - let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in - let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in - (dbs, [SC_Typeclass { tc ; args = fresh_vars }] @ List.flatten recur) - | C_access_label (tv, label, result) -> let _todo = ignore (tv, label, result) in failwith "TODO" + match new_constraint with + (* TODO: merge the cases that just insert a fresh variable *) + | C_equation ((P_forall _ as a), (P_forall _ as b)) + (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *) + | C_equation ((P_forall _ as a), (P_constant _ as b)) + (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *) + | C_equation ((P_constant _ as a), (P_constant _ as b)) + (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *) + | C_equation ((P_constant _ as a), (P_forall _ as b)) + -> + (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *) + let fresh = Core.fresh_type_variable () in + let (dbs , cs1) = normalizer_simpl dbs (C_equation (P_variable fresh, a)) in + let (dbs , cs2) = normalizer_simpl dbs (C_equation (P_variable fresh, b)) in + (dbs , cs1 @ cs2) (* TODO: O(n) concatenation! *) + | C_equation ((P_forall _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) + | C_equation (P_variable a, P_forall forall) -> (dbs , [SC_Poly { tv=a; forall }]) + | C_equation (P_variable a, P_variable b) -> (dbs , [SC_Alias (a, b)]) + | C_equation (P_variable a, P_constant (c_tag, args)) -> + let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in + let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in + let (dbs , recur) = List.fold_map normalizer_simpl dbs fresh_eqns in + (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars}] @ List.flatten recur) + | C_equation ((P_constant _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) + | C_equation ((_ as a), (P_apply _ as b)) -> + (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *) + let (reduced, new_constraints) = check_applied @@ type_level_eval b in + let (dbs , recur) = List.fold_map normalizer_simpl dbs new_constraints in + let (dbs , resimpl) = normalizer_simpl dbs (C_equation (a , reduced)) in + (dbs , resimpl @ List.flatten recur) + | C_equation ((P_apply _ as a), (_ as b)) -> + normalizer_simpl dbs (C_equation (b , a)) (* TODO: have a bunch of functions for the different cases, and call these functions possibly with the arguments swapped etc. *) + | C_typeclass (args, tc) -> + (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) + let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in + let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in + let (dbs , recur) = List.fold_map normalizer_simpl dbs fresh_eqns in + (dbs, [SC_Typeclass { tc ; args = fresh_vars }] @ List.flatten recur) + | C_access_label (tv, label, result) -> let _todo = ignore (tv, label, result) in failwith "TODO" + + +(* Random notes from live discussion. Kept here to include bits as a rationale later on / remind me of the discussion in the short term. + * Feel free to erase if it rots here for too long. + * + * function (zetype, zevalue) { if (typeof(zevalue) != zetype) { ohlàlà; } else { return zevalue; } } + * + * let f = (fun {a : Type} (v : a) -> v) + * + * (forall 'a, 'a -> 'a) ~ (int -> int) + * (forall {a : Type}, forall (v : a), a) ~ (forall (v : int), int) + * ({a : Type} -> (v : a) -> a) ~ ((v : int) -> int) + * + * (@f int) + * + * + * 'c 'c + * 'd -> 'e && 'c ~ d && 'c ~ 'e + * 'c -> 'c ???????????????wtf---->???????????? [ scope of 'c is fun z ] + * 'tid ~ (forall 'c, 'c -> 'c) + * let id = (fun z -> z) in + * let ii = (fun z -> z + 0) : (int -> int) in + * + * 'a 'b ['a ~ 'b] 'a 'b + * 'a 'a 'a 'a 'a + * (forall 'a, 'a -> 'a -> 'a ) 'tid 'tid + * + * 'tid -> 'tid -> 'tid + * + * (forall 'a, 'a -> 'a -> 'a ) (forall 'c1, 'c1 -> 'c1) (int -> int) + * (forall 'c1, 'c1 -> 'c1)~(int -> int) + * ('c1 -> 'c1) ~ (int -> int) + * (fun x y -> if random then x else y) id ii as toto + * id "foo" *) type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list } let lift_state_list_monad ~state ~list = { state ; list } @@ -556,28 +622,23 @@ type new_constraints = type_constraint list type new_assignments = c_constructor_simpl list type ('old_constraint_type, 'selector_output) selector = 'old_constraint_type selector_input -> structured_dbs -> 'selector_output selector_outputs - -(* selector / propagation rule for breaking down composite types - * For now: do something with ('a = 'b) constraints. - - Or maybe this one should be a normalizer. *) +type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments (* selector / propagation rule for breaking down composite types * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) -type output_break_ctor = < a_k_var : c_constructor_simpl ; a_k'_var' : c_constructor_simpl > +type output_break_ctor = < a_k_var : c_constructor_simpl ; a_k'_var' : c_constructor_simpl > (* TODO: replace with a struct *) let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = (* find two rules with the shape a = k(var …) and a = k'(var' …) *) fun todo dbs -> - match todo with - SC_Constructor c -> - let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in - let cs_pairs = List.map (fun x -> object method a_k_var = c method a_k'_var' = x end) other_cs in - WasSelected cs_pairs - | SC_Alias _ -> WasNotSelected (* TODO: ??? *) - | SC_Typeclass _ -> WasNotSelected - -type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments + match todo with + SC_Constructor c -> + let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in + let cs_pairs = List.map (fun x -> object method a_k_var = c method a_k'_var' = x end) other_cs in + WasSelected cs_pairs + | SC_Alias _ -> WasNotSelected (* TODO: ??? *) + | SC_Poly _ -> WasNotSelected (* TODO: ??? *) + | SC_Typeclass _ -> WasNotSelected let propagator_break_ctor : output_break_ctor propagator = fun selected dbs -> @@ -600,6 +661,42 @@ let propagator_break_ctor : output_break_ctor propagator = let eqs = eq1 :: eqs3 in (eqs , []) (* no new assignments *) +(* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-( + We need to return a lazy stream of constraints. *) + +type output_specialize1 = < poly : c_poly_simpl ; a_k_var : c_constructor_simpl > +let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector = + (* find two rules with the shape (a = forall b, d) and a = k'(var' …) *) + (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) + (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) + fun todo dbs -> + match todo with + SC_Constructor _ -> WasNotSelected + | SC_Alias _ -> WasNotSelected (* TODO: ??? *) + | SC_Poly p -> + let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in + let cs_pairs = List.map (fun x -> object method poly = p method a_k_var = x end) other_cs in + WasSelected cs_pairs + | SC_Typeclass _ -> WasNotSelected + +let propagator_specialize1 : output_specialize1 propagator = + fun selected dbs -> + let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) + let a = selected#poly in + let b = selected#a_k_var in + assert (a.tv = b.tv); (* TODO: throw a propper internal error if this fails / prove that it won't in Coq. *) + (* produce constraints: *) + + (* create a fresh existential variable to instantiate the polymorphic type b *) + let fresh_existential = Core.fresh_type_variable () in + (* Produce the constraint (b.tv = a.body[a.binder |-> fresh_existential]) + The substitution is obtained by immediately applying the forall. *) + let apply = (P_apply (P_forall a.forall , P_variable fresh_existential)) in + let (reduced, new_constraints) = check_applied @@ type_level_eval apply in + let eq1 = C_equation (P_variable b.tv, reduced) in + let eqs = eq1 :: new_constraints in + (eqs, []) (* no new assignments *) + let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_output propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = fun selector propagator -> fun todo dbs -> @@ -614,6 +711,7 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_ ([] , []) let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor +let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 let select_and_propagate_all' : type_constraint_simpl selector_input -> structured_dbs -> 'todo_result = fun new_constraint dbs -> @@ -714,3 +812,18 @@ let aggregate_constraints : state -> type_constraint list -> state result = fun failwith "TODO" (*let { constraints ; eqv } = state in ok { constraints = constraints @ newc ; eqv }*) + + + + + + + +(* TODO: later on, we'll ensure that all the heuristics register the + existential/unification variables that they create, as well as the + new constraints that they create. We will then check that they only + use a small set of core axioms to derive new constraints, and + produce traces justifying that instanciations satisfy all related + constraints, and that all existential variables are instantiated + (possibly by first generalizing the type and then using the + polymorphic type argument to instantiate the existential). *) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 2ef40e5ec..edc2e306d 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -456,7 +456,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate | E_literal (Literal_timestamp t) -> ( return_wrapped (e_timestamp t) state @@ Wrap.literal (t_timestamp ()) ) - | E_literal (Literal_operation o) -> ( +< | E_literal (Literal_operation o) -> ( return_wrapped (e_operation o) state @@ Wrap.literal (t_operation ()) ) | E_literal (Literal_unit) -> ( diff --git a/src/typesystem/core.ml b/src/typesystem/core.ml index 69a5d413c..7380139d1 100644 --- a/src/typesystem/core.ml +++ b/src/typesystem/core.ml @@ -39,9 +39,16 @@ | L_string of string type type_value = - | P_forall of (type_variable * type_constraint list * type_value) + | P_forall of p_forall | P_variable of type_variable | P_constant of (constant_tag * type_value list) + | P_apply of (type_value * type_value) + + and p_forall = { + binder : type_variable ; + constraints : type_constraint list ; + body : type_value + } and simple_c_constructor = (constant_tag * type_variable list) (* non-empty list *) and simple_c_constant = (constant_tag) (* for type constructors that do not take arguments *) diff --git a/src/typesystem/shorthands.ml b/src/typesystem/shorthands.ml index 2bf16dd9c..c4d794f87 100644 --- a/src/typesystem/shorthands.ml +++ b/src/typesystem/shorthands.ml @@ -6,13 +6,13 @@ let tc type_vars allowed_list = let forall binder f = let () = ignore binder in let freshvar = fresh_type_variable () in - P_forall (freshvar , [] , f (P_variable freshvar)) + P_forall { binder = freshvar ; constraints = [] ; body = f (P_variable freshvar) } let forall_tc binder f = let () = ignore binder in let freshvar = fresh_type_variable () in let (tc, ty) = f (P_variable freshvar) in - P_forall (freshvar , tc , ty) + P_forall { binder = freshvar ; constraints = tc ; body = ty } let forall2 a b f = forall a @@ fun a' -> From 4dbd2d5873c18634c4297758e6279c44e2582671 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 29 Sep 2019 00:05:54 +0100 Subject: [PATCH 05/39] revert indentation change --- src/passes/4-typer/solver.ml | 98 ++++++++++++++++++------------------ 1 file changed, 49 insertions(+), 49 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 55b9cc60a..349828557 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -427,29 +427,29 @@ module UnionFindWrapper = struct dbs let merge_variables : type_variable -> type_variable -> structured_dbs -> structured_dbs = fun variable_a variable_b dbs -> - let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in - let dbs = { dbs with aliases } in - let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in - let dbs = { dbs with aliases } in - let default d = function None -> d | Some y -> y in - let get_constraints ab = - TypeVariableMap.find_opt ab dbs.grouped_by_variable - |> default { constructor = [] ; poly = [] ; tc = [] } in - let constraints_a = get_constraints variable_repr_a in - let constraints_b = get_constraints variable_repr_b in - let all_constraints = { - (* TODO: should be a Set.union, not @ *) - constructor = constraints_a.constructor @ constraints_b.constructor ; - poly = constraints_a.poly @ constraints_b.poly ; - tc = constraints_a.tc @ constraints_b.tc ; - } in - let grouped_by_variable = - TypeVariableMap.add variable_repr_a all_constraints dbs.grouped_by_variable in - let dbs = { dbs with grouped_by_variable} in - let grouped_by_variable = - TypeVariableMap.remove variable_repr_b dbs.grouped_by_variable in - let dbs = { dbs with grouped_by_variable} in - dbs + let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in + let dbs = { dbs with aliases } in + let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in + let dbs = { dbs with aliases } in + let default d = function None -> d | Some y -> y in + let get_constraints ab = + TypeVariableMap.find_opt ab dbs.grouped_by_variable + |> default { constructor = [] ; poly = [] ; tc = [] } in + let constraints_a = get_constraints variable_repr_a in + let constraints_b = get_constraints variable_repr_b in + let all_constraints = { + (* TODO: should be a Set.union, not @ *) + constructor = constraints_a.constructor @ constraints_b.constructor ; + poly = constraints_a.poly @ constraints_b.poly ; + tc = constraints_a.tc @ constraints_b.tc ; + } in + let grouped_by_variable = + TypeVariableMap.add variable_repr_a all_constraints dbs.grouped_by_variable in + let dbs = { dbs with grouped_by_variable} in + let grouped_by_variable = + TypeVariableMap.remove variable_repr_b dbs.grouped_by_variable in + let dbs = { dbs with grouped_by_variable} in + dbs end (* sub-sub component: constraint normalizer: remove dupes and give structure @@ -642,24 +642,24 @@ let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = let propagator_break_ctor : output_break_ctor propagator = fun selected dbs -> - let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) - let a = selected#a_k_var in - let b = selected#a_k'_var' in - (* produce constraints: *) + let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) + let a = selected#a_k_var in + let b = selected#a_k'_var' in + (* produce constraints: *) - (* a.tv = b.tv *) - let eq1 = C_equation (P_variable a.tv, P_variable b.tv) in - (* a.c_tag = b.c_tag *) - if a.c_tag <> b.c_tag then - failwith "type error: incompatible types, not same ctor (TODO error message)" - else - (* a.tv_list = b.tv_list *) - if List.length a.tv_list <> List.length b.tv_list then - failwith "type error: incompatible types, not same length (TODO error message)" - else - let eqs3 = List.map2 (fun aa bb -> C_equation (P_variable aa, P_variable bb)) a.tv_list b.tv_list in - let eqs = eq1 :: eqs3 in - (eqs , []) (* no new assignments *) + (* a.tv = b.tv *) + let eq1 = C_equation (P_variable a.tv, P_variable b.tv) in + (* a.c_tag = b.c_tag *) + if a.c_tag <> b.c_tag then + failwith "type error: incompatible types, not same ctor (TODO error message)" + else + (* a.tv_list = b.tv_list *) + if List.length a.tv_list <> List.length b.tv_list then + failwith "type error: incompatible types, not same length (TODO error message)" + else + let eqs3 = List.map2 (fun aa bb -> C_equation (P_variable aa, P_variable bb)) a.tv_list b.tv_list in + let eqs = eq1 :: eqs3 in + (eqs , []) (* no new assignments *) (* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-( We need to return a lazy stream of constraints. *) @@ -700,15 +700,15 @@ let propagator_specialize1 : output_specialize1 propagator = let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_output propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = fun selector propagator -> fun todo dbs -> - match selector todo dbs with - WasSelected selected_outputs -> - (* Call the propagation rule *) - let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in - let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in - (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) - (List.flatten new_constraints , List.flatten new_assignments) - | WasNotSelected -> - ([] , []) + match selector todo dbs with + WasSelected selected_outputs -> + (* Call the propagation rule *) + let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in + let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in + (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) + (List.flatten new_constraints , List.flatten new_assignments) + | WasNotSelected -> + ([] , []) let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 From 74a09c5ba62b9d426ee62abe51a1c516ccd62f97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 28 Sep 2019 23:58:34 +0100 Subject: [PATCH 06/39] WIP: cleaning up some TODOs --- src/passes/4-typer/solver.ml | 155 ++++++++++++++--------------------- src/passes/4-typer/typer.ml | 2 +- 2 files changed, 63 insertions(+), 94 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 349828557..32138b726 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -38,7 +38,7 @@ module Wrap = struct | "unit" -> C_unit | "bool" -> C_bool | "string" -> C_string - | _ -> failwith "TODO") + | _ -> failwith "unknown type constructor") in P_constant (csttag, List.map type_expression_to_type_value args) @@ -58,8 +58,7 @@ module Wrap = struct [] ) - (* TODO: this should be renamed to failwith_ *) - let failwith : unit -> (constraints * O.type_variable) = fun () -> + let failwith_ : unit -> (constraints * O.type_variable) = fun () -> let type_name = Core.fresh_type_variable () in [] , type_name @@ -368,6 +367,7 @@ type structured_dbs = { } and constraints = { + (* If implemented in a language with decent sets, these should be sets not lists. *) constructor : c_constructor_simpl list ; (* List of ('a = constructor(args…)) constraints *) poly : c_poly_simpl list ; (* List of ('a = forall 'b, some_type) constraints *) tc : c_typeclass_simpl list ; (* List of (typeclass(args…)) constraints *) @@ -392,11 +392,12 @@ and c_poly_simpl = { and type_constraint_simpl = SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) | SC_Alias of (type_variable * type_variable) (* α = β *) - | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type, TODO: maybe type_value is too much and we want sth simpler? *) + | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *) | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) module UnionFindWrapper = struct - (* TODO: API for the structured db, to access it modulo unification variable aliases. *) + (* Light wrapper for API for grouped_by_variable in the structured + db, to access it modulo unification variable aliases. *) let get_constraints_related_to : type_variable -> structured_dbs -> constraints = fun variable dbs -> let variable , aliases = UF.get_or_set variable dbs.aliases in @@ -438,7 +439,6 @@ module UnionFindWrapper = struct let constraints_a = get_constraints variable_repr_a in let constraints_b = get_constraints variable_repr_b in let all_constraints = { - (* TODO: should be a Set.union, not @ *) constructor = constraints_a.constructor @ constraints_b.constructor ; poly = constraints_a.poly @ constraints_b.poly ; tc = constraints_a.tc @ constraints_b.tc ; @@ -457,6 +457,7 @@ end * later: better database-like organisation of knowledge *) (* Each normalizer returns a *) +(* If implemented in a language with decent sets, should be 'b set not 'b list. *) type ('a , 'b) normalizer = structured_dbs -> 'a -> (structured_dbs * 'b list) let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) normalizer = @@ -494,53 +495,58 @@ let type_level_eval : type_value -> type_value * type_constraint list = failwith let check_applied ((reduced, _new_constraints) as x) = let () = match reduced with - P_apply _ -> failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." (* TODO: report real error *) *) + P_apply _ -> failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *) | _ -> () in x +(* TODO: at some point there may be uses of named type aliases (type + foo = int; let x : foo = 42). These should be inlined. *) let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer = fun dbs new_constraint -> - match new_constraint with - (* TODO: merge the cases that just insert a fresh variable *) - | C_equation ((P_forall _ as a), (P_forall _ as b)) - (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *) - | C_equation ((P_forall _ as a), (P_constant _ as b)) - (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *) - | C_equation ((P_constant _ as a), (P_constant _ as b)) - (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *) - | C_equation ((P_constant _ as a), (P_forall _ as b)) - -> - (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *) + let insert_fresh a b = let fresh = Core.fresh_type_variable () in let (dbs , cs1) = normalizer_simpl dbs (C_equation (P_variable fresh, a)) in let (dbs , cs2) = normalizer_simpl dbs (C_equation (P_variable fresh, b)) in - (dbs , cs1 @ cs2) (* TODO: O(n) concatenation! *) - | C_equation ((P_forall _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) - | C_equation (P_variable a, P_forall forall) -> (dbs , [SC_Poly { tv=a; forall }]) - | C_equation (P_variable a, P_variable b) -> (dbs , [SC_Alias (a, b)]) - | C_equation (P_variable a, P_constant (c_tag, args)) -> + (dbs , cs1 @ cs2) in + let split_constant a c_tag args = let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in let (dbs , recur) = List.fold_map normalizer_simpl dbs fresh_eqns in - (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars}] @ List.flatten recur) - | C_equation ((P_constant _ as a), (P_variable _ as b)) -> normalizer_simpl dbs (C_equation (b , a)) - | C_equation ((_ as a), (P_apply _ as b)) -> - (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *) + (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars}] @ List.flatten recur) in + let gather_forall a forall = (dbs , [SC_Poly { tv=a; forall }]) in + let gather_alias a b = (dbs , [SC_Alias (a, b)]) in + let reduce_type_app a b = let (reduced, new_constraints) = check_applied @@ type_level_eval b in let (dbs , recur) = List.fold_map normalizer_simpl dbs new_constraints in - let (dbs , resimpl) = normalizer_simpl dbs (C_equation (a , reduced)) in - (dbs , resimpl @ List.flatten recur) - | C_equation ((P_apply _ as a), (_ as b)) -> - normalizer_simpl dbs (C_equation (b , a)) (* TODO: have a bunch of functions for the different cases, and call these functions possibly with the arguments swapped etc. *) - | C_typeclass (args, tc) -> - (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) + let (dbs , resimpl) = normalizer_simpl dbs (C_equation (a , reduced)) in (* Note: this calls recursively but cant't fall in the same case. *) + (dbs , resimpl @ List.flatten recur) in + let split_typeclass args tc = let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in let (dbs , recur) = List.fold_map normalizer_simpl dbs fresh_eqns in - (dbs, [SC_Typeclass { tc ; args = fresh_vars }] @ List.flatten recur) - | C_access_label (tv, label, result) -> let _todo = ignore (tv, label, result) in failwith "TODO" + (dbs, [SC_Typeclass { tc ; args = fresh_vars }] @ List.flatten recur) in + match new_constraint with + (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *) + | C_equation ((P_forall _ as a), (P_forall _ as b)) -> insert_fresh a b + (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *) + | C_equation ((P_forall _ as a), (P_constant _ as b)) -> insert_fresh a b + (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *) + | C_equation ((P_constant _ as a), (P_constant _ as b)) -> insert_fresh a b + (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *) + | C_equation ((P_constant _ as a), (P_forall _ as b)) -> insert_fresh a b + | C_equation ((P_forall forall), (P_variable b)) -> gather_forall b forall + | C_equation (P_variable a, P_forall forall) -> gather_forall a forall + | C_equation (P_variable a, P_variable b) -> gather_alias a b + | C_equation (P_variable a, P_constant (c_tag , args)) -> split_constant a c_tag args + | C_equation (P_constant (c_tag , args), P_variable b) -> split_constant b c_tag args + (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *) + | C_equation ((_ as a), (P_apply _ as b)) -> reduce_type_app a b + | C_equation ((P_apply _ as a), (_ as b)) -> reduce_type_app b a + (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) + | C_typeclass (args, tc) -> split_typeclass args tc + | C_access_label (tv, label, result) -> let _todo = ignore (tv, label, result) in failwith "TODO" (* Random notes from live discussion. Kept here to include bits as a rationale later on / remind me of the discussion in the short term. * Feel free to erase if it rots here for too long. @@ -585,19 +591,6 @@ let lift f = (* TODO: move this to the List module *) let named_fold_left f ~acc ~lst = List.fold_left (fun acc lst -> f ~acc ~lst) acc lst -(* TODO: place the list of normalizers in a map *) -(* (\* cons for heterogeneous lists *\) - * type 'b f = { f : 'a . ('a -> 'b) -> 'a -> 'b } - * type ('hd , 'tl) hcons = { hd : 'hd ; tl : 'tl ; map : 'b . 'b f -> ('b , 'tl) hcons } - * let (+::) hd tl = { hd ; tl ; map = fun x -> } - * - * let list_of_normalizers = - * normalizer_simpl +:: - * normalizer_all_constraints +:: - * normalizer_assignments +:: - * normalizer_grouped_by_variable +:: - * () *) - module Fun = struct let id x = x end (* in stdlib as of 4.08, we're in 4.07 for now *) let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad = @@ -612,8 +605,6 @@ let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modifi (* sub-sub component: lazy selector (don't re-try all selectors every time) * For now: just re-try everytime *) -type todo = unit -let todo : todo = () type 'old_constraint_type selector_input = 'old_constraint_type (* some info about the constraint just added, so that we know what to look for *) type 'selector_output selector_outputs = WasSelected of 'selector_output list @@ -627,14 +618,14 @@ type 'selector_output propagator = 'selector_output -> structured_dbs -> new_con (* selector / propagation rule for breaking down composite types * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) -type output_break_ctor = < a_k_var : c_constructor_simpl ; a_k'_var' : c_constructor_simpl > (* TODO: replace with a struct *) +type output_break_ctor = { a_k_var : c_constructor_simpl ; a_k'_var' : c_constructor_simpl } let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = (* find two rules with the shape a = k(var …) and a = k'(var' …) *) - fun todo dbs -> - match todo with + fun type_constraint_simpl dbs -> + match type_constraint_simpl with SC_Constructor c -> let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in - let cs_pairs = List.map (fun x -> object method a_k_var = c method a_k'_var' = x end) other_cs in + let cs_pairs = List.map (fun x -> { a_k_var = c ; a_k'_var' = x }) other_cs in WasSelected cs_pairs | SC_Alias _ -> WasNotSelected (* TODO: ??? *) | SC_Poly _ -> WasNotSelected (* TODO: ??? *) @@ -643,19 +634,19 @@ let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = let propagator_break_ctor : output_break_ctor propagator = fun selected dbs -> let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) - let a = selected#a_k_var in - let b = selected#a_k'_var' in + let a = selected.a_k_var in + let b = selected.a_k'_var' in (* produce constraints: *) (* a.tv = b.tv *) let eq1 = C_equation (P_variable a.tv, P_variable b.tv) in (* a.c_tag = b.c_tag *) if a.c_tag <> b.c_tag then - failwith "type error: incompatible types, not same ctor (TODO error message)" + failwith "type error: incompatible types, not same ctor" else (* a.tv_list = b.tv_list *) if List.length a.tv_list <> List.length b.tv_list then - failwith "type error: incompatible types, not same length (TODO error message)" + failwith "type error: incompatible types, not same length" else let eqs3 = List.map2 (fun aa bb -> C_equation (P_variable aa, P_variable bb)) a.tv_list b.tv_list in let eqs = eq1 :: eqs3 in @@ -664,27 +655,28 @@ let propagator_break_ctor : output_break_ctor propagator = (* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-( We need to return a lazy stream of constraints. *) -type output_specialize1 = < poly : c_poly_simpl ; a_k_var : c_constructor_simpl > +type output_specialize1 = { poly : c_poly_simpl ; a_k_var : c_constructor_simpl } let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector = (* find two rules with the shape (a = forall b, d) and a = k'(var' …) *) (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) - fun todo dbs -> - match todo with + fun type_constraint_simpl dbs -> + match type_constraint_simpl with SC_Constructor _ -> WasNotSelected | SC_Alias _ -> WasNotSelected (* TODO: ??? *) | SC_Poly p -> let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in - let cs_pairs = List.map (fun x -> object method poly = p method a_k_var = x end) other_cs in + let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in WasSelected cs_pairs | SC_Typeclass _ -> WasNotSelected let propagator_specialize1 : output_specialize1 propagator = fun selected dbs -> let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) - let a = selected#poly in - let b = selected#a_k_var in - assert (a.tv = b.tv); (* TODO: throw a propper internal error if this fails / prove that it won't in Coq. *) + let a = selected.poly in + let b = selected.a_k_var in + let () = if (a.tv <> b.tv) then failwith "internal error" else () in + (* produce constraints: *) (* create a fresh existential variable to instantiate the polymorphic type b *) @@ -699,8 +691,8 @@ let propagator_specialize1 : output_specialize1 propagator = let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_output propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = fun selector propagator -> - fun todo dbs -> - match selector todo dbs with + fun old_type_constraint dbs -> + match selector old_type_constraint dbs with WasSelected selected_outputs -> (* Call the propagation rule *) let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in @@ -713,7 +705,7 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_ let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 -let select_and_propagate_all' : type_constraint_simpl selector_input -> structured_dbs -> 'todo_result = +let select_and_propagate_all' : type_constraint_simpl selector_input -> structured_dbs -> new_constraints * structured_dbs = fun new_constraint dbs -> let (new_constraints, new_assignments) = select_and_propagate_break_ctor new_constraint dbs in let assignments = List.fold_left (fun acc ({tv;c_tag=_;tv_list=_} as ele) -> TypeVariableMap.update tv (function None -> Some ele | x -> x) acc) dbs.assignments new_assignments in @@ -722,7 +714,7 @@ let select_and_propagate_all' : type_constraint_simpl selector_input -> structur (* We should try each selector in turn. If multiple selectors work, what should we do? *) (new_constraints , dbs) -let rec select_and_propagate_all : type_constraint selector_input list -> structured_dbs -> 'todo_result = +let rec select_and_propagate_all : type_constraint selector_input list -> structured_dbs -> structured_dbs = fun new_constraints dbs -> match new_constraints with | [] -> dbs @@ -782,32 +774,9 @@ let initial_state : state = { (* | C_typeclass (l , rs) -> C_typeclass (List.map aux_tv l , aux_tc rs) *) (* in List.map aux state *) -(* let check_equal a b = failwith "TODO" - * let check_same_length l1 l2 = failwith "TODO" - * - * let rec unify : type_value * type_value -> type_constraint list result = function - * | (P_variable v , P_constant (y , argsy)) -> - * failwith "TODO: replace v with the constant everywhere." - * | (P_constant (x , argsx) , P_variable w) -> - * failwith "TODO: " - * | (P_variable v , P_variable w) -> - * failwith "TODO: replace v with w everywhere" - * | (P_constant (x , argsx) , P_constant (y , argsy)) -> - * let%bind () = check_equal x y in - * let%bind () = check_same_length argsx argsy in - * let%bind _ = bind_map_list unify (List.combine argsx argsy) in - * ok [] - * | _ -> failwith "TODO" *) - -(* (\* unify a and b, possibly produce new constraints *\) *) -(* let () = ignore (a,b) in *) -(* ok [] *) - (* This is the solver *) let aggregate_constraints : state -> type_constraint list -> state result = fun state newc -> (* TODO: Iterate over constraints *) - (* TODO: try to unify things: - if we have a = X and b = Y, try to unify X and Y *) let _todo = ignore (state, newc) in failwith "TODO" (*let { constraints ; eqv } = state in @@ -819,7 +788,7 @@ let aggregate_constraints : state -> type_constraint list -> state result = fun -(* TODO: later on, we'll ensure that all the heuristics register the +(* Later on, we'll ensure that all the heuristics register the existential/unification variables that they create, as well as the new constraints that they create. We will then check that they only use a small set of core axioms to derive new constraints, and diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index edc2e306d..8b2e710d3 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -420,7 +420,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate (* Basic *) | E_failwith expr -> ( let%bind (expr', state') = type_expression e state expr in - let (constraints , expr_type) = Wrap.failwith () in + let (constraints , expr_type) = Wrap.failwith_ () in let expr'' = e_failwith expr' in return expr'' state' constraints expr_type ) From 81569b9c5452b5aac9c8ddf403dcc0d1c2e953ef Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 29 Sep 2019 18:52:38 +0200 Subject: [PATCH 07/39] add subst --- src/typesystem/misc.ml | 57 ++++++++++++++++++++++++++++++++++++ src/typesystem/typesystem.ml | 1 + 2 files changed, 58 insertions(+) create mode 100644 src/typesystem/misc.ml diff --git a/src/typesystem/misc.ml b/src/typesystem/misc.ml new file mode 100644 index 000000000..96baf197b --- /dev/null +++ b/src/typesystem/misc.ml @@ -0,0 +1,57 @@ +open Core + +let pair_map = fun f (x , y) -> (f x , f y) + +module Substitution = struct + + module Pattern = struct + + (* + Computes `P[v := expr]`. + *) + let rec type_value ~tv ~v ~expr = + let self tv = type_value ~tv ~v ~expr in + match tv with + | P_variable v' when v' = v -> expr + | P_variable _ -> tv + | P_constant (x , lst) -> ( + let lst' = List.map self lst in + P_constant (x , lst') + ) + | P_apply ab -> ( + let ab' = pair_map self ab in + P_apply ab' + ) + | P_forall p -> ( + let aux c = constraint_ ~c ~v ~expr in + let constraints = List.map aux p.constraints in + if (p.binder = v) then ( + P_forall { p with constraints } + ) else ( + let body = self p.body in + P_forall { p with constraints ; body } + ) + ) + + and constraint_ ~c ~v ~expr = + match c with + | C_equation ab -> ( + let ab' = pair_map (fun tv -> type_value ~tv ~v ~expr) ab in + C_equation ab' + ) + | C_typeclass (tvs , tc) -> ( + let tvs' = List.map (fun tv -> type_value ~tv ~v ~expr) tvs in + let tc' = typeclass ~tc ~v ~expr in + C_typeclass (tvs' , tc') + ) + | C_access_label (tv , l , v') -> ( + let tv' = type_value ~tv ~v ~expr in + C_access_label (tv' , l , v') + ) + + and typeclass ~tc ~v ~expr = + List.map (List.map (fun tv -> type_value ~tv ~v ~expr)) tc + + end + +end diff --git a/src/typesystem/typesystem.ml b/src/typesystem/typesystem.ml index b97e373e9..75d8ee5b8 100644 --- a/src/typesystem/typesystem.ml +++ b/src/typesystem/typesystem.ml @@ -1,2 +1,3 @@ module Core = Core module Shorthands = Shorthands +module Misc = Misc From 2b5b23f266acd74c7b9bb960816a62bdb31e869e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 29 Sep 2019 18:25:02 -0400 Subject: [PATCH 08/39] WIP: fixing the build errors + missing non-merged code --- scripts/install_build_environment.sh | 2 +- scripts/setup_repos.sh | 2 +- src/passes/4-typer/solver.ml | 8 ++++---- src/passes/4-typer/typer.ml | 8 ++++---- vendors/ligo-utils/simple-utils/trace.ml | 4 ++-- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/scripts/install_build_environment.sh b/scripts/install_build_environment.sh index 958f855b1..2c26191e1 100755 --- a/scripts/install_build_environment.sh +++ b/scripts/install_build_environment.sh @@ -64,4 +64,4 @@ else fi fi -opam init -a --bare +opam init -a --bare --disable-sandboxing diff --git a/scripts/setup_repos.sh b/scripts/setup_repos.sh index e14c81707..411f4bc8d 100755 --- a/scripts/setup_repos.sh +++ b/scripts/setup_repos.sh @@ -5,7 +5,7 @@ set -x eval $(opam config env) # Remove the nomadic-labs tezos repo (from ligo switch only) -opam repository remove tezos-opam-repository +opam repository remove tezos-opam-repository || true # Add ligolang tezos repo opam repository add ligolang-tezos-opam-repository https://gitlab.com/ligolang/tezos-opam-repository.git diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 32138b726..941104001 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -504,7 +504,7 @@ let check_applied ((reduced, _new_constraints) as x) = let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer = fun dbs new_constraint -> - let insert_fresh a b = + let insert_fresh a b = let fresh = Core.fresh_type_variable () in let (dbs , cs1) = normalizer_simpl dbs (C_equation (P_variable fresh, a)) in let (dbs , cs2) = normalizer_simpl dbs (C_equation (P_variable fresh, b)) in @@ -512,19 +512,19 @@ let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer let split_constant a c_tag args = let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in - let (dbs , recur) = List.fold_map normalizer_simpl dbs fresh_eqns in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars}] @ List.flatten recur) in let gather_forall a forall = (dbs , [SC_Poly { tv=a; forall }]) in let gather_alias a b = (dbs , [SC_Alias (a, b)]) in let reduce_type_app a b = let (reduced, new_constraints) = check_applied @@ type_level_eval b in - let (dbs , recur) = List.fold_map normalizer_simpl dbs new_constraints in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs new_constraints in let (dbs , resimpl) = normalizer_simpl dbs (C_equation (a , reduced)) in (* Note: this calls recursively but cant't fall in the same case. *) (dbs , resimpl @ List.flatten recur) in let split_typeclass args tc = let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in let fresh_eqns = List.map (fun (v,t) -> C_equation (P_variable v, t)) (List.combine fresh_vars args) in - let (dbs , recur) = List.fold_map normalizer_simpl dbs fresh_eqns in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in (dbs, [SC_Typeclass { tc ; args = fresh_vars }] @ List.flatten recur) in match new_constraint with diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 8b2e710d3..3020d17b6 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -239,7 +239,7 @@ let rec type_program (p:I.program) : O.program result = (* Extract pairs of (name,type) in the declaration and add it to the environment *) -let rec type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function +and type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function | Declaration_type (type_name , type_expression) -> let%bind tv = evaluate_type env type_expression in let env' = Environment.add_type type_name tv env in @@ -256,7 +256,7 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) ) -and type_match : environment -> Solver.state -> O.type_expression -> 'i I.matching -> I.expression -> Location.t -> (O.value O.matching * Solver.state) result = +and type_match : environment -> Solver.state -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> (O.value O.matching * Solver.state) result = fun e state t i ae loc -> match i with | Match_bool {match_true ; match_false} -> let%bind _ = @@ -284,7 +284,7 @@ and type_match : environment -> Solver.state -> O.type_expression -> 'i I.matchi let e' = Environment.add_ez_binder hd t_list e in let e' = Environment.add_ez_binder tl t e' in let%bind (b' , state'') = type_expression e' state' b in - ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')} , state'') + ok (O.Match_list {match_nil ; match_cons = ((hd, t_list), (tl, t)), b'} , state'') | Match_tuple (lst, b) -> let%bind t_tuple = trace_strong (match_error ~expected:i ~actual:t loc) @@ -456,7 +456,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate | E_literal (Literal_timestamp t) -> ( return_wrapped (e_timestamp t) state @@ Wrap.literal (t_timestamp ()) ) -< | E_literal (Literal_operation o) -> ( + | E_literal (Literal_operation o) -> ( return_wrapped (e_operation o) state @@ Wrap.literal (t_operation ()) ) | E_literal (Literal_unit) -> ( diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 1ae5360dd..75cc3bf85 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -599,8 +599,8 @@ let bind_fold_map_list = fun f acc lst -> f acc hd >>? fun (acc' , hd') -> aux (acc' , hd' :: prev) f tl in - aux (acc , []) f lst >>? fun (_acc' , lst') -> - ok @@ List.rev lst' + aux (acc , []) f lst >>? fun (acc' , lst') -> + ok @@ (acc' , List.rev lst') let bind_fold_map_right_list = fun f acc lst -> let rec aux (acc , prev) f = function From c1ca3184af2a62bc5265d2371aec53998d60f1b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 29 Sep 2019 18:28:19 -0400 Subject: [PATCH 09/39] WIP: fixing the build errors --- src/passes/4-typer/typer.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 3020d17b6..d32263ba8 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -222,6 +222,7 @@ end open Errors let swap (a,b) = ok (b,a) +(* let rec type_program (p:I.program) : O.program result = let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = let%bind ed' = (bind_map_location (type_declaration e)) d in @@ -235,11 +236,12 @@ let rec type_program (p:I.program) : O.program result = trace (fun () -> program_error p ()) @@ bind_fold_list aux (Environment.full_empty, []) p in ok @@ List.rev lst +*) (* Extract pairs of (name,type) in the declaration and add it to the environment *) -and type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function +let rec type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function | Declaration_type (type_name , type_expression) -> let%bind tv = evaluate_type env type_expression in let env' = Environment.add_type type_name tv env in @@ -409,7 +411,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate ] in error ~data title content in trace main_error @@ - match ae.expression' with + match ae.expression with (* TODO: this file should take care only of the order in which program fragments are translated by Wrap.xyz From a0461d06225787c3ff87df9f6e19e36e7bbdfc05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 8 Oct 2019 18:46:55 -0400 Subject: [PATCH 10/39] Renamed --- src/{ => stages}/typesystem/core.ml | 0 src/{ => stages}/typesystem/dune | 0 src/{ => stages}/typesystem/misc.ml | 0 src/{ => stages}/typesystem/shorthands.ml | 0 src/{ => stages}/typesystem/typesystem.ml | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename src/{ => stages}/typesystem/core.ml (100%) rename src/{ => stages}/typesystem/dune (100%) rename src/{ => stages}/typesystem/misc.ml (100%) rename src/{ => stages}/typesystem/shorthands.ml (100%) rename src/{ => stages}/typesystem/typesystem.ml (100%) diff --git a/src/typesystem/core.ml b/src/stages/typesystem/core.ml similarity index 100% rename from src/typesystem/core.ml rename to src/stages/typesystem/core.ml diff --git a/src/typesystem/dune b/src/stages/typesystem/dune similarity index 100% rename from src/typesystem/dune rename to src/stages/typesystem/dune diff --git a/src/typesystem/misc.ml b/src/stages/typesystem/misc.ml similarity index 100% rename from src/typesystem/misc.ml rename to src/stages/typesystem/misc.ml diff --git a/src/typesystem/shorthands.ml b/src/stages/typesystem/shorthands.ml similarity index 100% rename from src/typesystem/shorthands.ml rename to src/stages/typesystem/shorthands.ml diff --git a/src/typesystem/typesystem.ml b/src/stages/typesystem/typesystem.ml similarity index 100% rename from src/typesystem/typesystem.ml rename to src/stages/typesystem/typesystem.ml From 5de98259dc00d3153886b2d51ed8d7367f0f45da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 9 Oct 2019 00:51:29 -0400 Subject: [PATCH 11/39] Trying to merge new typer and new dev --- src/passes/4-typer/solver.ml | 98 ++++++++++++++++--------- src/passes/4-typer/typer.ml | 20 ++--- src/passes/6-transpiler/transpiler.ml | 6 ++ src/passes/6-transpiler/untranspiler.ml | 1 + src/passes/operators/helpers.ml | 2 +- src/passes/operators/operators.ml | 24 +++--- src/stages/ast_typed/PP.ml | 1 + src/stages/ast_typed/combinators.ml | 11 ++- src/stages/ast_typed/misc.ml | 2 + src/stages/ast_typed/types.ml | 1 + 10 files changed, 104 insertions(+), 62 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 941104001..138671f6e 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -4,6 +4,7 @@ module Core = Typesystem.Core module Wrap = struct module I = Ast_simplified + module T = Ast_typed module O = Core type constraints = O.type_constraint list @@ -16,8 +17,8 @@ module Wrap = struct (* let%bind state' = add_type state t in *) (* return expr state' in *) - let rec type_expression_to_type_value : I.type_expression -> O.type_value = fun te -> - match te with + let rec type_expression_to_type_value : T.type_value -> O.type_value = fun te -> + match te.type_value' with | T_tuple types -> P_constant (C_tuple, List.map type_expression_to_type_value types) | T_sum kvmap -> @@ -42,16 +43,43 @@ module Wrap = struct in P_constant (csttag, List.map type_expression_to_type_value args) + + let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te -> + match te with + | T_tuple types -> + P_constant (C_tuple, List.map type_expression_to_type_value_copypasted types) + | T_sum kvmap -> + P_constant (C_variant, Map.String.to_list @@ Map.String.map type_expression_to_type_value_copypasted kvmap) + | T_record kvmap -> + P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value_copypasted kvmap) + | T_function (arg , ret) -> + P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ arg ; ret ]) + | T_variable type_name -> P_variable type_name + | T_constant (type_name , args) -> + let csttag = Core.(match type_name with + | "arrow" -> C_arrow + | "option" -> C_option + | "tuple" -> C_tuple + | "map" -> C_map + | "list" -> C_list + | "set" -> C_set + | "unit" -> C_unit + | "bool" -> C_bool + | "string" -> C_string + | _ -> failwith "unknown type constructor") + in + P_constant (csttag, List.map type_expression_to_type_value_copypasted args) + (** TODO *) let type_declaration : I.declaration -> constraints = fun td -> match td with | Declaration_type (name , te) -> - let pattern = type_expression_to_type_value te in + let pattern = type_expression_to_type_value_copypasted te in [C_equation (P_variable (name) , pattern)] (* TODO: this looks wrong. If this is a type declaration, it should not set any constraints. *) | Declaration_constant (name, te, _) ->( match te with | Some (exp) -> - let pattern = type_expression_to_type_value exp in + let pattern = type_expression_to_type_value_copypasted exp in [C_equation (P_variable (name) , pattern)] (* TODO: this looks wrong. If this is a type declaration, it should not set any constraints. *) | None -> (** TODO *) @@ -62,12 +90,12 @@ module Wrap = struct let type_name = Core.fresh_type_variable () in [] , type_name - let variable : I.name -> I.type_expression -> (constraints * O.type_variable) = fun _name expr -> + let variable : I.name -> T.type_value -> (constraints * O.type_variable) = fun _name expr -> let pattern = type_expression_to_type_value expr in let type_name = Core.fresh_type_variable () in [C_equation (P_variable (type_name) , pattern)] , type_name - let literal : I.type_expression -> (constraints * O.type_variable) = fun t -> + let literal : T.type_value -> (constraints * O.type_variable) = fun t -> let pattern = type_expression_to_type_value t in let type_name = Core.fresh_type_variable () in [C_equation (P_variable (type_name) , pattern)] , type_name @@ -85,7 +113,7 @@ module Wrap = struct *) let tuple : I.type_expression list -> (constraints * O.type_variable) = fun tys -> - let patterns = List.map type_expression_to_type_value tys in + let patterns = List.map type_expression_to_type_value_copypasted tys in let pattern = O.(P_constant (C_tuple , patterns)) in let type_name = Core.fresh_type_variable () in [C_equation (P_variable (type_name) , pattern)] , type_name @@ -129,8 +157,8 @@ module Wrap = struct fun ~base ~key -> let key_type = Core.fresh_type_variable () in let element_type = Core.fresh_type_variable () in - let base' = type_expression_to_type_value base in - let key' = type_expression_to_type_value key in + let base' = type_expression_to_type_value_copypasted base in + let key' = type_expression_to_type_value_copypasted key in let base_expected = mk_map_type key_type element_type in let expr_type = Core.fresh_type_variable () in O.[C_equation (base' , base_expected); @@ -140,9 +168,9 @@ module Wrap = struct let constructor : I.type_expression -> I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun t_arg c_arg sum -> - let t_arg = type_expression_to_type_value t_arg in - let c_arg = type_expression_to_type_value c_arg in - let sum = type_expression_to_type_value sum in + let t_arg = type_expression_to_type_value_copypasted t_arg in + let c_arg = type_expression_to_type_value_copypasted c_arg in + let sum = type_expression_to_type_value_copypasted sum in let whole_expr = Core.fresh_type_variable () in [ C_equation (P_variable (whole_expr) , sum) ; @@ -150,7 +178,7 @@ module Wrap = struct ] , whole_expr let record : I.type_expression I.type_name_map -> (constraints * O.type_variable) = fun fields -> - let record_type = type_expression_to_type_value (I.t_record fields) in + let record_type = type_expression_to_type_value_copypasted (I.t_record fields) in let whole_expr = Core.fresh_type_variable () in [C_equation (P_variable whole_expr , record_type)] , whole_expr @@ -158,7 +186,7 @@ module Wrap = struct fun ctor element_tys -> let elttype = O.P_variable (Core.fresh_type_variable ()) in let aux elt = - let elt' = type_expression_to_type_value elt + let elt' = type_expression_to_type_value_copypasted elt in O.C_equation (elttype , elt') in let equations = List.map aux element_tys in let whole_expr = Core.fresh_type_variable () in @@ -174,10 +202,10 @@ module Wrap = struct let k_type = O.P_variable (Core.fresh_type_variable ()) in let v_type = O.P_variable (Core.fresh_type_variable ()) in let aux_k (k , _v) = - let k' = type_expression_to_type_value k in + let k' = type_expression_to_type_value_copypasted k in O.C_equation (k_type , k') in let aux_v (_k , v) = - let v' = type_expression_to_type_value v in + let v' = type_expression_to_type_value_copypasted v in O.C_equation (v_type , v') in let equations_k = List.map aux_k kv_tys in let equations_v = List.map aux_v kv_tys in @@ -189,16 +217,16 @@ module Wrap = struct let application : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun f arg -> let whole_expr = Core.fresh_type_variable () in - let f' = type_expression_to_type_value f in - let arg' = type_expression_to_type_value arg in + let f' = type_expression_to_type_value_copypasted f in + let arg' = type_expression_to_type_value_copypasted arg in O.[ C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr])) ] , whole_expr let look_up : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun ds ind -> - let ds' = type_expression_to_type_value ds in - let ind' = type_expression_to_type_value ind in + let ds' = type_expression_to_type_value_copypasted ds in + let ind' = type_expression_to_type_value_copypasted ind in let whole_expr = Core.fresh_type_variable () in let v = Core.fresh_type_variable () in O.[ @@ -208,8 +236,8 @@ module Wrap = struct let sequence : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun a b -> - let a' = type_expression_to_type_value a in - let b' = type_expression_to_type_value b in + let a' = type_expression_to_type_value_copypasted a in + let b' = type_expression_to_type_value_copypasted b in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (a' , P_constant (C_unit , [])) ; @@ -218,8 +246,8 @@ module Wrap = struct let loop : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun expr body -> - let expr' = type_expression_to_type_value expr in - let body' = type_expression_to_type_value body in + let expr' = type_expression_to_type_value_copypasted expr in + let body' = type_expression_to_type_value_copypasted body in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (expr' , P_constant (C_bool , [])) ; @@ -229,11 +257,11 @@ module Wrap = struct let let_in : I.type_expression -> I.type_expression option -> I.type_expression -> (constraints * O.type_variable) = fun rhs rhs_tv_opt result -> - let rhs' = type_expression_to_type_value rhs in - let result' = type_expression_to_type_value result in + let rhs' = type_expression_to_type_value_copypasted rhs in + let result' = type_expression_to_type_value_copypasted result in let rhs_tv_opt' = match rhs_tv_opt with None -> [] - | Some annot -> O.[C_equation (rhs' , type_expression_to_type_value annot)] in + | Some annot -> O.[C_equation (rhs' , type_expression_to_type_value_copypasted annot)] in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (result' , P_variable whole_expr) @@ -241,8 +269,8 @@ module Wrap = struct let assign : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun v e -> - let v' = type_expression_to_type_value v in - let e' = type_expression_to_type_value e in + let v' = type_expression_to_type_value_copypasted v in + let e' = type_expression_to_type_value_copypasted e in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (v' , e') ; @@ -251,8 +279,8 @@ module Wrap = struct let annotation : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = fun e annot -> - let e' = type_expression_to_type_value e in - let annot' = type_expression_to_type_value annot in + let e' = type_expression_to_type_value_copypasted e in + let annot' = type_expression_to_type_value_copypasted annot in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (e' , annot') ; @@ -262,7 +290,7 @@ module Wrap = struct let matching : I.type_expression list -> (constraints * O.type_variable) = fun es -> let whole_expr = Core.fresh_type_variable () in - let type_values = (List.map type_expression_to_type_value es) in + let type_values = (List.map type_expression_to_type_value_copypasted es) in let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values in cs, whole_expr @@ -280,12 +308,12 @@ module Wrap = struct let unification_body = Core.fresh_type_variable () in let arg' = match arg with None -> [] - | Some arg -> O.[C_equation (P_variable unification_arg , type_expression_to_type_value arg)] in + | Some arg -> O.[C_equation (P_variable unification_arg , type_expression_to_type_value_copypasted arg)] in let body' = match body with None -> [] - | Some body -> O.[C_equation (P_variable unification_body , type_expression_to_type_value body)] + | Some body -> O.[C_equation (P_variable unification_body , type_expression_to_type_value_copypasted body)] in O.[ - C_equation (type_expression_to_type_value fresh , P_variable unification_arg) ; + C_equation (type_expression_to_type_value_copypasted fresh , P_variable unification_arg) ; C_equation (P_variable whole_expr , P_constant (C_arrow , [P_variable unification_arg ; P_variable unification_body])) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index d32263ba8..70ad57305 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -420,17 +420,17 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate to actually perform the recursive calls *) (* Basic *) - | E_failwith expr -> ( - let%bind (expr', state') = type_expression e state expr in - let (constraints , expr_type) = Wrap.failwith_ () in - let expr'' = e_failwith expr' in - return expr'' state' constraints expr_type - ) + (* | E_failwith expr -> ( + * let%bind (expr', state') = type_expression e state expr in + * let (constraints , expr_type) = Wrap.failwith_ () in + * let expr'' = e_failwith expr' in + * return expr'' state' constraints expr_type + * ) *) | E_variable name -> ( - let%bind tv' = + let%bind (tv' : Environment.element) = trace_option (unbound_variable e name ae.location) @@ Environment.get_opt name e in - let (constraints , expr_type) = Wrap.variable name tv'.type_expression in + let (constraints , expr_type) = Wrap.variable name tv'.type_value in let expr' = e_variable name in return expr' state constraints expr_type ) @@ -449,8 +449,8 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate | E_literal (Literal_nat n) -> ( return_wrapped (e_nat n) state @@ Wrap.literal (t_nat ()) ) - | E_literal (Literal_tez t) -> ( - return_wrapped (e_tez t) state @@ Wrap.literal (t_tez ()) + | E_literal (Literal_mutez t) -> ( + return_wrapped (e_mutez t) state @@ Wrap.literal (t_mutez ()) ) | E_literal (Literal_address a) -> ( return_wrapped (e_address a) state @@ Wrap.literal (t_address ()) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index db7fe394a..a3eca7837 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -28,6 +28,11 @@ them. please report this to the developers." in let content () = name in error title content + let no_type_variable name = + let title () = "type variables can't be transpiled" in + let content () = name in + error title content + let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l) let unsupported_pattern_matching kind location = @@ -102,6 +107,7 @@ open Errors let rec transpile_type (t:AST.type_value) : type_value result = match t.type_value' with + | T_variable name -> fail @@ no_type_variable name | T_constant ("bool", []) -> ok (T_base Base_bool) | T_constant ("int", []) -> ok (T_base Base_int) | T_constant ("nat", []) -> ok (T_base Base_nat) diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml index 78c41cca8..fb5a7c97b 100644 --- a/src/passes/6-transpiler/untranspiler.ml +++ b/src/passes/6-transpiler/untranspiler.ml @@ -203,3 +203,4 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression let m' = map_of_kv_list lst in return (E_record m') | T_function _ -> fail @@ bad_untranspile "function" v + | T_variable v -> return (E_variable v) diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index b588605f2..46ffc302b 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -113,7 +113,7 @@ module Typer = struct List.exists (eq_2 (a , b)) [ t_int () ; t_nat () ; - t_tez () ; + t_mutez () ; t_string () ; t_bytes () ; t_address () ; diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 5eb1dfb91..27584f065 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -297,8 +297,8 @@ module Typer = struct then ok @@ t_int () else if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) then ok @@ t_timestamp () else - if (eq_2 (a , b) (t_tez ())) - then ok @@ t_tez () else + if (eq_2 (a , b) (t_mutez ())) + then ok @@ t_mutez () else fail (simple_error "Typing substraction, bad parameters.") let some = typer_1 "SOME" @@ fun a -> ok @@ t_option a () @@ -428,16 +428,16 @@ module Typer = struct let unit = constant "UNIT" @@ t_unit () - let amount = constant "AMOUNT" @@ t_tez () + let amount = constant "AMOUNT" @@ t_mutez () - let balance = constant "BALANCE" @@ t_tez () + let balance = constant "BALANCE" @@ t_mutez () let address = constant "ADDRESS" @@ t_address () let now = constant "NOW" @@ t_timestamp () let transaction = typer_3 "CALL" @@ fun param amount contract -> - let%bind () = assert_t_tez amount in + let%bind () = assert_t_mutez amount in let%bind contract_param = get_t_contract contract in let%bind () = assert_type_value_eq (param , contract_param) in ok @@ t_operation () @@ -447,7 +447,7 @@ module Typer = struct let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in let%bind () = assert_eq_1 spendable (t_bool ()) in let%bind () = assert_eq_1 delegatable (t_bool ()) in - let%bind () = assert_t_tez init_balance in + let%bind () = assert_t_mutez init_balance in let%bind (arg , res) = get_t_function code in let%bind (_param , storage) = get_t_pair arg in let%bind (storage' , op_lst) = get_t_pair res in @@ -485,8 +485,8 @@ module Typer = struct then ok @@ t_nat () else if eq_2 (a , b) (t_int ()) then ok @@ t_int () else - if (eq_1 a (t_nat ()) && eq_1 b (t_tez ())) || (eq_1 b (t_nat ()) && eq_1 a (t_tez ())) - then ok @@ t_tez () else + if (eq_1 a (t_nat ()) && eq_1 b (t_mutez ())) || (eq_1 b (t_nat ()) && eq_1 a (t_mutez ())) + then ok @@ t_mutez () else simple_fail "Multiplying with wrong types" let div = typer_2 "DIV" @@ fun a b -> @@ -494,8 +494,8 @@ module Typer = struct then ok @@ t_nat () else if eq_2 (a , b) (t_int ()) then ok @@ t_int () else - if eq_1 a (t_tez ()) && eq_1 b (t_nat ()) - then ok @@ t_tez () else + if eq_1 a (t_mutez ()) && eq_1 b (t_nat ()) + then ok @@ t_mutez () else simple_fail "Dividing with wrong types" let mod_ = typer_2 "MOD" @@ fun a b -> @@ -508,8 +508,8 @@ module Typer = struct then ok @@ t_nat () else if eq_2 (a , b) (t_int ()) then ok @@ t_int () else - if eq_2 (a , b) (t_tez ()) - then ok @@ t_tez () else + if eq_2 (a , b) (t_mutez ()) + then ok @@ t_mutez () else if (eq_1 a (t_nat ()) && eq_1 b (t_int ())) || (eq_1 b (t_nat ()) && eq_1 a (t_int ())) then ok @@ t_int () else if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) || (eq_1 b (t_timestamp ()) && eq_1 a (t_int ())) diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index fb8923ea9..d77334e87 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -14,6 +14,7 @@ let rec type_value' ppf (tv':type_value') : unit = | T_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b | T_constant (c, []) -> fprintf ppf "%s" c | T_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n + | T_variable name -> fprintf ppf "%s" name and type_value ppf (tv:type_value) : unit = type_value' ppf tv.type_value' diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index d9dcebb73..a4909851c 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -21,11 +21,12 @@ let t_int ?s () : type_value = make_t (T_constant ("int", [])) s let t_address ?s () : type_value = make_t (T_constant ("address", [])) s let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s let t_nat ?s () : type_value = make_t (T_constant ("nat", [])) s -let t_tez ?s () : type_value = make_t (T_constant ("tez", [])) s +let t_mutez ?s () : type_value = make_t (T_constant ("tez", [])) s let t_timestamp ?s () : type_value = make_t (T_constant ("timestamp", [])) s let t_unit ?s () : type_value = make_t (T_constant ("unit", [])) s let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s +let t_variable t ?s () : type_value = make_t (T_variable t) s let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s let t_set t ?s () : type_value = make_t (T_constant ("set", [t])) s let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s @@ -82,7 +83,7 @@ let get_t_unit (t:type_value) : unit result = match t.type_value' with | T_constant ("unit", []) -> ok () | _ -> simple_fail "not a unit" -let get_t_tez (t:type_value) : unit result = match t.type_value' with +let get_t_mutez (t:type_value) : unit result = match t.type_value' with | T_constant ("tez", []) -> ok () | _ -> simple_fail "not a tez" @@ -179,7 +180,7 @@ let assert_t_map = fun t -> let is_t_map = Function.compose to_bool get_t_map let is_t_big_map = Function.compose to_bool get_t_big_map -let assert_t_tez : type_value -> unit result = get_t_tez +let assert_t_mutez : type_value -> unit result = get_t_mutez let assert_t_key = get_t_key let assert_t_signature = get_t_signature let assert_t_key_hash = get_t_key_hash @@ -235,6 +236,8 @@ let e_nat n : expression = E_literal (Literal_nat n) let e_mutez n : expression = E_literal (Literal_mutez n) let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) +let e_bytes s : expression = E_literal (Literal_bytes s) +let e_timestamp s : expression = E_literal (Literal_timestamp s) let e_address s : expression = E_literal (Literal_address s) let e_operation s : expression = E_literal (Literal_operation s) let e_lambda l : expression = E_lambda l @@ -247,7 +250,7 @@ let e_let_in binder rhs result = E_let_in { binder ; rhs ; result } let e_a_unit = make_a_e e_unit (t_unit ()) let e_a_int n = make_a_e (e_int n) (t_int ()) let e_a_nat n = make_a_e (e_nat n) (t_nat ()) -let e_a_mutez n = make_a_e (e_mutez n) (t_tez ()) +let e_a_mutez n = make_a_e (e_mutez n) (t_mutez ()) let e_a_bool b = make_a_e (e_bool b) (t_bool ()) let e_a_string s = make_a_e (e_string s) (t_string ()) let e_a_address s = make_a_e (e_address s) (t_address ()) diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 5ba66b4ea..723ba3100 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -346,6 +346,8 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m let%bind _ = assert_type_value_eq (result, result') in ok () | T_function _, _ -> fail @@ different_kinds a b + | T_variable x, T_variable y -> let _ = x == y in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding" + | T_variable _, _ -> fail @@ different_kinds a b (* No information about what made it fail *) let type_value_eq ab = Trace.to_bool @@ assert_type_value_eq ab diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index d0b8ee2bb..b60632a0d 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -56,6 +56,7 @@ and type_value' = | T_sum of tv_map | T_record of tv_map | T_constant of type_name * tv list + | T_variable of type_name | T_function of (tv * tv) and type_value = { From 4fa54dd2c1d3425afaff01b664944c43c052d275 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 10 Oct 2019 01:23:55 -0400 Subject: [PATCH 12/39] More progress on merging new typer and new dev --- src/passes/4-typer/solver.ml | 85 ++++--- src/passes/4-typer/typer.ml | 305 +++++++++++++---------- src/stages/ast_typed/combinators.ml | 1 + src/stages/typesystem/core.ml | 1 + vendors/ligo-utils/simple-utils/trace.ml | 5 +- 5 files changed, 230 insertions(+), 167 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 138671f6e..ff72e1bc5 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -112,8 +112,8 @@ module Wrap = struct [C_equation (P_variable (type_name) , pattern)] , type_name *) - let tuple : I.type_expression list -> (constraints * O.type_variable) = fun tys -> - let patterns = List.map type_expression_to_type_value_copypasted tys in + let tuple : T.type_value list -> (constraints * O.type_variable) = fun tys -> + let patterns = List.map type_expression_to_type_value tys in let pattern = O.(P_constant (C_tuple , patterns)) in let type_name = Core.fresh_type_variable () in [C_equation (P_variable (type_name) , pattern)] , type_name @@ -143,7 +143,7 @@ module Wrap = struct end (* TODO: I think we should take an I.expression for the base+label *) - let access_label ~base ~label : (constraints * O.type_variable) = + let access_label ~(base : T.type_value) ~(label : O.label) : (constraints * O.type_variable) = let base' = type_expression_to_type_value base in let expr_type = Core.fresh_type_variable () in [O.C_access_label (base' , label , expr_type)] , expr_type @@ -151,14 +151,14 @@ module Wrap = struct let access_int ~base ~index = access_label ~base ~label:(L_int index) let access_string ~base ~property = access_label ~base ~label:(L_string property) - let access_map : base:I.type_expression -> key:I.type_expression -> (constraints * O.type_variable) = + let access_map : base:T.type_value -> key:T.type_value -> (constraints * O.type_variable) = let mk_map_type key_type element_type = O.P_constant O.(C_map , [P_variable element_type; P_variable key_type]) in fun ~base ~key -> let key_type = Core.fresh_type_variable () in let element_type = Core.fresh_type_variable () in - let base' = type_expression_to_type_value_copypasted base in - let key' = type_expression_to_type_value_copypasted key in + let base' = type_expression_to_type_value base in + let key' = type_expression_to_type_value key in let base_expected = mk_map_type key_type element_type in let expr_type = Core.fresh_type_variable () in O.[C_equation (base' , base_expected); @@ -166,27 +166,27 @@ module Wrap = struct C_equation (P_variable expr_type , P_variable element_type)] , expr_type let constructor - : I.type_expression -> I.type_expression -> I.type_expression -> (constraints * O.type_variable) + : T.type_value -> T.type_value -> T.type_value -> (constraints * O.type_variable) = fun t_arg c_arg sum -> - let t_arg = type_expression_to_type_value_copypasted t_arg in - let c_arg = type_expression_to_type_value_copypasted c_arg in - let sum = type_expression_to_type_value_copypasted sum in + let t_arg = type_expression_to_type_value t_arg in + let c_arg = type_expression_to_type_value c_arg in + let sum = type_expression_to_type_value sum in let whole_expr = Core.fresh_type_variable () in [ C_equation (P_variable (whole_expr) , sum) ; C_equation (t_arg , c_arg) ] , whole_expr - let record : I.type_expression I.type_name_map -> (constraints * O.type_variable) = fun fields -> - let record_type = type_expression_to_type_value_copypasted (I.t_record fields) in + let record : T.type_value I.type_name_map -> (constraints * O.type_variable) = fun fields -> + let record_type = type_expression_to_type_value (T.t_record fields ()) in let whole_expr = Core.fresh_type_variable () in [C_equation (P_variable whole_expr , record_type)] , whole_expr - let collection : O.constant_tag -> I.type_expression list -> (constraints * O.type_variable) = + let collection : O.constant_tag -> T.type_value list -> (constraints * O.type_variable) = fun ctor element_tys -> let elttype = O.P_variable (Core.fresh_type_variable ()) in let aux elt = - let elt' = type_expression_to_type_value_copypasted elt + let elt' = type_expression_to_type_value elt in O.C_equation (elttype , elt') in let equations = List.map aux element_tys in let whole_expr = Core.fresh_type_variable () in @@ -197,15 +197,15 @@ module Wrap = struct let list = collection O.C_list let set = collection O.C_set - let map : (I.type_expression * I.type_expression) list -> (constraints * O.type_variable) = + let map : (T.type_value * T.type_value) list -> (constraints * O.type_variable) = fun kv_tys -> let k_type = O.P_variable (Core.fresh_type_variable ()) in let v_type = O.P_variable (Core.fresh_type_variable ()) in let aux_k (k , _v) = - let k' = type_expression_to_type_value_copypasted k in + let k' = type_expression_to_type_value k in O.C_equation (k_type , k') in let aux_v (_k , v) = - let v' = type_expression_to_type_value_copypasted v in + let v' = type_expression_to_type_value v in O.C_equation (v_type , v') in let equations_k = List.map aux_k kv_tys in let equations_v = List.map aux_v kv_tys in @@ -214,19 +214,38 @@ module Wrap = struct C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type])) ] @ equations_k @ equations_v , whole_expr - let application : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + let big_map : (T.type_value * T.type_value) list -> (constraints * O.type_variable) = + fun kv_tys -> + let k_type = O.P_variable (Core.fresh_type_variable ()) in + let v_type = O.P_variable (Core.fresh_type_variable ()) in + let aux_k (k , _v) = + let k' = type_expression_to_type_value k in + O.C_equation (k_type , k') in + let aux_v (_k , v) = + let v' = type_expression_to_type_value v in + O.C_equation (v_type , v') in + let equations_k = List.map aux_k kv_tys in + let equations_v = List.map aux_v kv_tys in + let whole_expr = Core.fresh_type_variable () in + O.[ + (* TODO: this doesn't tag big_maps uniquely (i.e. if two + big_map have the same type, they can be swapped. *) + C_equation (P_variable whole_expr , O.P_constant (C_big_map , [k_type ; v_type])) + ] @ equations_k @ equations_v , whole_expr + + let application : T.type_value -> T.type_value -> (constraints * O.type_variable) = fun f arg -> let whole_expr = Core.fresh_type_variable () in - let f' = type_expression_to_type_value_copypasted f in - let arg' = type_expression_to_type_value_copypasted arg in + let f' = type_expression_to_type_value f in + let arg' = type_expression_to_type_value arg in O.[ C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr])) ] , whole_expr - let look_up : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + let look_up : T.type_value -> T.type_value -> (constraints * O.type_variable) = fun ds ind -> - let ds' = type_expression_to_type_value_copypasted ds in - let ind' = type_expression_to_type_value_copypasted ind in + let ds' = type_expression_to_type_value ds in + let ind' = type_expression_to_type_value ind in let whole_expr = Core.fresh_type_variable () in let v = Core.fresh_type_variable () in O.[ @@ -234,20 +253,20 @@ module Wrap = struct C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v])) ] , whole_expr - let sequence : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + let sequence : T.type_value -> T.type_value -> (constraints * O.type_variable) = fun a b -> - let a' = type_expression_to_type_value_copypasted a in - let b' = type_expression_to_type_value_copypasted b in + let a' = type_expression_to_type_value a in + let b' = type_expression_to_type_value b in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (a' , P_constant (C_unit , [])) ; C_equation (b' , P_variable whole_expr) ] , whole_expr - let loop : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + let loop : T.type_value -> T.type_value -> (constraints * O.type_variable) = fun expr body -> - let expr' = type_expression_to_type_value_copypasted expr in - let body' = type_expression_to_type_value_copypasted body in + let expr' = type_expression_to_type_value expr in + let body' = type_expression_to_type_value body in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (expr' , P_constant (C_bool , [])) ; @@ -255,13 +274,13 @@ module Wrap = struct C_equation (P_variable whole_expr , P_constant (C_unit , [])) ] , whole_expr - let let_in : I.type_expression -> I.type_expression option -> I.type_expression -> (constraints * O.type_variable) = + let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * O.type_variable) = fun rhs rhs_tv_opt result -> - let rhs' = type_expression_to_type_value_copypasted rhs in - let result' = type_expression_to_type_value_copypasted result in + let rhs' = type_expression_to_type_value rhs in + let result' = type_expression_to_type_value result in let rhs_tv_opt' = match rhs_tv_opt with None -> [] - | Some annot -> O.[C_equation (rhs' , type_expression_to_type_value_copypasted annot)] in + | Some annot -> O.[C_equation (rhs' , type_expression_to_type_value annot)] in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (result' , P_variable whole_expr) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 70ad57305..eba974e5f 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -474,39 +474,35 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate * | _ -> return (E_literal (Literal_string s)) (t_string ()) * ) *) (* Tuple *) - | E_tuple lst -> - let aux state hd = type_expression e state hd >>? swap in - let%bind (state', lst') = bind_fold_map_list aux state lst in - let tv_lst = List.map get_type_annotation lst' in - return (E_tuple lst') (t_tuple tv_lst ()) - | E_accessor (ae', path) -> - let%bind e' = type_expression e ae' in - let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = - match a with - | Access_tuple index -> ( - let%bind tpl_tv = get_t_tuple prev.type_annotation in - let%bind tv = - generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) - @@ (fun () -> List.nth tpl_tv index) in - return (E_tuple_accessor (prev , index)) tv - ) - | Access_record property -> ( - let%bind r_tv = get_t_record prev.type_annotation in - let%bind tv = - generic_try (bad_record_access property ae' prev.type_annotation ae.location) - @@ (fun () -> SMap.find property r_tv) in - return (E_record_accessor (prev , property)) tv - ) - | Access_map ae' -> ( - let%bind ae'' = type_expression e ae' in - let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in - let%bind () = - Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in - return (E_look_up (prev , ae'')) v - ) - in - trace (simple_info "accessing") @@ - bind_fold_list aux e' path + | E_tuple lst -> ( + let aux state hd = type_expression e state hd >>? swap in + let%bind (state', lst') = bind_fold_map_list aux state lst in + let tv_lst = List.map get_type_annotation lst' in + return_wrapped (e_tuple lst') state' @@ Wrap.tuple tv_lst + ) + | E_accessor (base , [Access_tuple index]) -> ( + let%bind (base' , state') = type_expression e state base in + let wrapped = Wrap.access_int ~base:base'.type_annotation ~index in + return_wrapped (E_tuple_accessor (base' , index)) state' wrapped + ) + | E_accessor (base , [Access_record property]) -> ( + let%bind (base' , state') = type_expression e state base in + let wrapped = Wrap.access_string ~base:base'.type_annotation ~property in + return_wrapped (E_record_accessor (base' , property)) state' wrapped + ) + | E_accessor (base , [Access_map key_ae]) -> ( + let%bind (base' , state') = type_expression e state base in + let%bind (key_ae' , state'') = type_expression e state' key_ae in + let xyz = get_type_annotation key_ae' in + let wrapped = Wrap.access_map ~base:base'.type_annotation ~key:xyz in + return_wrapped (E_look_up (base' , key_ae')) state'' wrapped + ) + + | E_accessor (_base , []) | E_accessor (_base , _ :: _ :: _) -> ( + failwith + "The simplifier should produce E_accessor with only a single path element, not a list of path elements." + ) + (* Sum *) | E_constructor (c, expr) -> let%bind (c_tv, sum_tv) = @@ -520,9 +516,10 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate trace_option error @@ Environment.get_constructor c e in let%bind (expr' , state') = type_expression e state expr in - let%bind _assert = O.assert_type_expression_eq (expr'.type_annotation, c_tv) in + let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in let wrapped = Wrap.constructor expr'.type_annotation c_tv sum_tv in return_wrapped (E_constructor (c , expr')) state' wrapped + (* Record *) | E_record m -> let aux (acc, state) k expr = @@ -533,6 +530,8 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let wrapped = Wrap.record (SMap.map get_type_annotation m') in return_wrapped (E_record m') state' wrapped (* Data-structure *) + +(* | E_list lst -> let%bind lst' = bind_map_list (type_expression e) lst in let%bind tv = @@ -605,112 +604,152 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate ok (t_map key_type value_type ()) in return (E_map lst') tv - | E_big_map lst -> - let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind key_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_big_map_key tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - let%bind value_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_big_map_value tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - ok (t_big_map key_type value_type ()) - in - return (E_big_map lst') tv - | E_lambda { - binder ; - input_type ; - output_type ; - result ; - } -> ( - let%bind input_type = - let%bind input_type = - (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *) - let default_action e () = fail @@ (needs_annotation e "the returned value") in - match input_type with - | Some ty -> ok ty - | None -> ( - match result.expression with - | I.E_let_in li -> ( - match li.rhs.expression with - | I.E_variable name when name = (fst binder) -> ( - match snd li.binder with - | Some ty -> ok ty - | None -> default_action li.rhs () - ) - | _ -> default_action li.rhs () - ) - | _ -> default_action result () - ) - in - evaluate_type e input_type in - let%bind output_type = - bind_map_option (evaluate_type e) output_type - in - let e' = Environment.add_ez_binder (fst binder) input_type e in - let%bind body = type_expression ?tv_opt:output_type e' result in - let output_type = body.type_annotation in - return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) - ) - | E_constant (name, lst) -> - let%bind lst' = bind_list @@ List.map (type_expression e) lst in - let tv_lst = List.map get_type_annotation lst' in - let%bind (name', tv) = - type_constant name tv_lst tv_opt ae.location in - return (E_constant (name' , lst')) tv +*) + + | E_list lst -> + let%bind (state', lst') = + bind_fold_map_list (fun state' elt -> type_expression e state' elt >>? swap) state lst in + let wrapped = Wrap.list (List.map (fun x -> O.(x.type_annotation)) lst') in + return_wrapped (E_list lst') state' wrapped + | E_set set -> + let aux = fun state' elt -> type_expression e state' elt >>? swap in + let%bind (state', set') = + bind_fold_map_list aux state set in + let wrapped = Wrap.set (List.map (fun x -> O.(x.type_annotation)) set') in + return_wrapped (E_set set') state' wrapped + | E_map map -> + let aux' state' elt = type_expression e state' elt >>? swap in + let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in + let%bind (state', map') = + bind_fold_map_list aux state map in + let aux (x, y) = O.(x.type_annotation , y.type_annotation) in + let wrapped = Wrap.map (List.map aux map') in + return_wrapped (E_map map') state' wrapped + + (* | E_big_map lst -> + * let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in + * let%bind tv = + * let aux opt c = + * match opt with + * | None -> ok (Some c) + * | Some c' -> + * let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + * ok (Some c') in + * let%bind key_type = + * let%bind sub = + * bind_fold_list aux None + * @@ List.map get_type_annotation + * @@ List.map fst lst' in + * let%bind annot = bind_map_option get_t_big_map_key tv_opt in + * trace (simple_info "empty map expression without a type annotation") @@ + * O.merge_annotation annot sub (needs_annotation ae "this map literal") + * in + * let%bind value_type = + * let%bind sub = + * bind_fold_list aux None + * @@ List.map get_type_annotation + * @@ List.map snd lst' in + * let%bind annot = bind_map_option get_t_big_map_value tv_opt in + * trace (simple_info "empty map expression without a type annotation") @@ + * O.merge_annotation annot sub (needs_annotation ae "this map literal") + * in + * ok (t_big_map key_type value_type ()) + * in + * return (E_big_map lst') tv *) + | E_big_map big_map -> + let aux' state' elt = type_expression e state' elt >>? swap in + let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in + let%bind (state', big_map') = + bind_fold_map_list aux state big_map in + let aux (x, y) = O.(x.type_annotation , y.type_annotation) in + let wrapped = Wrap.big_map (List.map aux big_map') in + return_wrapped (E_big_map big_map') state' wrapped + + (* | E_lambda { + * binder ; + * input_type ; + * output_type ; + * result ; + * } -> ( + * let%bind input_type = + * let%bind input_type = + * (\* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *\) + * let default_action e () = fail @@ (needs_annotation e "the returned value") in + * match input_type with + * | Some ty -> ok ty + * | None -> ( + * match result.expression with + * | I.E_let_in li -> ( + * match li.rhs.expression with + * | I.E_variable name when name = (fst binder) -> ( + * match snd li.binder with + * | Some ty -> ok ty + * | None -> default_action li.rhs () + * ) + * | _ -> default_action li.rhs () + * ) + * | _ -> default_action result () + * ) + * in + * evaluate_type e input_type in + * let%bind output_type = + * bind_map_option (evaluate_type e) output_type + * in + * let e' = Environment.add_ez_binder (fst binder) input_type e in + * let%bind body = type_expression ?tv_opt:output_type e' result in + * let output_type = body.type_annotation in + * return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) + * ) *) + + (* | E_constant (name, lst) -> + * let%bind lst' = bind_list @@ List.map (type_expression e) lst in + * let tv_lst = List.map get_type_annotation lst' in + * let%bind (name', tv) = + * type_constant name tv_lst tv_opt ae.location in + * return (E_constant (name' , lst')) tv *) | E_application (f, arg) -> let%bind (f' , state') = type_expression e state f in let%bind (arg , state'') = type_expression e state' arg in let wrapped = Wrap.application f'.type_annotation arg.type_annotation in return_wrapped (E_application (f' , arg)) state'' wrapped + + (* | E_look_up dsi -> + * let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in + * let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in + * let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in + * return (E_look_up (ds , ind)) (t_option dst ()) *) + | E_look_up dsi -> - let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in - let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in - return (E_look_up (ds , ind)) (t_option dst ()) + let aux' state' elt = type_expression e state' elt >>? swap in + let%bind (state'' , (ds , ind)) = bind_fold_map_pair aux' state dsi in + let wrapped = Wrap.look_up ds.type_annotation ind.type_annotation in + return_wrapped (E_look_up (ds , ind)) state'' wrapped + (* Advanced *) - | E_matching (ex, m) -> ( - let%bind ex' = type_expression e ex in - let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae ae.location in - let tvs = - let aux (cur:O.value O.matching) = - match cur with - | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] - | Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] - | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] - | Match_tuple (_ , match_tuple) -> [ match_tuple ] - | Match_variant (lst , _) -> List.map snd lst in - List.map get_type_annotation @@ aux m' in - let aux prec cur = - let%bind () = - match prec with - | None -> ok () - | Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in - ok (Some cur) in - let%bind tv_opt = bind_fold_list aux None tvs in - let%bind tv = - trace_option (match_empty_variant m ae.location) @@ - tv_opt in - return (O.E_matching (ex', m')) tv - ) + (* | E_matching (ex, m) -> ( + * let%bind ex' = type_expression e ex in + * let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae ae.location in + * let tvs = + * let aux (cur:O.value O.matching) = + * match cur with + * | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] + * | Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] + * | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] + * | Match_tuple (_ , match_tuple) -> [ match_tuple ] + * | Match_variant (lst , _) -> List.map snd lst in + * List.map get_type_annotation @@ aux m' in + * let aux prec cur = + * let%bind () = + * match prec with + * | None -> ok () + * | Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in + * ok (Some cur) in + * let%bind tv_opt = bind_fold_list aux None tvs in + * let%bind tv = + * trace_option (match_empty_variant m ae.location) @@ + * tv_opt in + * return (O.E_matching (ex', m')) tv + * ) *) | E_sequence (a , b) -> let%bind (a' , state') = type_expression e state a in let%bind (b' , state'') = type_expression e state' b in diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index a4909851c..af742b334 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -246,6 +246,7 @@ let e_application a b : expression = E_application (a , b) let e_variable v : expression = E_variable v let e_list lst : expression = E_list lst let e_let_in binder rhs result = E_let_in { binder ; rhs ; result } +let e_tuple lst : expression = E_tuple lst let e_a_unit = make_a_e e_unit (t_unit ()) let e_a_int n = make_a_e (e_int n) (t_int ()) diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index 7380139d1..8aef87157 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -17,6 +17,7 @@ | C_record (* ( label , * ) … -> * *) | C_variant (* ( label , * ) … -> * *) | C_map (* * -> * -> * *) + | C_big_map (* * -> * -> * *) | C_list (* * -> * *) | C_set (* * -> * *) | C_unit (* * *) diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 75cc3bf85..7e5083695 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -665,7 +665,10 @@ let bind_and (a, b) = let bind_pair = bind_and let bind_map_pair f (a, b) = bind_pair (f a, f b) - +let bind_fold_map_pair f acc (a, b) = + f acc a >>? fun (acc' , a') -> + f acc' b >>? fun (acc'' , b') -> + ok (acc'' , (a' , b')) (** From acfbd7eb1570d553ba278ca3b4e4776d937343d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 10 Oct 2019 03:52:43 -0400 Subject: [PATCH 13/39] Nearly builds, only one small API change and integration errors left --- src/passes/4-typer/solver.ml | 28 +++++++++++++-------------- src/passes/4-typer/typer.ml | 37 +++++++++++++++++++++++++++--------- 2 files changed, 42 insertions(+), 23 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index ff72e1bc5..f277a7fb4 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -286,30 +286,30 @@ module Wrap = struct C_equation (result' , P_variable whole_expr) ] @ rhs_tv_opt', whole_expr - let assign : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + let assign : T.type_value -> T.type_value -> (constraints * O.type_variable) = fun v e -> - let v' = type_expression_to_type_value_copypasted v in - let e' = type_expression_to_type_value_copypasted e in + let v' = type_expression_to_type_value v in + let e' = type_expression_to_type_value e in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (v' , e') ; C_equation (P_variable whole_expr , P_constant (C_unit , [])) ] , whole_expr - let annotation : I.type_expression -> I.type_expression -> (constraints * O.type_variable) = + let annotation : T.type_value -> T.type_value -> (constraints * O.type_variable) = fun e annot -> - let e' = type_expression_to_type_value_copypasted e in - let annot' = type_expression_to_type_value_copypasted annot in + let e' = type_expression_to_type_value e in + let annot' = type_expression_to_type_value annot in let whole_expr = Core.fresh_type_variable () in O.[ C_equation (e' , annot') ; C_equation (e' , P_variable whole_expr) ] , whole_expr - let matching : I.type_expression list -> (constraints * O.type_variable) = + let matching : T.type_value list -> (constraints * O.type_variable) = fun es -> let whole_expr = Core.fresh_type_variable () in - let type_values = (List.map type_expression_to_type_value_copypasted es) in + let type_values = (List.map type_expression_to_type_value es) in let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values in cs, whole_expr @@ -317,9 +317,9 @@ module Wrap = struct Core.fresh_type_variable () let lambda - : I.type_expression -> - I.type_expression option -> - I.type_expression option -> + : T.type_value -> + T.type_value option -> + T.type_value option -> (constraints * O.type_variable) = fun fresh arg body -> let whole_expr = Core.fresh_type_variable () in @@ -327,12 +327,12 @@ module Wrap = struct let unification_body = Core.fresh_type_variable () in let arg' = match arg with None -> [] - | Some arg -> O.[C_equation (P_variable unification_arg , type_expression_to_type_value_copypasted arg)] in + | Some arg -> O.[C_equation (P_variable unification_arg , type_expression_to_type_value arg)] in let body' = match body with None -> [] - | Some body -> O.[C_equation (P_variable unification_body , type_expression_to_type_value_copypasted body)] + | Some body -> O.[C_equation (P_variable unification_body , type_expression_to_type_value body)] in O.[ - C_equation (type_expression_to_type_value_copypasted fresh , P_variable unification_arg) ; + C_equation (type_expression_to_type_value fresh , P_variable unification_arg) ; C_equation (P_variable whole_expr , P_constant (C_arrow , [P_variable unification_arg ; P_variable unification_body])) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index eba974e5f..f6a9078ff 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -793,7 +793,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate | Access_map _ -> fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae in - bind_fold_list aux (typed_name.type_expression , []) path in + bind_fold_list aux (typed_name.type_value , []) path in let%bind (expr' , state') = type_expression e state expr in let wrapped = Wrap.assign assign_tv expr'.type_annotation in return_wrapped (O.E_assign (typed_name , path' , expr')) state' wrapped @@ -814,7 +814,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let aux (cur:O.value O.matching) = match cur with | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] - | Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ] + | Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] | Match_tuple (_ , match_tuple) -> [ match_tuple ] | Match_variant (lst , _) -> List.map snd lst in @@ -867,14 +867,14 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let%bind input_type' = bind_map_option (evaluate_type e) input_type in let%bind output_type' = bind_map_option (evaluate_type e) output_type in - let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in + let fresh : O.type_value = t_variable (Wrap.fresh_binder ()) () in let e' = Environment.add_ez_binder (fst binder) fresh e in let%bind (result , state') = type_expression e' state result in let output_type = result.type_annotation in let wrapped = Wrap.lambda fresh input_type' output_type' in return_wrapped - (E_lambda {binder = fst binder;input_type=fresh;output_type;result}) + (E_lambda {binder = fst binder; input_type=fresh;output_type; body=result}) state' wrapped ) @@ -964,8 +964,27 @@ let type_program' : I.program -> O.program result = fun p -> (* Tranform a Ast_typed type_expression into an ast_simplified type_expression *) -let untype_type_expression (t:O.type_expression) : (I.type_expression) result = - ok t +let rec untype_type_expression (t:O.type_value) : (I.type_expression) result = + (* TODO: or should we use t.simplified if present? *) + match t.type_value' with + | O.T_tuple x -> + let%bind x' = bind_map_list untype_type_expression x in + ok @@ I.T_tuple x' + | O.T_sum x -> + let%bind x' = bind_map_smap untype_type_expression x in + ok @@ I.T_sum x' + | O.T_record x -> + let%bind x' = bind_map_smap untype_type_expression x in + ok @@ I.T_record x' + | O.T_constant (tag, args) -> + let%bind args' = bind_map_list untype_type_expression args in + ok @@ I.T_constant (tag, args') + | O.T_variable name -> ok @@ I.T_variable name (* TODO: is this the right conversion? *) + | O.T_function (a , b) -> + let%bind a' = untype_type_expression a in + let%bind b' = untype_type_expression b in + ok @@ I.T_function (a' , b') + (* match t.simplified with *) (* | Some s -> ok s *) (* | _ -> fail @@ internal_assertion_failure "trying to untype generated type" *) @@ -1049,9 +1068,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let%bind ae' = untype_expression ae in let%bind m' = untype_matching untype_expression m in return (e_matching ae' m') - | E_failwith ae -> - let%bind ae' = untype_expression ae in - return (e_failwith ae') + (* | E_failwith ae -> + * let%bind ae' = untype_expression ae in + * return (e_failwith ae') *) | E_sequence _ | E_loop _ | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression From 581babb45906fecf6c53952c89daab5e5b42376c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 10 Oct 2019 03:55:08 -0400 Subject: [PATCH 14/39] Builds (commented out a few issues, just to check that there are no compilation errors left) --- src/bin/cli.ml | 23 ++++++++++++----------- src/main/compile/of_simplified.ml | 12 +++++++----- src/main/compile/of_source.ml | 26 ++++++++++++++------------ src/passes/4-typer/typer.ml | 3 ++- 4 files changed, 35 insertions(+), 29 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 31e9261ab..9a59280de 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -139,17 +139,18 @@ let run_function = (term , Term.info ~docs cmdname) let evaluate_value = - let f source entry_point amount syntax display_format = - toplevel ~display_format @@ - let%bind output = - Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in - ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output - in - let term = - Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in - let cmdname = "evaluate-value" in - let docs = "Subcommand: evaluate a given definition." in - (term , Term.info ~docs cmdname) + failwith "TODO" + (* let f source entry_point amount syntax display_format = + * toplevel ~display_format @@ + * let%bind output = + * Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in + * ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output + * in + * let term = + * Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in + * let cmdname = "evaluate-value" in + * let docs = "Subcommand: evaluate a given definition." in + * (term , Term.info ~docs cmdname) *) let compile_expression = let f expression syntax display_format = diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index cf8bc00fd..3e4a5e9d1 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -3,23 +3,25 @@ open Trace open Tezos_utils let compile_contract_entry (program : program) entry_point = - let%bind prog_typed = Typer.type_program program in + let%bind (_ , _ , prog_typed) = Typer.type_program program in Of_typed.compile_contract_entry prog_typed entry_point let compile_function_entry (program : program) entry_point : _ result = - let%bind prog_typed = Typer.type_program program in + let%bind (_ , _ , prog_typed) = Typer.type_program program in Of_typed.compile_function_entry prog_typed entry_point let compile_expression_as_function_entry (program : program) entry_point : _ result = - let%bind typed_program = Typer.type_program program in + let%bind (_,_,typed_program) = Typer.type_program program in Of_typed.compile_expression_as_function_entry typed_program entry_point let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = - let%bind typed = Typer.type_expression env ae in + let todo_state = failwith "todo" in + let%bind (typed , _) = Typer.type_expression env todo_state ae in Of_typed.compile_expression_as_value typed let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ae : _ result = - let%bind typed = Typer.type_expression env ae in + let todo_state = failwith "todo" in + let%bind (typed , _) = Typer.type_expression env todo_state ae in Of_typed.compile_expression_as_function typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index f7576ec19..bf1e4e6bc 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -25,15 +25,17 @@ let compile_expression_as_function : string -> s_syntax -> _ result = let type_file ?(debug_simplify = false) ?(debug_typed = false) syntax (source_filename:string) : Ast_typed.program result = - let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind simpl = parsify syntax source_filename in - (if debug_simplify then - Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) - ) ; - let%bind typed = - trace (simple_error "typing") @@ - Typer.type_program simpl in - (if debug_typed then ( - Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) - )) ; - ok typed + let _ = debug_simplify, debug_typed, syntax, source_filename in + failwith "TODO" + (* let%bind syntax = syntax_to_variant syntax (Some source_filename) in + * let%bind simpl = parsify syntax source_filename in + * (if debug_simplify then + * Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) + * ) ; + * let%bind typed = + * trace (simple_error "typing") @@ + * Typer.type_program simpl in + * (if debug_typed then ( + * Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) + * )) ; + * ok typed *) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index f6a9078ff..330615bf9 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -873,8 +873,9 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let%bind (result , state') = type_expression e' state result in let output_type = result.type_annotation in let wrapped = Wrap.lambda fresh input_type' output_type' in + let _TODO = output_type in return_wrapped - (E_lambda {binder = fst binder; input_type=fresh;output_type; body=result}) + (E_lambda {binder = fst binder;(* input_type=fresh;output_type; *)body=result}) state' wrapped ) From 2a39aa29492fc8c39dc7db016805edf21a31e147 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 10 Oct 2019 03:55:15 -0400 Subject: [PATCH 15/39] Revert "Builds (commented out a few issues, just to check that there are no compilation errors left)" This reverts commit 581babb45906fecf6c53952c89daab5e5b42376c. --- src/bin/cli.ml | 23 +++++++++++------------ src/main/compile/of_simplified.ml | 12 +++++------- src/main/compile/of_source.ml | 26 ++++++++++++-------------- src/passes/4-typer/typer.ml | 3 +-- 4 files changed, 29 insertions(+), 35 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 9a59280de..31e9261ab 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -139,18 +139,17 @@ let run_function = (term , Term.info ~docs cmdname) let evaluate_value = - failwith "TODO" - (* let f source entry_point amount syntax display_format = - * toplevel ~display_format @@ - * let%bind output = - * Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in - * ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output - * in - * let term = - * Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in - * let cmdname = "evaluate-value" in - * let docs = "Subcommand: evaluate a given definition." in - * (term , Term.info ~docs cmdname) *) + let f source entry_point amount syntax display_format = + toplevel ~display_format @@ + let%bind output = + Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output + in + let term = + Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in + let cmdname = "evaluate-value" in + let docs = "Subcommand: evaluate a given definition." in + (term , Term.info ~docs cmdname) let compile_expression = let f expression syntax display_format = diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 3e4a5e9d1..cf8bc00fd 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -3,25 +3,23 @@ open Trace open Tezos_utils let compile_contract_entry (program : program) entry_point = - let%bind (_ , _ , prog_typed) = Typer.type_program program in + let%bind prog_typed = Typer.type_program program in Of_typed.compile_contract_entry prog_typed entry_point let compile_function_entry (program : program) entry_point : _ result = - let%bind (_ , _ , prog_typed) = Typer.type_program program in + let%bind prog_typed = Typer.type_program program in Of_typed.compile_function_entry prog_typed entry_point let compile_expression_as_function_entry (program : program) entry_point : _ result = - let%bind (_,_,typed_program) = Typer.type_program program in + let%bind typed_program = Typer.type_program program in Of_typed.compile_expression_as_function_entry typed_program entry_point let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = - let todo_state = failwith "todo" in - let%bind (typed , _) = Typer.type_expression env todo_state ae in + let%bind typed = Typer.type_expression env ae in Of_typed.compile_expression_as_value typed let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ae : _ result = - let todo_state = failwith "todo" in - let%bind (typed , _) = Typer.type_expression env todo_state ae in + let%bind typed = Typer.type_expression env ae in Of_typed.compile_expression_as_function typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index bf1e4e6bc..f7576ec19 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -25,17 +25,15 @@ let compile_expression_as_function : string -> s_syntax -> _ result = let type_file ?(debug_simplify = false) ?(debug_typed = false) syntax (source_filename:string) : Ast_typed.program result = - let _ = debug_simplify, debug_typed, syntax, source_filename in - failwith "TODO" - (* let%bind syntax = syntax_to_variant syntax (Some source_filename) in - * let%bind simpl = parsify syntax source_filename in - * (if debug_simplify then - * Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) - * ) ; - * let%bind typed = - * trace (simple_error "typing") @@ - * Typer.type_program simpl in - * (if debug_typed then ( - * Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) - * )) ; - * ok typed *) + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simpl = parsify syntax source_filename in + (if debug_simplify then + Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) + ) ; + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simpl in + (if debug_typed then ( + Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) + )) ; + ok typed diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 330615bf9..f6a9078ff 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -873,9 +873,8 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let%bind (result , state') = type_expression e' state result in let output_type = result.type_annotation in let wrapped = Wrap.lambda fresh input_type' output_type' in - let _TODO = output_type in return_wrapped - (E_lambda {binder = fst binder;(* input_type=fresh;output_type; *)body=result}) + (E_lambda {binder = fst binder; input_type=fresh;output_type; body=result}) state' wrapped ) From 1356159281ede12abab00429c4c65c2a24151410 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 11 Oct 2019 04:08:12 -0400 Subject: [PATCH 16/39] WIP on integrating typer with the bin / CLI, fixed last API change --- src/main/compile/of_simplified.ml | 13 +++++++++---- src/passes/4-typer/typer.ml | 10 +++++++--- 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index cf8bc00fd..96d1f6836 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -14,12 +14,17 @@ let compile_expression_as_function_entry (program : program) entry_point : _ res let%bind typed_program = Typer.type_program program in Of_typed.compile_expression_as_function_entry typed_program entry_point -let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = - let%bind typed = Typer.type_expression env ae in +(* TODO: do we need to thread the state here? Also, make the state arg. optional. *) +let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) ae : Michelson.t result = + let%bind (typed , state) = Typer.type_expression env state ae in + (* TODO: move this to typer.ml *) + let typed = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed in Of_typed.compile_expression_as_value typed -let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ae : _ result = - let%bind typed = Typer.type_expression env ae in +let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) ae : _ result = + let%bind (typed , state) = Typer.type_expression env state ae in + (* TODO: move this to typer.ml *) + let typed = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed in Of_typed.compile_expression_as_function typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index f6a9078ff..d209d95aa 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -871,10 +871,9 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let e' = Environment.add_ez_binder (fst binder) fresh e in let%bind (result , state') = type_expression e' state result in - let output_type = result.type_annotation in let wrapped = Wrap.lambda fresh input_type' output_type' in return_wrapped - (E_lambda {binder = fst binder; input_type=fresh;output_type; body=result}) + (E_lambda {binder = fst binder; body=result}) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *) state' wrapped ) @@ -923,7 +922,7 @@ let untype_type_value (t:O.type_value) : (I.type_expression) result = (* Apply type_declaration on all the node of the AST_simplified from the root p *) -let type_program (p:I.program) : (environment * Solver.state * O.program) result = +let type_program_returns_state (p:I.program) : (environment * Solver.state * O.program) result = let env = Ast_typed.Environment.full_empty in let state = Solver.initial_state in let aux ((e : environment), (s : Solver.state) , (ds : O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = @@ -940,6 +939,11 @@ let type_program (p:I.program) : (environment * Solver.state * O.program) result let () = ignore (env' , state') in ok (env', state', declarations) +let type_program (p : I.program) : O.program result = + let%bind (env, state, program) = type_program_returns_state p in + let program = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in program in + ok program + (* Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity *) From 9e2c057edbb53968888f41fc2dbc34ff491a154a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 11 Oct 2019 15:21:21 -0400 Subject: [PATCH 17/39] dune build passes, but not dune build @ligo-test. Threaded the typechecker's state in a bunch of places where it's likely not needed, because I don't know which parts are entrypoints and which parts are intermediate functions, and the role of the state between program fragments is not yet 100% clear to me. --- src/bin/cli.ml | 4 +++- src/main/compile/of_simplified.ml | 11 +++++++---- src/main/compile/of_source.ml | 8 ++++---- src/main/run/of_simplified.ml | 12 ++++++------ src/main/run/of_source.ml | 31 +++++++++++++++++-------------- src/passes/4-typer/solver.ml | 9 +++++++++ src/passes/4-typer/typer.ml | 4 ++-- 7 files changed, 48 insertions(+), 31 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 31e9261ab..2eacae3bd 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -154,9 +154,11 @@ let evaluate_value = let compile_expression = let f expression syntax display_format = toplevel ~display_format @@ + (* This is an actual compiler entry-point, so we start with a blank state *) + let state = Typer.Solver.initial_state in let%bind value = trace (simple_error "compile-input") @@ - Ligo.Run.Of_source.compile_expression expression (Syntax_name syntax) in + Ligo.Run.Of_source.compile_expression expression state (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 96d1f6836..a443001a5 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -3,15 +3,18 @@ open Trace open Tezos_utils let compile_contract_entry (program : program) entry_point = - let%bind prog_typed = Typer.type_program program in + let%bind (prog_typed , state) = Typer.type_program program in + let () = Typer.Solver.discard_state state in Of_typed.compile_contract_entry prog_typed entry_point let compile_function_entry (program : program) entry_point : _ result = - let%bind prog_typed = Typer.type_program program in + let%bind (prog_typed , state) = Typer.type_program program in + let () = Typer.Solver.discard_state state in Of_typed.compile_function_entry prog_typed entry_point let compile_expression_as_function_entry (program : program) entry_point : _ result = - let%bind typed_program = Typer.type_program program in + let%bind (typed_program , state) = Typer.type_program program in + let () = Typer.Solver.discard_state state in Of_typed.compile_expression_as_function_entry typed_program entry_point (* TODO: do we need to thread the state here? Also, make the state arg. optional. *) @@ -21,7 +24,7 @@ let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ~(stat let typed = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed in Of_typed.compile_expression_as_value typed -let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) ae : _ result = +let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) : _ result = let%bind (typed , state) = Typer.type_expression env state ae in (* TODO: move this to typer.ml *) let typed = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed in diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index f7576ec19..b28244c3a 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -21,19 +21,19 @@ let compile_expression_as_function : string -> s_syntax -> _ result = fun expression syntax -> let%bind syntax = syntax_to_variant syntax None in let%bind simplified = parsify_expression syntax expression in - Of_simplified.compile_expression_as_function simplified + Of_simplified.compile_expression_as_function ~state:Typer.Solver.initial_state (* TODO: thread state or start with initial? *) simplified let type_file ?(debug_simplify = false) ?(debug_typed = false) - syntax (source_filename:string) : Ast_typed.program result = + syntax (source_filename:string) : (Ast_typed.program * Typer.Solver.state) result = let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind simpl = parsify syntax source_filename in (if debug_simplify then Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) ) ; - let%bind typed = + let%bind (typed, state) = trace (simple_error "typing") @@ Typer.type_program simpl in (if debug_typed then ( Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) )) ; - ok typed + ok (typed, state) diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 4bc7729b8..aab84e240 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -1,24 +1,24 @@ open Trace open Ast_simplified -let compile_expression ?(value = false) ?env expr = +let compile_expression ?(value = false) ?env ~state expr = (* TODO: state optional *) if value then ( - Compile.Of_simplified.compile_expression_as_value ?env expr + Compile.Of_simplified.compile_expression_as_value ?env ~state expr ) else ( - let%bind code = Compile.Of_simplified.compile_expression_as_function ?env expr in + let%bind code = Compile.Of_simplified.compile_expression_as_function ?env ~state expr in Of_michelson.evaluate_michelson code ) -let run_typed_program +let run_typed_program (* TODO: this runs an *untyped* program, not a typed one. *) ?options ?input_to_value - (program : Ast_typed.program) (entry : string) + (program : Ast_typed.program) (state : Typer.Solver.state) (entry : string) (input : expression) : expression result = let%bind code = Compile.Of_typed.compile_function_entry program entry in let%bind input = let env = Ast_typed.program_environment program in - compile_expression ?value:input_to_value ~env input + compile_expression ?value:input_to_value ~env ~state input in let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index f9a8e776c..1cdd71cf8 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -50,47 +50,48 @@ end let compile_file_contract_parameter : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression simplified ~env + Of_simplified.compile_expression simplified ~env ~state let compile_file_expression : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression simplified ~env + Of_simplified.compile_expression simplified ~env ~state -let compile_expression : string -> Compile.Helpers.s_syntax -> Michelson.t result = - fun expression syntax -> +let compile_expression : string -> Typer.Solver.state -> Compile.Helpers.s_syntax -> Michelson.t result = + fun expression state syntax -> let%bind syntax = Compile.Helpers.syntax_to_variant syntax None in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression simplified + Of_simplified.compile_expression ~state simplified let compile_file_contract_storage ~value : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind simplified = Compile.Helpers.parsify_expression syntax expression in - Of_simplified.compile_expression ~value simplified ~env + Of_simplified.compile_expression ~value simplified ~env ~state let compile_file_contract_args = fun ?value source_filename _entry_point storage parameter syntax -> - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in let env = Ast_typed.program_environment program in let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in let%bind storage_simplified = Compile.Helpers.parsify_expression syntax storage in let%bind parameter_simplified = Compile.Helpers.parsify_expression syntax parameter in let args = Ast_simplified.e_pair storage_simplified parameter_simplified in - Of_simplified.compile_expression ?value args ~env + Of_simplified.compile_expression ?value args ~env ~state let run_contract ?amount ?storage_value source_filename entry_point storage parameter syntax = - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in + let () = Typer.Solver.discard_state state in let%bind code = Compile.Of_typed.compile_function_entry program entry_point in let%bind args = compile_file_contract_args ?value:storage_value source_filename entry_point storage parameter syntax in let%bind ex_value_ty = @@ -104,7 +105,8 @@ let run_contract ?amount ?storage_value source_filename entry_point storage para Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty let run_function_entry ?amount source_filename entry_point input syntax = - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in + let () = Typer.Solver.discard_state state in let%bind code = Compile.Of_typed.compile_function_entry program entry_point in let%bind args = compile_file_expression source_filename entry_point input syntax in let%bind ex_value_ty = @@ -118,7 +120,8 @@ let run_function_entry ?amount source_filename entry_point input syntax = Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty let evaluate_entry ?amount source_filename entry_point syntax = - let%bind program = Compile.Of_source.type_file syntax source_filename in + let%bind (program , state) = Compile.Of_source.type_file syntax source_filename in + let () = Typer.Solver.discard_state state in let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry_point in let%bind ex_value_ty = let options = diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index f277a7fb4..4898232d4 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -804,6 +804,15 @@ let initial_state : state = { assignments = TypeVariableMap.empty ; } +(* This function is called when a program is fully compiled, and the + typechecker's state is discarded. TODO: either get rid of the state + earlier, or perform a sanity check here (e.g. that types have been + inferred for all bindings and expressions, etc. + + Also, we should check at these places that we indeed do not need the + state any further. Suwanne *) +let discard_state (_ : state) = () + (* let replace_var_in_state = fun (v : type_variable) (state : state) -> *) (* let aux_tv : type_value -> _ = function *) (* | P_forall (w , cs , tval) -> failwith "TODO" *) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index d209d95aa..a6622e944 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -939,10 +939,10 @@ let type_program_returns_state (p:I.program) : (environment * Solver.state * O.p let () = ignore (env' , state') in ok (env', state', declarations) -let type_program (p : I.program) : O.program result = +let type_program (p : I.program) : (O.program * Solver.state) result = let%bind (env, state, program) = type_program_returns_state p in let program = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in program in - ok program + ok (program, state) (* Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity From 3bbb8bfd8b427df116685e1d64f758069a960dd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 11 Oct 2019 17:01:28 -0400 Subject: [PATCH 18/39] Fixed merge issues with new merge of dev --- src/passes/4-typer/typer.ml | 38 +++++++-------- src/passes/4-typer/typer.mli | 12 +++-- src/passes/operators/operators.mli | 73 ++++++++++++++++++++++++++++ src/stages/ast_typed/combinators.mli | 16 +++--- 4 files changed, 109 insertions(+), 30 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index a6622e944..906766540 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -138,25 +138,25 @@ module Errors = struct ] in error ~data title message () - let needs_annotation (e : I.expression) (case : string) () = - let title = (thunk "this expression must be annotated with its type") in - let message () = Format.asprintf "%s needs an annotation" case in - let data = [ - ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp e.location) - ] in - error ~data title message () + (* let needs_annotation (e : I.expression) (case : string) () = + * let title = (thunk "this expression must be annotated with its type") in + * let message () = Format.asprintf "%s needs an annotation" case in + * let data = [ + * ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ; + * ("location" , fun () -> Format.asprintf "%a" Location.pp e.location) + * ] in + * error ~data title message () *) - let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () = - let title = (thunk "type error") in - let message () = msg in - let data = [ - ("expected" , fun () -> Format.asprintf "%s" expected); - ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); - ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp loc) - ] in - error ~data title message () + (* let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () = + * let title = (thunk "type error") in + * let message () = msg in + * let data = [ + * ("expected" , fun () -> Format.asprintf "%s" expected); + * ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); + * ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ; + * ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + * ] in + * error ~data title message () *) let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () = let title = (thunk "type error") in @@ -945,7 +945,7 @@ let type_program (p : I.program) : (O.program * Solver.state) result = ok (program, state) (* - Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity +TODO: Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity *) let type_program' : I.program -> O.program result = fun p -> let initial_state = Solver.initial_state in diff --git a/src/passes/4-typer/typer.mli b/src/passes/4-typer/typer.mli index cd7c00012..e60ce51bb 100644 --- a/src/passes/4-typer/typer.mli +++ b/src/passes/4-typer/typer.mli @@ -6,6 +6,8 @@ module O = Ast_typed module SMap = O.SMap module Environment = O.Environment +module Solver = Solver + type environment = Environment.t module Errors : sig @@ -37,16 +39,18 @@ module Errors : sig *) end -val type_program : I.program -> O.program result -val type_declaration : environment -> I.declaration -> (environment * O.declaration option) result -val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result +val type_program : I.program -> (O.program * Solver.state) result +val type_program' : I.program -> (O.program) result (* TODO: merge with type_program *) +val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result +(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *) val evaluate_type : environment -> I.type_expression -> O.type_value result -val type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result +val type_expression : environment -> Solver.state -> I.expression -> (O.annotated_expression * Solver.state) result val type_constant : string -> O.type_value list -> O.type_value option -> Location.t -> (string * O.type_value) result (* val untype_type_value : O.type_value -> (I.type_expression) result val untype_literal : O.literal -> I.literal result *) +val untype_type_expression : O.type_value -> I.type_expression result val untype_expression : O.annotated_expression -> I.expression result (* val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result diff --git a/src/passes/operators/operators.mli b/src/passes/operators/operators.mli index 2224cc74e..10e61a48b 100644 --- a/src/passes/operators/operators.mli +++ b/src/passes/operators/operators.mli @@ -22,6 +22,79 @@ module Typer : sig open Helpers.Typer open Ast_typed + module Operators_types : sig + (* TODO: we need a map from type names to type values. Then, all + these bindings don't need to be exported anymore. *) + val tc_subarg : + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val tc_sizearg : + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val tc_packable : + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val tc_timargs : + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val tc_divargs : + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val tc_modargs : + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val tc_addargs : + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> + Typesystem.Core.type_value -> Typesystem.Core.type_constraint + val t_none : Typesystem.Core.type_value + val t_sub : Typesystem.Core.type_value + val t_some : Typesystem.Core.type_value + val t_map_remove : Typesystem.Core.type_value + val t_map_add : Typesystem.Core.type_value + val t_map_update : Typesystem.Core.type_value + val t_map_mem : Typesystem.Core.type_value + val t_map_find : Typesystem.Core.type_value + val t_map_find_opt : Typesystem.Core.type_value + val t_map_fold : Typesystem.Core.type_value + val t_map_map : Typesystem.Core.type_value + val t_map_map_fold : Typesystem.Core.type_value + val t_map_iter : Typesystem.Core.type_value + val t_size : Typesystem.Core.type_value + val t_slice : Typesystem.Core.type_value + val t_failwith : Typesystem.Core.type_value + val t_get_force : Typesystem.Core.type_value + val t_int : Typesystem.Core.type_value + val t_bytes_pack : Typesystem.Core.type_value + val t_bytes_unpack : Typesystem.Core.type_value + val t_hash256 : Typesystem.Core.type_value + val t_hash512 : Typesystem.Core.type_value + val t_blake2b : Typesystem.Core.type_value + val t_hash_key : Typesystem.Core.type_value + val t_check_signature : Typesystem.Core.type_value + val t_sender : Typesystem.Core.type_value + val t_source : Typesystem.Core.type_value + val t_unit : Typesystem.Core.type_value + val t_amount : Typesystem.Core.type_value + val t_address : Typesystem.Core.type_value + val t_now : Typesystem.Core.type_value + val t_transaction : Typesystem.Core.type_value + val t_get_contract : Typesystem.Core.type_value + val t_abs : Typesystem.Core.type_value + val t_cons : Typesystem.Core.type_value + val t_assertion : Typesystem.Core.type_value + val t_times : Typesystem.Core.type_value + val t_div : Typesystem.Core.type_value + val t_mod : Typesystem.Core.type_value + val t_add : Typesystem.Core.type_value + val t_set_mem : Typesystem.Core.type_value + val t_set_add : Typesystem.Core.type_value + val t_set_remove : Typesystem.Core.type_value + val t_not : Typesystem.Core.type_value + end + (* val none : typer val set_empty : typer diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/ast_typed/combinators.mli index 082293b76..12b922013 100644 --- a/src/stages/ast_typed/combinators.mli +++ b/src/stages/ast_typed/combinators.mli @@ -17,13 +17,14 @@ val t_set : type_value -> ?s:S.type_expression -> unit -> type_value val t_contract : type_value -> ?s:S.type_expression -> unit -> type_value val t_int : ?s:S.type_expression -> unit -> type_value val t_nat : ?s:S.type_expression -> unit -> type_value -val t_tez : ?s:S.type_expression -> unit -> type_value +val t_mutez : ?s:S.type_expression -> unit -> type_value val t_address : ?s:S.type_expression -> unit -> type_value val t_unit : ?s:S.type_expression -> unit -> type_value val t_option : type_value -> ?s:S.type_expression -> unit -> type_value val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_list : type_value -> ?s:S.type_expression -> unit -> type_value val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value +val t_variable : name -> ?s:S.type_expression -> unit -> type_value val t_record : tv_map -> ?s:S.type_expression -> unit -> type_value val make_t_ez_record : (string * type_value) list -> type_value (* @@ -47,7 +48,7 @@ val get_t_bool : type_value -> unit result val get_t_int : type_value -> unit result val get_t_nat : type_value -> unit result val get_t_unit : type_value -> unit result -val get_t_tez : type_value -> unit result +val get_t_mutez : type_value -> unit result val get_t_bytes : type_value -> unit result val get_t_string : type_value -> unit result *) @@ -77,7 +78,7 @@ val assert_t_map : type_value -> unit result val is_t_map : type_value -> bool val is_t_big_map : type_value -> bool -val assert_t_tez : type_value -> unit result +val assert_t_mutez : type_value -> unit result val assert_t_key : type_value -> unit result val assert_t_signature : type_value -> unit result val assert_t_key_hash : type_value -> unit result @@ -104,26 +105,27 @@ val assert_t_unit : type_value -> unit result val e_record : ae_map -> expression val ez_e_record : ( string * annotated_expression ) list -> expression +*) val e_some : value -> expression val e_none : expression val e_map : ( value * value ) list -> expression val e_unit : expression val e_int : int -> expression val e_nat : int -> expression -val e_tez : int -> expression +val e_mutez : int -> expression val e_bool : bool -> expression val e_string : string -> expression -*) +val e_bytes : bytes -> expression +val e_timestamp : int -> expression val e_address : string -> expression val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression -(* val e_lambda : lambda -> expression val e_pair : value -> value -> expression val e_application : value -> value -> expression val e_variable : name -> expression val e_list : value list -> expression val e_let_in : string -> value -> value -> expression -*) +val e_tuple : value list -> expression val e_a_unit : full_environment -> annotated_expression val e_a_int : int -> full_environment -> annotated_expression From 38f9b0ba0be942248e1940e0062b3f26492802f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 11 Oct 2019 17:22:43 -0400 Subject: [PATCH 19/39] tests build (but fail when running, as expected) --- src/test/coase_tests.ml | 3 ++- src/test/heap_tests.ml | 3 ++- src/test/integration_tests.ml | 14 ++++++++++---- src/test/test_helpers.ml | 4 ++-- src/test/typer_tests.ml | 8 ++++++-- src/test/vote_tests.ml | 10 +++++----- 6 files changed, 27 insertions(+), 15 deletions(-) diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 967130f3d..874712849 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -10,7 +10,8 @@ let get_program = fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = type_file "./contracts/coase.ligo" in + let%bind (program , state) = type_file "./contracts/coase.ligo" in + let () = Typer.Solver.discard_state state in s := Some program ; ok program ) diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index 2b66de488..4fe87b4b3 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -8,7 +8,8 @@ let get_program = fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = type_file "./contracts/heap-instance.ligo" in + let%bind (program , state) = type_file "./contracts/heap-instance.ligo" in + let () = Typer.Solver.discard_state state in s := Some program ; ok program ) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 7a50ad29b..a0d93c782 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -3,8 +3,14 @@ open Test_helpers open Ast_simplified.Combinators -let mtype_file ?debug_simplify ?debug_typed = Ligo.Compile.Of_source.type_file ?debug_simplify ?debug_typed (Syntax_name "cameligo") -let type_file = Ligo.Compile.Of_source.type_file (Syntax_name "pascaligo") +let mtype_file ?debug_simplify ?debug_typed f = + let%bind (typed , state) = Ligo.Compile.Of_source.type_file ?debug_simplify ?debug_typed (Syntax_name "cameligo") f in + let () = Typer.Solver.discard_state state in + ok typed +let type_file f = + let%bind (typed , state) = Ligo.Compile.Of_source.type_file (Syntax_name "pascaligo") f in + let () = Typer.Solver.discard_state state in + ok typed let type_alias () : unit result = let%bind program = type_file "./contracts/type-alias.ligo" in @@ -212,9 +218,9 @@ let bytes_arithmetic () : unit result = let%bind () = expect_eq program "slice_op" tata at in let%bind () = expect_fail program "slice_op" foo in let%bind () = expect_fail program "slice_op" ba in - let%bind b1 = Run.Of_simplified.run_typed_program program "hasherman" foo in + let%bind b1 = Run.Of_simplified.run_typed_program program Typer.Solver.initial_state "hasherman" foo in let%bind () = expect_eq program "hasherman" foo b1 in - let%bind b3 = Run.Of_simplified.run_typed_program program "hasherman" foototo in + let%bind b3 = Run.Of_simplified.run_typed_program program Typer.Solver.initial_state "hasherman" foototo in let%bind () = Assert.assert_fail @@ Ast_simplified.Misc.assert_value_eq (b3 , b1) in ok () diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 9eee8adc0..d7650a343 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -38,7 +38,7 @@ let expect ?input_to_value ?options program entry_point input expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.Run.Of_simplified.run_typed_program ?input_to_value ?options program entry_point input in + Ligo.Run.Of_simplified.run_typed_program ?input_to_value ?options program Typer.Solver.initial_state entry_point input in expecter result let expect_fail ?options program entry_point input = @@ -49,7 +49,7 @@ let expect_fail ?options program entry_point input = in trace run_error @@ Assert.assert_fail - @@ Ligo.Run.Of_simplified.run_typed_program ?options program entry_point input + @@ Ligo.Run.Of_simplified.run_typed_program ?options program Typer.Solver.initial_state entry_point input let expect_eq ?input_to_value ?options program entry_point input expected = diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index b22fb01db..9b7007c9b 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -11,7 +11,9 @@ let int () : unit result = let pre = e_int 32 in let open Typer in let e = Environment.full_empty in - let%bind post = type_expression e pre in + let state = Typer.Solver.initial_state in + let%bind (post , new_state) = type_expression e state pre in + let () = Typer.Solver.discard_state new_state in let open! Typed in let open Combinators in let%bind () = assert_type_value_eq (post.type_annotation, t_int ()) in @@ -19,12 +21,14 @@ let int () : unit result = module TestExpressions = struct let test_expression ?(env = Typer.Environment.full_empty) + ?(state = Typer.Solver.initial_state) (expr : expression) (test_expected_ty : Typed.tv) = let pre = expr in let open Typer in let open! Typed in - let%bind post = type_expression env pre in + let%bind (post , new_state) = type_expression env state pre in + let () = Typer.Solver.discard_state new_state in let%bind () = assert_type_value_eq (post.type_annotation, test_expected_ty) in ok () diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml index 683169ee2..645ccf758 100644 --- a/src/test/vote_tests.ml +++ b/src/test/vote_tests.ml @@ -8,9 +8,9 @@ let get_program = fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = type_file "./contracts/vote.mligo" in - s := Some program ; - ok program + let%bind (program , state) = type_file "./contracts/vote.mligo" in + s := Some (program , state) ; + ok (program , state) ) open Ast_simplified @@ -39,8 +39,8 @@ let vote str = e_constructor "Vote" vote let init_vote () = - let%bind program = get_program () in - let%bind result = Ligo.Run.Of_simplified.run_typed_program program "main" (e_pair (vote "Yes") (init_storage "basic")) in + let%bind (program , state) = get_program () in + let%bind result = Ligo.Run.Of_simplified.run_typed_program program state "main" (e_pair (vote "Yes") (init_storage "basic")) in let%bind (_ , storage) = extract_pair result in let%bind storage' = extract_record storage in let votes = List.assoc "candidates" storage' in From 81ab0267f5ddd97380c4aed147d3c4d2c3463aa8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 16 Oct 2019 22:19:32 -0400 Subject: [PATCH 20/39] cleanup --- scripts/install_build_environment.sh | 2 +- src/passes/4-typer/solver.ml | 16 ---------------- 2 files changed, 1 insertion(+), 17 deletions(-) diff --git a/scripts/install_build_environment.sh b/scripts/install_build_environment.sh index 2c26191e1..958f855b1 100755 --- a/scripts/install_build_environment.sh +++ b/scripts/install_build_environment.sh @@ -64,4 +64,4 @@ else fi fi -opam init -a --bare --disable-sandboxing +opam init -a --bare diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 4898232d4..37dc296da 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -70,22 +70,6 @@ module Wrap = struct in P_constant (csttag, List.map type_expression_to_type_value_copypasted args) - (** TODO *) - let type_declaration : I.declaration -> constraints = fun td -> - match td with - | Declaration_type (name , te) -> - let pattern = type_expression_to_type_value_copypasted te in - [C_equation (P_variable (name) , pattern)] (* TODO: this looks wrong. If this is a type declaration, it should not set any constraints. *) - | Declaration_constant (name, te, _) ->( - match te with - | Some (exp) -> - let pattern = type_expression_to_type_value_copypasted exp in - [C_equation (P_variable (name) , pattern)] (* TODO: this looks wrong. If this is a type declaration, it should not set any constraints. *) - | None -> - (** TODO *) - [] - ) - let failwith_ : unit -> (constraints * O.type_variable) = fun () -> let type_name = Core.fresh_type_variable () in [] , type_name From 79967e9067c21a36373608760d04b6a772a25922 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 22 Oct 2019 08:50:21 -0400 Subject: [PATCH 21/39] Hit a module problem in OCaml. --- src/passes/4-typer/solver.ml | 228 +++++++++++++++++++++++++++++++++-- 1 file changed, 219 insertions(+), 9 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 37dc296da..b20eb7ef9 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -43,7 +43,6 @@ module Wrap = struct in P_constant (csttag, List.map type_expression_to_type_value args) - let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te -> match te with | T_tuple types -> @@ -650,16 +649,19 @@ type 'selector_output propagator = 'selector_output -> structured_dbs -> new_con * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) type output_break_ctor = { a_k_var : c_constructor_simpl ; a_k'_var' : c_constructor_simpl } -let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = +let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = (* find two rules with the shape a = k(var …) and a = k'(var' …) *) fun type_constraint_simpl dbs -> match type_constraint_simpl with SC_Constructor c -> + (* finding other constraints related to the same type variable and + with the same sort of constraint (constructor vs. constructor) + is symmetric *) let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in let cs_pairs = List.map (fun x -> { a_k_var = c ; a_k'_var' = x }) other_cs in WasSelected cs_pairs - | SC_Alias _ -> WasNotSelected (* TODO: ??? *) - | SC_Poly _ -> WasNotSelected (* TODO: ??? *) + | SC_Alias _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *) + | SC_Poly _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *) | SC_Typeclass _ -> WasNotSelected let propagator_break_ctor : output_break_ctor propagator = @@ -686,17 +688,213 @@ let propagator_break_ctor : output_break_ctor propagator = (* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-( We need to return a lazy stream of constraints. *) +module type BLABLA = Set.OrderedType (* Set.S *) + type output_specialize1 = { poly : c_poly_simpl ; a_k_var : c_constructor_simpl } + + +module Comparators = struct + module Int = struct + (* Restrict use of Pervasives.compare to just `int`, because we + don't want to risk the type of a field changing from int to + something not compatible with Pervasives.compare, and not + noticing that the comparator needs to be updated. *) + let compare (a : int) (b : int) = Pervasives.compare a b + end + let ( (function + [] -> 1 + | hd2::tl2 -> + f hd1 hd2 + compare_list f tl1 tl2) + | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) + let compare_type_variable a b = + String.compare a b + let compare_label = function + | L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1) + | L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b) + let compare_simple_c_constant = function + | C_arrow -> (function + (* N/A -> 1 *) + | C_arrow -> 0 + | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_option -> (function + | C_arrow -> 1 + | C_option -> 0 + | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_tuple -> (function + | C_arrow | C_option -> 1 + | C_tuple -> 0 + | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_record -> (function + | C_arrow | C_option | C_tuple -> 1 + | C_record -> 0 + | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_variant -> (function + | C_arrow | C_option | C_tuple | C_record -> 1 + | C_variant -> 0 + | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_map -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant -> 1 + | C_map -> 0 + | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_big_map -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1 + | C_big_map -> 0 + | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_list -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1 + | C_list -> 0 + | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_set -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1 + | C_set -> 0 + | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_unit -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 + | C_unit -> 0 + | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_bool -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1 + | C_bool -> 0 + | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_string -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1 + | C_string -> 0 + | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_nat -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1 + | C_nat -> 0 + | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_tez -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1 + | C_tez -> 0 + | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_timestamp -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez -> 1 + | C_timestamp -> 0 + | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_int -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp -> 1 + | C_int -> 0 + | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_address -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int -> 1 + | C_address -> 0 + | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_bytes -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address -> 1 + | C_bytes -> 0 + | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_key_hash -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes -> 1 + | C_key_hash -> 0 + | C_key | C_signature | C_operation | C_contract -> -1) + | C_key -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 + | C_key -> 0 + | C_signature | C_operation | C_contract -> -1) + | C_signature -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 + | C_signature -> 0 + | C_operation | C_contract -> -1) + | C_operation -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 + | C_operation -> 0 + | C_contract -> -1) + | C_contract -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 + | C_contract -> 0 + (* N/A -> -1 *) + ) + let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b + and compare_type_value = function + | P_forall { binder=a1; constraints=a2; body=a3 } -> (function + | P_forall { binder=b1; constraints=b2; body=b3 } -> + compare_type_variable a1 b1 + compare_list compare_type_constraint a2 b2 + compare_type_value a3 b3 + | P_variable _ -> -1 + | P_constant _ -> -1 + | P_apply _ -> -1) + | P_variable a -> (function + | P_forall _ -> 1 + | P_variable b -> String.compare a b + | P_constant _ -> -1 + | P_apply _ -> -1) + | P_constant (a1, a2) -> (function + | P_forall _ -> 1 + | P_variable _ -> 1 + | P_constant (b1, b2) -> compare_simple_c_constant a1 b1 compare_list compare_type_value a2 b2 + | P_apply _ -> -1) + | P_apply (a1, a2) -> (function + | P_forall _ -> 1 + | P_variable _ -> 1 + | P_constant _ -> 1 + | P_apply (b1, b2) -> compare_type_value a1 b1 compare_type_value a2 b2) + and compare_type_constraint = function + | C_equation (a1, a2) -> (function + | C_equation (b1, b2) -> compare_type_value a1 b1 compare_type_value a2 b2 + | C_typeclass _ -> -1 + | C_access_label _ -> -1) + | C_typeclass (a1, a2) -> (function + | C_equation _ -> 1 + | C_typeclass (b1, b2) -> compare_list compare_type_value a1 b1 compare_typeclass a2 b2 + | C_access_label _ -> -1) + | C_access_label (a1, a2, a3) -> (function + | C_equation _ -> 1 + | C_typeclass _ -> 1 + | C_access_label (b1, b2, b3) -> compare_type_value a1 b1 compare_label a2 b2 compare_type_variable a3 b3) + let rec compare_type_constraint_list = compare_list compare_type_constraint + let compare_p_forall + { binder = a1; constraints = a2; body = a3 } + { binder = b1; constraints = b2; body = b3 } = + compare_type_variable a1 b1 + compare_type_constraint_list a2 b2 + compare_type_value a3 b3 + let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } = + compare_type_variable a1 b1 + compare_p_forall a2 b2 + let compare_c_constructor_simpl { tv=a1; c_tag=a2; tv_list=a3 } { tv=b1; c_tag=b2; tv_list=b3 } = + compare_type_variable a1 b1 compare_simple_c_constant a2 b2 compare_list compare_type_variable a3 b3 + + let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } = + compare_c_poly_simpl a1 b1 + compare_c_constructor_simpl a2 b2 + + let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } = + compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 +end + +module OutputSpecialize1 : BLABLA = struct + type t = output_specialize1 + let compare = Comparators.compare_output_specialize1 +end + + +module BreakCtor : BLABLA = struct + type t = output_break_ctor + let compare = Comparators.compare_output_break_ctor +end + let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector = - (* find two rules with the shape (a = forall b, d) and a = k'(var' …) *) + (* find two rules with the shape (a = forall b, d) and a = k'(var' …) or vice versa *) (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) fun type_constraint_simpl dbs -> match type_constraint_simpl with - SC_Constructor _ -> WasNotSelected + SC_Constructor c -> + (* vice versa *) + let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).poly in + let other_cs = List.filter (fun (x : c_poly_simpl) -> c.tv == x.tv) other_cs in (* TODO: does equality work in OCaml? *) + let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in + WasSelected cs_pairs | SC_Alias _ -> WasNotSelected (* TODO: ??? *) | SC_Poly p -> let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in + let other_cs = List.filter (fun (x : c_constructor_simpl) -> x.tv == p.tv) other_cs in (* TODO: does equality work in OCaml? *) let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in WasSelected cs_pairs | SC_Typeclass _ -> WasNotSelected @@ -720,11 +918,19 @@ let propagator_specialize1 : output_specialize1 propagator = let eqs = eq1 :: new_constraints in (eqs, []) (* no new assignments *) -let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_output propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = +module M (BlaBla : BLABLA) = struct + module AlreadySelected = Set.Make(BlaBla) + +let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = fun selector propagator -> fun old_type_constraint dbs -> + (* TODO: thread some state to know which selector outputs were already seen *) + let already_selected = (??) in match selector old_type_constraint dbs with WasSelected selected_outputs -> + (* TODO: fold instead. *) + let selected_outputs = List.filter (fun elt -> AlreadySelected.mem elt already_selected) selected_outputs in + let blahblah = List.fold_left (fun acc elt -> AlreadySelected.add elt acc) already_selected selected_outputs in (* Call the propagation rule *) let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in @@ -732,9 +938,13 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_ (List.flatten new_constraints , List.flatten new_assignments) | WasNotSelected -> ([] , []) +end -let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor -let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 +module M_break_ctor = M(BreakCtor) +module M_specialize1 = M(OutputSpecialize1) + +let select_and_propagate_break_ctor = M_break_ctor.select_and_propagate selector_break_ctor propagator_break_ctor +let select_and_propagate_specialize1 = M_specialize1.select_and_propagate selector_specialize1 propagator_specialize1 let select_and_propagate_all' : type_constraint_simpl selector_input -> structured_dbs -> new_constraints * structured_dbs = fun new_constraint dbs -> From 10362426aacdca72ac0600b8d13e9f0bd0ad6b91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 23 Oct 2019 10:41:36 -0400 Subject: [PATCH 22/39] blabla --- src/passes/4-typer/solver.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index b20eb7ef9..8ce71daaf 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -925,12 +925,13 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t p fun selector propagator -> fun old_type_constraint dbs -> (* TODO: thread some state to know which selector outputs were already seen *) - let already_selected = (??) in + let already_selected = failwith "(?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? TODO)" in match selector old_type_constraint dbs with WasSelected selected_outputs -> (* TODO: fold instead. *) let selected_outputs = List.filter (fun elt -> AlreadySelected.mem elt already_selected) selected_outputs in let blahblah = List.fold_left (fun acc elt -> AlreadySelected.add elt acc) already_selected selected_outputs in + let _______________________________________________________________________________________________________________________________________TODO = blahblah in (* Call the propagation rule *) let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in From 535c291b3f860b06122e95cacb8bbd382db55a4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 23 Oct 2019 10:45:48 -0400 Subject: [PATCH 23/39] blabla --- src/passes/4-typer/solver.ml | 350 +++++++++++++++++------------------ 1 file changed, 173 insertions(+), 177 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 8ce71daaf..91b6715ac 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -688,195 +688,191 @@ let propagator_break_ctor : output_break_ctor propagator = (* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-( We need to return a lazy stream of constraints. *) -module type BLABLA = Set.OrderedType (* Set.S *) - type output_specialize1 = { poly : c_poly_simpl ; a_k_var : c_constructor_simpl } -module Comparators = struct - module Int = struct - (* Restrict use of Pervasives.compare to just `int`, because we - don't want to risk the type of a field changing from int to - something not compatible with Pervasives.compare, and not - noticing that the comparator needs to be updated. *) - let compare (a : int) (b : int) = Pervasives.compare a b - end - let ( (function - [] -> 1 - | hd2::tl2 -> - f hd1 hd2 - compare_list f tl1 tl2) - | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) - let compare_type_variable a b = - String.compare a b - let compare_label = function - | L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1) - | L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b) - let compare_simple_c_constant = function - | C_arrow -> (function - (* N/A -> 1 *) - | C_arrow -> 0 - | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_option -> (function - | C_arrow -> 1 - | C_option -> 0 - | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_tuple -> (function - | C_arrow | C_option -> 1 - | C_tuple -> 0 - | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_record -> (function - | C_arrow | C_option | C_tuple -> 1 - | C_record -> 0 - | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_variant -> (function - | C_arrow | C_option | C_tuple | C_record -> 1 - | C_variant -> 0 - | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_map -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant -> 1 - | C_map -> 0 - | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_big_map -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1 - | C_big_map -> 0 - | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_list -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1 - | C_list -> 0 - | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_set -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1 - | C_set -> 0 - | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_unit -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 - | C_unit -> 0 - | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_bool -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1 - | C_bool -> 0 - | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_string -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1 - | C_string -> 0 - | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_nat -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1 - | C_nat -> 0 - | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_tez -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1 - | C_tez -> 0 - | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_timestamp -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez -> 1 - | C_timestamp -> 0 - | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_int -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp -> 1 - | C_int -> 0 - | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_address -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int -> 1 - | C_address -> 0 - | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_bytes -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address -> 1 - | C_bytes -> 0 - | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) - | C_key_hash -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes -> 1 - | C_key_hash -> 0 - | C_key | C_signature | C_operation | C_contract -> -1) - | C_key -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 - | C_key -> 0 - | C_signature | C_operation | C_contract -> -1) - | C_signature -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 - | C_signature -> 0 - | C_operation | C_contract -> -1) - | C_operation -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 - | C_operation -> 0 - | C_contract -> -1) - | C_contract -> (function - | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 - | C_contract -> 0 - (* N/A -> -1 *) - ) - let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b - and compare_type_value = function - | P_forall { binder=a1; constraints=a2; body=a3 } -> (function - | P_forall { binder=b1; constraints=b2; body=b3 } -> - compare_type_variable a1 b1 - compare_list compare_type_constraint a2 b2 - compare_type_value a3 b3 - | P_variable _ -> -1 - | P_constant _ -> -1 - | P_apply _ -> -1) - | P_variable a -> (function - | P_forall _ -> 1 - | P_variable b -> String.compare a b - | P_constant _ -> -1 - | P_apply _ -> -1) - | P_constant (a1, a2) -> (function - | P_forall _ -> 1 - | P_variable _ -> 1 - | P_constant (b1, b2) -> compare_simple_c_constant a1 b1 compare_list compare_type_value a2 b2 - | P_apply _ -> -1) - | P_apply (a1, a2) -> (function - | P_forall _ -> 1 - | P_variable _ -> 1 - | P_constant _ -> 1 - | P_apply (b1, b2) -> compare_type_value a1 b1 compare_type_value a2 b2) - and compare_type_constraint = function - | C_equation (a1, a2) -> (function - | C_equation (b1, b2) -> compare_type_value a1 b1 compare_type_value a2 b2 - | C_typeclass _ -> -1 - | C_access_label _ -> -1) - | C_typeclass (a1, a2) -> (function - | C_equation _ -> 1 - | C_typeclass (b1, b2) -> compare_list compare_type_value a1 b1 compare_typeclass a2 b2 - | C_access_label _ -> -1) - | C_access_label (a1, a2, a3) -> (function - | C_equation _ -> 1 - | C_typeclass _ -> 1 - | C_access_label (b1, b2, b3) -> compare_type_value a1 b1 compare_label a2 b2 compare_type_variable a3 b3) - let rec compare_type_constraint_list = compare_list compare_type_constraint - let compare_p_forall - { binder = a1; constraints = a2; body = a3 } - { binder = b1; constraints = b2; body = b3 } = - compare_type_variable a1 b1 - compare_type_constraint_list a2 b2 - compare_type_value a3 b3 - let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } = - compare_type_variable a1 b1 +module Int = struct + (* Restrict use of Pervasives.compare to just `int`, because we + don't want to risk the type of a field changing from int to + something not compatible with Pervasives.compare, and not + noticing that the comparator needs to be updated. *) + let compare (a : int) (b : int) = Pervasives.compare a b +end +let ( (function + [] -> 1 + | hd2::tl2 -> + f hd1 hd2 + compare_list f tl1 tl2) + | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) +let compare_type_variable a b = + String.compare a b +let compare_label = function + | L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1) + | L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b) +let compare_simple_c_constant = function + | C_arrow -> (function + (* N/A -> 1 *) + | C_arrow -> 0 + | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_option -> (function + | C_arrow -> 1 + | C_option -> 0 + | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_tuple -> (function + | C_arrow | C_option -> 1 + | C_tuple -> 0 + | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_record -> (function + | C_arrow | C_option | C_tuple -> 1 + | C_record -> 0 + | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_variant -> (function + | C_arrow | C_option | C_tuple | C_record -> 1 + | C_variant -> 0 + | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_map -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant -> 1 + | C_map -> 0 + | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_big_map -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1 + | C_big_map -> 0 + | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_list -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1 + | C_list -> 0 + | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_set -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1 + | C_set -> 0 + | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_unit -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 + | C_unit -> 0 + | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_bool -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1 + | C_bool -> 0 + | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_string -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1 + | C_string -> 0 + | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_nat -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1 + | C_nat -> 0 + | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_tez -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1 + | C_tez -> 0 + | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_timestamp -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez -> 1 + | C_timestamp -> 0 + | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_int -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp -> 1 + | C_int -> 0 + | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_address -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int -> 1 + | C_address -> 0 + | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_bytes -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address -> 1 + | C_bytes -> 0 + | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1) + | C_key_hash -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes -> 1 + | C_key_hash -> 0 + | C_key | C_signature | C_operation | C_contract -> -1) + | C_key -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 + | C_key -> 0 + | C_signature | C_operation | C_contract -> -1) + | C_signature -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 + | C_signature -> 0 + | C_operation | C_contract -> -1) + | C_operation -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 + | C_operation -> 0 + | C_contract -> -1) + | C_contract -> (function + | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_tez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 + | C_contract -> 0 + (* N/A -> -1 *) + ) +let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b +and compare_type_value = function + | P_forall { binder=a1; constraints=a2; body=a3 } -> (function + | P_forall { binder=b1; constraints=b2; body=b3 } -> + compare_type_variable a1 b1 + compare_list compare_type_constraint a2 b2 + compare_type_value a3 b3 + | P_variable _ -> -1 + | P_constant _ -> -1 + | P_apply _ -> -1) + | P_variable a -> (function + | P_forall _ -> 1 + | P_variable b -> String.compare a b + | P_constant _ -> -1 + | P_apply _ -> -1) + | P_constant (a1, a2) -> (function + | P_forall _ -> 1 + | P_variable _ -> 1 + | P_constant (b1, b2) -> compare_simple_c_constant a1 b1 compare_list compare_type_value a2 b2 + | P_apply _ -> -1) + | P_apply (a1, a2) -> (function + | P_forall _ -> 1 + | P_variable _ -> 1 + | P_constant _ -> 1 + | P_apply (b1, b2) -> compare_type_value a1 b1 compare_type_value a2 b2) +and compare_type_constraint = function + | C_equation (a1, a2) -> (function + | C_equation (b1, b2) -> compare_type_value a1 b1 compare_type_value a2 b2 + | C_typeclass _ -> -1 + | C_access_label _ -> -1) + | C_typeclass (a1, a2) -> (function + | C_equation _ -> 1 + | C_typeclass (b1, b2) -> compare_list compare_type_value a1 b1 compare_typeclass a2 b2 + | C_access_label _ -> -1) + | C_access_label (a1, a2, a3) -> (function + | C_equation _ -> 1 + | C_typeclass _ -> 1 + | C_access_label (b1, b2, b3) -> compare_type_value a1 b1 compare_label a2 b2 compare_type_variable a3 b3) +let rec compare_type_constraint_list = compare_list compare_type_constraint +let compare_p_forall + { binder = a1; constraints = a2; body = a3 } + { binder = b1; constraints = b2; body = b3 } = + compare_type_variable a1 b1 + compare_type_constraint_list a2 b2 + compare_type_value a3 b3 +let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } = + compare_type_variable a1 b1 compare_p_forall a2 b2 - let compare_c_constructor_simpl { tv=a1; c_tag=a2; tv_list=a3 } { tv=b1; c_tag=b2; tv_list=b3 } = - compare_type_variable a1 b1 compare_simple_c_constant a2 b2 compare_list compare_type_variable a3 b3 +let compare_c_constructor_simpl { tv=a1; c_tag=a2; tv_list=a3 } { tv=b1; c_tag=b2; tv_list=b3 } = + compare_type_variable a1 b1 compare_simple_c_constant a2 b2 compare_list compare_type_variable a3 b3 - let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } = - compare_c_poly_simpl a1 b1 +let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } = + compare_c_poly_simpl a1 b1 compare_c_constructor_simpl a2 b2 - let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } = - compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 -end +let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } = + compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 -module OutputSpecialize1 : BLABLA = struct +module OutputSpecialize1 : Set.OrderedType = struct type t = output_specialize1 - let compare = Comparators.compare_output_specialize1 + let compare = compare_output_specialize1 end -module BreakCtor : BLABLA = struct +module BreakCtor : Set.OrderedType = struct type t = output_break_ctor - let compare = Comparators.compare_output_break_ctor + let compare = compare_output_break_ctor end let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector = @@ -918,7 +914,7 @@ let propagator_specialize1 : output_specialize1 propagator = let eqs = eq1 :: new_constraints in (eqs, []) (* no new assignments *) -module M (BlaBla : BLABLA) = struct +module M (BlaBla : Set.OrderedType) = struct module AlreadySelected = Set.Make(BlaBla) let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = From c4e996d5aa1c2ee9c4bed0a99b8ba1c767e11262 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 23 Oct 2019 12:17:18 -0400 Subject: [PATCH 24/39] Fixed module issue, thanks Christian --- src/passes/4-typer/solver.ml | 40 ++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index 91b6715ac..cf345b218 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -864,13 +864,13 @@ let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } = compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 -module OutputSpecialize1 : Set.OrderedType = struct +module OutputSpecialize1 : (Set.OrderedType with type t = output_specialize1) = struct type t = output_specialize1 let compare = compare_output_specialize1 end -module BreakCtor : Set.OrderedType = struct +module BreakCtor : (Set.OrderedType with type t = output_break_ctor) = struct type t = output_break_ctor let compare = compare_output_break_ctor end @@ -917,24 +917,24 @@ let propagator_specialize1 : output_specialize1 propagator = module M (BlaBla : Set.OrderedType) = struct module AlreadySelected = Set.Make(BlaBla) -let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = - fun selector propagator -> - fun old_type_constraint dbs -> - (* TODO: thread some state to know which selector outputs were already seen *) - let already_selected = failwith "(?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? TODO)" in - match selector old_type_constraint dbs with - WasSelected selected_outputs -> - (* TODO: fold instead. *) - let selected_outputs = List.filter (fun elt -> AlreadySelected.mem elt already_selected) selected_outputs in - let blahblah = List.fold_left (fun acc elt -> AlreadySelected.add elt acc) already_selected selected_outputs in - let _______________________________________________________________________________________________________________________________________TODO = blahblah in - (* Call the propagation rule *) - let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in - let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in - (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) - (List.flatten new_constraints , List.flatten new_assignments) - | WasNotSelected -> - ([] , []) + let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = + fun selector propagator -> + fun old_type_constraint dbs -> + (* TODO: thread some state to know which selector outputs were already seen *) + let already_selected = failwith "(?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? TODO)" in + match selector old_type_constraint dbs with + WasSelected selected_outputs -> + (* TODO: fold instead. *) + let selected_outputs = List.filter (fun elt -> AlreadySelected.mem elt already_selected) selected_outputs in + let blahblah = List.fold_left (fun acc elt -> AlreadySelected.add elt acc) already_selected selected_outputs in + let _______________________________________________________________________________________________________________________________________TODO = blahblah in + (* Call the propagation rule *) + let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in + let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in + (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) + (List.flatten new_constraints , List.flatten new_assignments) + | WasNotSelected -> + ([] , []) end module M_break_ctor = M(BreakCtor) From 1dc690bbbabd8c2ef5e91ba635b45a9c950d4717 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 25 Oct 2019 22:30:20 -0400 Subject: [PATCH 25/39] Bugfix: only one propagator was called. Now they are all (both of them so far) called in turn. --- src/passes/4-typer/solver.ml | 72 +++++++++++++++++++++++------------- src/stages/ast_typed/misc.ml | 2 +- 2 files changed, 47 insertions(+), 27 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index cf345b218..eaaef767b 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -619,7 +619,7 @@ let lift f = { state = new_state ; list = List.flatten new_lists } (* TODO: move this to the List module *) -let named_fold_left f ~acc ~lst = List.fold_left (fun acc lst -> f ~acc ~lst) acc lst +let named_fold_left f ~acc ~lst = List.fold_left (fun acc elt -> f ~acc ~elt) acc lst module Fun = struct let id x = x end (* in stdlib as of 4.08, we're in 4.07 for now *) @@ -844,7 +844,7 @@ and compare_type_constraint = function | C_equation _ -> 1 | C_typeclass _ -> 1 | C_access_label (b1, b2, b3) -> compare_type_value a1 b1 compare_label a2 b2 compare_type_variable a3 b3) -let rec compare_type_constraint_list = compare_list compare_type_constraint +let compare_type_constraint_list = compare_list compare_type_constraint let compare_p_forall { binder = a1; constraints = a2; body = a3 } { binder = b1; constraints = b2; body = b3 } = @@ -884,13 +884,13 @@ let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector SC_Constructor c -> (* vice versa *) let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).poly in - let other_cs = List.filter (fun (x : c_poly_simpl) -> c.tv == x.tv) other_cs in (* TODO: does equality work in OCaml? *) + let other_cs = List.filter (fun (x : c_poly_simpl) -> c.tv = x.tv) other_cs in (* TODO: does equality work in OCaml? *) let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in WasSelected cs_pairs | SC_Alias _ -> WasNotSelected (* TODO: ??? *) | SC_Poly p -> let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in - let other_cs = List.filter (fun (x : c_constructor_simpl) -> x.tv == p.tv) other_cs in (* TODO: does equality work in OCaml? *) + let other_cs = List.filter (fun (x : c_constructor_simpl) -> x.tv = p.tv) other_cs in (* TODO: does equality work in OCaml? *) let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in WasSelected cs_pairs | SC_Typeclass _ -> WasNotSelected @@ -917,24 +917,22 @@ let propagator_specialize1 : output_specialize1 propagator = module M (BlaBla : Set.OrderedType) = struct module AlreadySelected = Set.Make(BlaBla) - let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t propagator -> 'a -> structured_dbs -> new_constraints * new_assignments = + let select_and_propagate : ('old_input, 'selector_output) selector -> BlaBla.t propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments = fun selector propagator -> - fun old_type_constraint dbs -> + fun already_selected old_type_constraint dbs -> (* TODO: thread some state to know which selector outputs were already seen *) - let already_selected = failwith "(?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? TODO)" in match selector old_type_constraint dbs with WasSelected selected_outputs -> (* TODO: fold instead. *) - let selected_outputs = List.filter (fun elt -> AlreadySelected.mem elt already_selected) selected_outputs in - let blahblah = List.fold_left (fun acc elt -> AlreadySelected.add elt acc) already_selected selected_outputs in - let _______________________________________________________________________________________________________________________________________TODO = blahblah in + let (already_selected , selected_outputs) = List.fold_left (fun (already_selected, selected_outputs) elt -> if AlreadySelected.mem elt already_selected then (AlreadySelected.add elt already_selected , elt :: selected_outputs) + else (already_selected , selected_outputs)) (already_selected , selected_outputs) selected_outputs in (* Call the propagation rule *) let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) - (List.flatten new_constraints , List.flatten new_assignments) + (already_selected , List.flatten new_constraints , List.flatten new_assignments) | WasNotSelected -> - ([] , []) + (already_selected, [] , []) end module M_break_ctor = M(BreakCtor) @@ -943,30 +941,52 @@ module M_specialize1 = M(OutputSpecialize1) let select_and_propagate_break_ctor = M_break_ctor.select_and_propagate selector_break_ctor propagator_break_ctor let select_and_propagate_specialize1 = M_specialize1.select_and_propagate selector_specialize1 propagator_specialize1 -let select_and_propagate_all' : type_constraint_simpl selector_input -> structured_dbs -> new_constraints * structured_dbs = - fun new_constraint dbs -> - let (new_constraints, new_assignments) = select_and_propagate_break_ctor new_constraint dbs in +type already_selected = { + break_ctor : M_break_ctor.AlreadySelected.t ; + specialize1 : M_specialize1.AlreadySelected.t ; +} + +(* Takes a constraint, applies all selector+propagator pairs to it. + Keeps track of which constraints have already been selected. *) +let select_and_propagate_all' : _ -> type_constraint_simpl selector_input -> structured_dbs -> _ * new_constraints * structured_dbs = + let aux sel_propag new_constraint (already_selected , new_constraints , dbs) = + let (already_selected , new_constraints', new_assignments) = sel_propag already_selected new_constraint dbs in let assignments = List.fold_left (fun acc ({tv;c_tag=_;tv_list=_} as ele) -> TypeVariableMap.update tv (function None -> Some ele | x -> x) acc) dbs.assignments new_assignments in let dbs = { dbs with assignments } in - (* let blah2 = select_ … in … *) - (* We should try each selector in turn. If multiple selectors work, what should we do? *) - (new_constraints , dbs) + (already_selected , new_constraints' @ new_constraints , dbs) + in + fun already_selected new_constraint dbs -> + (* The order in which the propagators are applied to constraints + is entirely accidental (dfs/bfs/something in-between). *) + let (already_selected , new_constraints , dbs) = (already_selected , [] , dbs) in -let rec select_and_propagate_all : type_constraint selector_input list -> structured_dbs -> structured_dbs = - fun new_constraints dbs -> + (* We must have a different already_selected for each selector, + so this is more verbose than a few uses of `aux'. *) + let (already_selected' , new_constraints , dbs) = aux select_and_propagate_break_ctor new_constraint (already_selected.break_ctor , new_constraints , dbs) in + let (already_selected , new_constraints , dbs) = ({already_selected with break_ctor = already_selected'}, new_constraints , dbs) in + + let (already_selected' , new_constraints , dbs) = aux select_and_propagate_specialize1 new_constraint (already_selected.specialize1 , new_constraints , dbs) in + let (already_selected , new_constraints , dbs) = ({already_selected with specialize1 = already_selected'}, new_constraints , dbs) in + + (already_selected , new_constraints , dbs) + +(* Takes a list of constraints, applies all selector+propagator pairs + to each in turn. *) +let rec select_and_propagate_all : _ -> type_constraint selector_input list -> structured_dbs -> structured_dbs = + fun already_selected new_constraints dbs -> match new_constraints with | [] -> dbs | new_constraint :: tl -> let { state = dbs ; list = modified_constraints } = normalizers new_constraint dbs in - let (new_constraints' , dbs) = + let (already_selected , new_constraints' , dbs) = List.fold_left - (fun (nc , dbs) c -> - let (new_constraints' , dbs) = select_and_propagate_all' c dbs in - (new_constraints' @ nc , dbs)) - ([] , dbs) + (fun (already_selected , nc , dbs) c -> + let (already_selected , new_constraints' , dbs) = select_and_propagate_all' already_selected c dbs in + (already_selected , new_constraints' @ nc , dbs)) + (already_selected , [] , dbs) modified_constraints in let new_constraints = new_constraints' @ tl in - select_and_propagate_all new_constraints dbs + select_and_propagate_all already_selected new_constraints dbs (* sub-component: constraint selector (worklist / dynamic queries) *) diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 723ba3100..105057905 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -346,7 +346,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m let%bind _ = assert_type_value_eq (result, result') in ok () | T_function _, _ -> fail @@ different_kinds a b - | T_variable x, T_variable y -> let _ = x == y in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding" + | T_variable x, T_variable y -> let _ = (x = y) in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding" | T_variable _, _ -> fail @@ different_kinds a b (* No information about what made it fail *) From 174c028406399bee644d2ec020b5db58833cd04d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Sun, 27 Oct 2019 23:24:21 -0400 Subject: [PATCH 26/39] Fixing issues in the new typer --- src/passes/4-typer/solver.ml | 109 +++++++++++++++++++------- src/passes/4-typer/typer.ml | 11 ++- src/passes/6-transpiler/transpiler.ml | 12 ++- src/stages/ast_typed/environment.ml | 5 +- src/stages/typesystem/misc.ml | 16 +++- src/test/test.ml | 3 +- src/union_find/dune | 2 +- 7 files changed, 120 insertions(+), 38 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index eaaef767b..b940422e0 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -7,6 +7,21 @@ module Wrap = struct module T = Ast_typed module O = Core + module Errors = struct + + let unknown_type_constructor (ctor : string) (te : T.type_value) () = + let title = (thunk "unknown type constructor") in + (* TODO: sanitize the "ctor" argument before displaying it. *) + let message () = ctor in + let data = [ + ("ctor" , fun () -> ctor) ; + ("expression" , fun () -> Format.asprintf "%a" T.PP.type_value te) ; + (* ("location" , fun () -> Format.asprintf "%a" Location.pp te.location) *) (* TODO *) + ] in + error ~data title message () + end + + type constraints = O.type_constraint list (* let add_type state t = *) @@ -30,16 +45,33 @@ module Wrap = struct | T_variable type_name -> P_variable type_name | T_constant (type_name , args) -> let csttag = Core.(match type_name with - | "arrow" -> C_arrow - | "option" -> C_option - | "tuple" -> C_tuple - | "map" -> C_map - | "list" -> C_list - | "set" -> C_set - | "unit" -> C_unit - | "bool" -> C_bool - | "string" -> C_string - | _ -> failwith "unknown type constructor") + | "arrow" -> C_arrow + | "option" -> C_option + | "tuple" -> C_tuple + (* record *) + (* variant *) + | "map" -> C_map + | "big_map" -> C_map + | "list" -> C_list + | "set" -> C_set + | "unit" -> C_unit + | "bool" -> C_bool + | "string" -> C_string + | "nat" -> C_nat + | "mutez" -> C_tez (* TODO: rename tez to mutez*) + | "timestamp" -> C_timestamp + | "int" -> C_int + | "address" -> C_address + | "bytes" -> C_bytes + | "key_hash" -> C_key_hash + | "key" -> C_key + | "signature" -> C_signature + | "operation" -> C_operation + | "contract" -> C_contract + | unknown -> + (* TODO: return a Trace.result *) + let _ = fail (fun () -> Errors.unknown_type_constructor unknown te ()) in + failwith ("unknown type constructor " ^ unknown)) in P_constant (csttag, List.map type_expression_to_type_value args) @@ -336,10 +368,6 @@ module UF = Union_find.Partition0.Make(TV) type unionfind = UF.t -let empty = UF.empty (* DEMO *) -let representative_toto = UF.repr "toto" empty (* DEMO *) -let merge x y = UF.equiv x y (* DEMO *) - (* end unionfind *) (* representant for an equivalence class of type variables *) @@ -521,7 +549,8 @@ let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) nor | _ -> (dbs , [new_constraint]) -let type_level_eval : type_value -> type_value * type_constraint list = failwith "implemented in other branch" +let type_level_eval : type_value -> type_value * type_constraint list = + fun tv -> Typesystem.Misc.Substitution.Pattern.eval_beta_root ~tv let check_applied ((reduced, _new_constraints) as x) = let () = match reduced with @@ -972,10 +1001,10 @@ let select_and_propagate_all' : _ -> type_constraint_simpl selector_input -> str (* Takes a list of constraints, applies all selector+propagator pairs to each in turn. *) -let rec select_and_propagate_all : _ -> type_constraint selector_input list -> structured_dbs -> structured_dbs = +let rec select_and_propagate_all : _ -> type_constraint selector_input list -> structured_dbs -> _ * structured_dbs = fun already_selected new_constraints dbs -> match new_constraints with - | [] -> dbs + | [] -> (already_selected, dbs) | new_constraint :: tl -> let { state = dbs ; list = modified_constraints } = normalizers new_constraint dbs in let (already_selected , new_constraints' , dbs) = @@ -998,21 +1027,40 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s (* Below is a draft *) +(* type state = { + * (\* when α-renaming x to y, we put them in the same union-find class *\) + * unification_vars : unionfind ; + * + * (\* assigns a value to the representant in the unionfind *\) + * assignments : type_value TypeVariableMap.t ; + * + * (\* constraints related to a type variable *\) + * constraints : constraints TypeVariableMap.t ; + * } *) + type state = { - (* when α-renaming x to y, we put them in the same union-find class *) - unification_vars : unionfind ; - - (* assigns a value to the representant in the unionfind *) - assignments : type_value TypeVariableMap.t ; - - (* constraints related to a type variable *) - constraints : constraints TypeVariableMap.t ; + structured_dbs : structured_dbs ; + already_selected : already_selected ; } -let initial_state : state = { - unification_vars = UF.empty ; - constraints = TypeVariableMap.empty ; - assignments = TypeVariableMap.empty ; +let initial_state : state = (* { + * unification_vars = UF.empty ; + * constraints = TypeVariableMap.empty ; + * assignments = TypeVariableMap.empty ; + * } *) +{ + structured_dbs = + { + all_constraints = [] ; (* type_constraint_simpl list *) + aliases = UF.empty ; (* unionfind *) + assignments = TypeVariableMap.empty; (* c_constructor_simpl TypeVariableMap.t *) + grouped_by_variable = TypeVariableMap.empty; (* constraints TypeVariableMap.t *) + cycle_detection_toposort = (); (* unit *) + } ; + already_selected = { + break_ctor = M_break_ctor.AlreadySelected.empty ; + specialize1 = M_specialize1.AlreadySelected.empty ; + } } (* This function is called when a program is fully compiled, and the @@ -1045,7 +1093,8 @@ let discard_state (_ : state) = () let aggregate_constraints : state -> type_constraint list -> state result = fun state newc -> (* TODO: Iterate over constraints *) let _todo = ignore (state, newc) in - failwith "TODO" + let (a, b) = select_and_propagate_all state.already_selected newc state.structured_dbs in + ok { already_selected = a ; structured_dbs = b } (*let { constraints ; eqv } = state in ok { constraints = constraints @ newc ; eqv }*) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 906766540..d743aa11f 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -920,7 +920,7 @@ let untype_type_value (t:O.type_value) : (I.type_expression) result = (* TODO: we ended up with two versions of type_program… ??? *) (* -Apply type_declaration on all the node of the AST_simplified from the root p +Apply type_declaration on all the node of the AST_simplified from the root p *) let type_program_returns_state (p:I.program) : (environment * Solver.state * O.program) result = let env = Ast_typed.Environment.full_empty in @@ -941,7 +941,14 @@ let type_program_returns_state (p:I.program) : (environment * Solver.state * O.p let type_program (p : I.program) : (O.program * Solver.state) result = let%bind (env, state, program) = type_program_returns_state p in - let program = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in program in + let subst_all = + let assignments = state.structured_dbs.assignments in + let aux (v : O.type_name) (expr : Solver.c_constructor_simpl) (p:O.program) = + Typesystem.Misc.Substitution.Pattern.program ~p ~v ~expr in + let p = SMap.fold aux assignments program in + p in + let program = subst_all in + let () = ignore env in (* TODO: shouldn't we use the `env` somewhere? *) ok (program, state) (* diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 9d53b6ea3..66e841689 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -102,6 +102,13 @@ them. please report this to the developers." in ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; ] in error ~data title content + + let not_found content = + let title () = "Not_found" in + let content () = content in + let data = [ + ] in + error ~data title content end open Errors @@ -539,7 +546,10 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind ty'_map = bind_map_smap transpile_type ty_map in let%bind path = record_access_to_lr ty' ty'_map prop in let path' = List.map snd path in - ok (Map.String.find prop ty_map, acc @ path') + let%bind prop_in_ty_map = trace_option + (Errors.not_found "acessing prop in ty_map [TODO: better error message]") + (Map.String.find_opt prop ty_map) in + ok (prop_in_ty_map, acc @ path') ) | Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet") in diff --git a/src/stages/ast_typed/environment.ml b/src/stages/ast_typed/environment.ml index 673f8645f..6281f0094 100644 --- a/src/stages/ast_typed/environment.ml +++ b/src/stages/ast_typed/environment.ml @@ -43,7 +43,10 @@ let get_constructor : string -> t -> (type_value * type_value) option = fun k x let aux = fun x -> let aux = fun (_type_name , x) -> match x.type_value' with - | T_sum m when Map.String.mem k m -> Some (Map.String.find k m , x) + | T_sum m -> + (match Map.String.find_opt k m with + Some km -> Some (km , x) + | None -> None) | _ -> None in List.find_map aux (Small.get_type_environment x) in diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 96baf197b..096a5cea8 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -6,10 +6,17 @@ module Substitution = struct module Pattern = struct + let rec declaration ~(d : Ast_typed.declaration Location.wrap) ~v ~expr : Ast_typed.declaration Location.wrap = + let _TODO = (d, v, expr) in + failwith "TODO: subst declaration" + + and program ~(p : Ast_typed.program) ~v ~expr : Ast_typed.program = + List.map (fun d -> declaration ~d ~v ~expr) p + (* Computes `P[v := expr]`. *) - let rec type_value ~tv ~v ~expr = + and type_value ~tv ~v ~expr = let self tv = type_value ~tv ~v ~expr in match tv with | P_variable v' when v' = v -> expr @@ -52,6 +59,13 @@ module Substitution = struct and typeclass ~tc ~v ~expr = List.map (List.map (fun tv -> type_value ~tv ~v ~expr)) tc + (* Performs beta-reduction at the root of the type *) + let eval_beta_root ~(tv : type_value) = + match tv with + P_apply (P_forall { binder; constraints; body }, arg) -> + let constraints = List.map (fun c -> constraint_ ~c ~v:binder ~expr:arg) constraints in + (type_value ~tv:body ~v:binder ~expr:arg , constraints) + | _ -> (tv , []) end end diff --git a/src/test/test.ml b/src/test/test.ml index a3709700e..aebade390 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -2,9 +2,8 @@ open Test_helpers - let () = - (* Printexc.record_backtrace true ; *) + Printexc.record_backtrace true ; run_test @@ test_suite "LIGO" [ Integration_tests.main ; Compiler_tests.main ; diff --git a/src/union_find/dune b/src/union_find/dune index a4c27e725..fad355c7a 100644 --- a/src/union_find/dune +++ b/src/union_find/dune @@ -12,5 +12,5 @@ (test (modules PartitionMain) - (libraries UnionFind) + (libraries union_find) (name PartitionMain)) From dcf5a975d444dd056694db7c763dac0424a5d29d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Mon, 28 Oct 2019 01:10:26 -0400 Subject: [PATCH 27/39] More of subst --- src/passes/4-typer/typer.ml | 10 +++++++--- src/stages/typesystem/misc.ml | 15 ++++++++++----- vendors/ligo-utils/simple-utils/trace.ml | 10 ++++++++++ 3 files changed, 27 insertions(+), 8 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index d743aa11f..f6f51b482 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -939,15 +939,19 @@ let type_program_returns_state (p:I.program) : (environment * Solver.state * O.p let () = ignore (env' , state') in ok (env', state', declarations) +module TSMap = TMap(Solver.TypeVariable) + let type_program (p : I.program) : (O.program * Solver.state) result = let%bind (env, state, program) = type_program_returns_state p in let subst_all = let assignments = state.structured_dbs.assignments in - let aux (v : O.type_name) (expr : Solver.c_constructor_simpl) (p:O.program) = + let aux (v : O.type_name) (expr : Solver.c_constructor_simpl) (p:O.program result) = + let%bind p = p in Typesystem.Misc.Substitution.Pattern.program ~p ~v ~expr in - let p = SMap.fold aux assignments program in + (* let p = TSMap.bind_fold_Map aux program assignments in *) (* TODO: Module magic: this does not work *) + let p = Solver.TypeVariableMap.fold aux assignments (ok program) in p in - let program = subst_all in + let%bind program = subst_all in let () = ignore env in (* TODO: shouldn't we use the `env` somewhere? *) ok (program, state) diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 096a5cea8..88b06e3fd 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -6,12 +6,17 @@ module Substitution = struct module Pattern = struct - let rec declaration ~(d : Ast_typed.declaration Location.wrap) ~v ~expr : Ast_typed.declaration Location.wrap = - let _TODO = (d, v, expr) in - failwith "TODO: subst declaration" + open Trace - and program ~(p : Ast_typed.program) ~v ~expr : Ast_typed.program = - List.map (fun d -> declaration ~d ~v ~expr) p + let rec declaration ~(d : Ast_typed.declaration Location.wrap) ~v ~expr : Ast_typed.declaration Location.wrap result = + Trace.bind_map_location (function + Ast_typed.Declaration_constant (e, (env1, env2)) -> + let _ = v, expr, failwith "TODO: subst" in + ok @@ Ast_typed.Declaration_constant (e, (env1, env2)) + ) d + + and program ~(p : Ast_typed.program) ~v ~expr : Ast_typed.program Trace.result = + Trace.bind_map_list (fun d -> declaration ~d ~v ~expr) p (* Computes `P[v := expr]`. diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 7a0326eec..e8f3b43eb 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -592,6 +592,16 @@ let bind_fold_list f init lst = in List.fold_left aux (ok init) lst +module TMap(X : Map.OrderedType) = struct + module MX = Map.Make(X) + let bind_fold_Map f init map = + let aux k v x = + x >>? fun x -> + f ~x ~k ~v + in + MX.fold aux map (ok init) +end + let bind_fold_pair f init (a,b) = let aux x y = x >>? fun x -> From 735bd8e668b77c6bec852007752f844a05477ca5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 29 Oct 2019 01:55:53 -0400 Subject: [PATCH 28/39] Implementing subst over the AST --- src/stages/ast_typed/combinators.ml | 1 - src/stages/ast_typed/types.ml | 1 - src/stages/typesystem/misc.ml | 135 +++++++++++++++++++++-- vendors/ligo-utils/simple-utils/trace.ml | 13 ++- 4 files changed, 140 insertions(+), 10 deletions(-) diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index af742b334..5700cb0f5 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -5,7 +5,6 @@ let make_t type_value' simplified = { type_value' ; simplified } let make_a_e ?(location = Location.generated) expression type_annotation environment = { expression ; type_annotation ; - dummy_field = () ; environment ; location ; } diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index b60632a0d..3ecf979d5 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -38,7 +38,6 @@ and annotated_expression = { type_annotation : tv ; environment : full_environment ; location : Location.t ; - dummy_field : unit ; } and named_expression = { diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 88b06e3fd..ee83bfd78 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -7,16 +7,137 @@ module Substitution = struct module Pattern = struct open Trace + module T = Ast_typed + module TSMap = Trace.TMap(String) - let rec declaration ~(d : Ast_typed.declaration Location.wrap) ~v ~expr : Ast_typed.declaration Location.wrap result = - Trace.bind_map_location (function - Ast_typed.Declaration_constant (e, (env1, env2)) -> - let _ = v, expr, failwith "TODO: subst" in - ok @@ Ast_typed.Declaration_constant (e, (env1, env2)) - ) d + type 'a w = 'a -> 'a result + + let todo = failwith "TODO" + + let rec rec_yes = true + and s_full_environment ~v ~expr : T.full_environment w = fun (a , b) -> + let%bind a = todo ~v ~expr a in + let%bind b = bind_map_list (todo ~v ~expr) b in + ok (a , b) + + and s_variable ~v ~expr : T.name w = fun var -> todo + + and s_type_variable ~v ~expr : T.name w = fun tvar -> todo + + and s_type_value ~v ~expr : T.type_value w = fun { type_value'; simplified } -> todo + + and s_expression ~v ~expr : T.expression w = function + | T.E_literal x -> + let%bind x = s_literal ~v ~expr x in + ok @@ T.E_literal x + | T.E_constant (var, vals) -> + let%bind var = s_variable ~v ~expr var in + let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in + ok @@ T.E_constant (var, vals) + | T.E_variable tv -> + let%bind tv = s_variable ~v ~expr tv in + ok @@ T.E_variable tv + | T.E_application (val1 , val2) -> + let%bind val1 = s_annotated_expression ~v ~expr val1 in + let%bind val2 = s_annotated_expression ~v ~expr val2 in + ok @@ T.E_application (val1 , val2) + | T.E_lambda { binder; body } -> + let%bind binder = s_variable ~v ~expr binder in + let%bind body = s_annotated_expression ~v ~expr body in + ok @@ T.E_lambda { binder; body } + | T.E_let_in { binder; rhs; result } -> + let%bind binder = s_variable ~v ~expr binder in + let%bind rhs = s_annotated_expression ~v ~expr rhs in + let%bind result = s_annotated_expression ~v ~expr result in + ok @@ T.E_let_in { binder; rhs; result } + | T.E_tuple vals -> + let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in + ok @@ T.E_tuple vals + | T.E_tuple_accessor (val_, i) -> + let%bind val_ = s_annotated_expression ~v ~expr val_ in + let i = i in + ok @@ T.E_tuple_accessor (val_, i) + | T.E_constructor (tvar, val_) -> + let%bind tvar = s_type_variable ~v ~expr tvar in + let%bind val_ = s_annotated_expression ~v ~expr val_ in + ok @@ T.E_constructor (tvar, val_) + | T.E_record aemap -> + let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> + let key = s_type_variable ~v ~expr key in + let val_ = s_annotated_expression ~v ~expr val_ in + ok @@ (key , val_)) aemap in + ok @@ T.E_record aemap + | T.E_record_accessor (val_, tvar) -> + let%bind val_ = s_annotated_expression ~v ~expr val_ in + let%bind tvar = s_type_variable ~v ~expr tvar in + ok @@ T.E_record_accessor (val_, tvar) + | T.E_map val_val_list -> + let%bind val_val_list = bind_map_list (fun (val1 , val2) -> + let%bind val1 = s_annotated_expression ~v ~expr val1 in + let%bind val2 = s_annotated_expression ~v ~expr val2 in + (val1 , val2) + ) val_val_list in + ok @@ T.E_map val_val_list + | T.E_big_map val_val_list -> + let%bind val_val_list = bind_map_list (fun (val1 , val2) -> + let%bind val1 = s_annotated_expression ~v ~expr val1 in + let%bind val2 = s_annotated_expression ~v ~expr val2 in + (val1 , val2) + ) val_val_list in + ok @@ T.E_big_map val_val_list + | T.E_list vals -> + let%bind vals = bind_map_list s_annotated_expression ~v ~expr vals in + ok @@ T.E_list vals + | T.E_set vals -> + let%bind vals = bind_map_list s_annotated_expression ~v ~expr vals in + ok @@ T.E_set vals + | T.E_look_up (val1, val2) -> + let%bind val1 = s_annotated_expression ~v ~expr val1 in + let%bind val2 = s_annotated_expression ~v ~expr val2 in + ok @@ T.E_look_up (val1 , val2) + | T.E_matching (val_ , matching) -> + let%bind val_ = s_annotated_expression ~v ~expr val_ in + let%bind matching = s_matching matching in + ok @@ T.E_matching (val_ , matching) + | T.E_sequence (val1, val2) -> + let%bind val1 = s_annotated_expression ~v ~expr val1 in + let%bind val2 = s_annotated_expression ~v ~expr val2 in + ok @@ T.E_sequence (val1 , val2) + | T.E_loop (val1, val2) -> + let%bind val1 = s_annotated_expression ~v ~expr val1 in + let%bind val2 = s_annotated_expression ~v ~expr val2 in + ok @@ T.E_loop (val1 , val2) + | T.E_assign (named_tval, access_path, val_) -> + let%bind named_tval = s_named_type_value ~v ~expr named_tval in + let%bind access_path = s_access_path ~v ~expr access_path in + let%bind val_ = s_annotated_expression ~v ~expr val_ in + ok @@ T.E_assign (named_tval, access_path, val_) + + and s_annotated_expression ~v ~expr : T.annotated_expression w = fun { expression; type_annotation; environment; location } -> + let%bind expression = s_expression ~v ~expr expression in + let%bind type_annotation = s_type_value ~v ~expr type_annotation in + let%bind environment = s_full_environment ~v ~expr environment in + let location = location in + ok T.{ expression; type_annotation; environment; location } + + and s_named_expression ~v ~expr : T.named_expression w = fun { name; annotated_expression } -> + let name = name in + let annotated_expression = s_annotated_expression annotated_expression in + ok T.{ name; annotated_expression } + + and s_declaration ~v ~expr : T.declaration w = + function + Ast_typed.Declaration_constant (e, (env1, env2)) -> + let e = s_named_expression ~v ~expr e in + let env1 = s_full_environment ~v ~expr env1 in + let env2 = s_full_environment ~v ~expr env2 in + ok @@ Ast_typed.Declaration_constant (e, (env1, env2)) + + and s_declaration_wrap ~v ~expr : T.declaration Location.wrap w = fun d -> + Trace.bind_map_location (s_declaration ~v ~expr) d and program ~(p : Ast_typed.program) ~v ~expr : Ast_typed.program Trace.result = - Trace.bind_map_list (fun d -> declaration ~d ~v ~expr) p + Trace.bind_map_list (s_declaration_wrap ~v ~expr) p (* Computes `P[v := expr]`. diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index e8f3b43eb..46981eae5 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -600,9 +600,20 @@ module TMap(X : Map.OrderedType) = struct f ~x ~k ~v in MX.fold aux map (ok init) + + let bind_map_Map f map = + let aux k v map' = + map' >>? fun map' -> + f ~k ~v >>? fun v' -> + ok @@ MX.update k (function + | None -> Some v' + | Some _ -> failwith "key collision, shouldn't happen in bind_map_Map") + map' + in + MX.fold aux map (ok MX.empty) end -let bind_fold_pair f init (a,b) = +let bind_fold_pair f init (a,b) = let aux x y = x >>? fun x -> f x y From 3f0b9346a5bc3411f76e2af3bdd45bfcc40eb953 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 29 Oct 2019 20:14:42 -0400 Subject: [PATCH 29/39] More but not enough of the fold. Filled in holes with failwith, need to implement enough that it passes a test. --- src/passes/4-typer/solver.ml | 1 + src/stages/typesystem/misc.ml | 102 ++++++++++++++++++++++++++-------- 2 files changed, 79 insertions(+), 24 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index b940422e0..fc95a2885 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -419,6 +419,7 @@ type structured_dbs = { (* assignments (passive data structure). Now: just a map from unification vars to types (pb: what about partial types?) maybe just local assignments (allow only vars as children of pair(α,β)) *) + (* TODO: the rhs of the map should not repeat the variable name. *) assignments : c_constructor_simpl TypeVariableMap.t ; grouped_by_variable : constraints TypeVariableMap.t ; (* map from (unionfind) variables to constraints containing them *) cycle_detection_toposort : unit ; (* example of structured db that we'll add later *) diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index ee83bfd78..8223c192a 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -12,19 +12,69 @@ module Substitution = struct type 'a w = 'a -> 'a result - let todo = failwith "TODO" - let rec rec_yes = true + and s_environment_element_definition ~v ~expr = function + | T.ED_binder -> ok @@ T.ED_binder + | T.ED_declaration (val_, free_variables) -> + let%bind val_ = s_annotated_expression ~v ~expr val_ in + let%bind free_variables = bind_map_list (s_type_variable ~v ~expr) free_variables in + ok @@ T.ED_declaration (val_, free_variables) + and s_environment ~v ~expr = fun lst -> + bind_map_list (fun (type_variable, T.{ type_value; source_environment; definition }) -> + let _ = type_value in + let%bind type_variable = s_type_variable ~v ~expr type_variable in + let%bind type_value = s_type_value ~v ~expr type_value in + let%bind source_environment = s_full_environment ~v ~expr source_environment in + let%bind definition = s_environment_element_definition ~v ~expr definition in + ok @@ (type_variable, T.{ type_value; source_environment; definition }) + ) lst + and s_type_environment ~v ~expr : T.type_environment w = fun _ -> + let _TODO = (v, expr) in + failwith "TODO: subst: unimplemented case s_type_environment" + and s_small_environment ~v ~expr : T.small_environment w = fun (environment, type_environment) -> + let%bind environment = s_environment ~v ~expr environment in + let%bind type_environment = s_type_environment ~v ~expr type_environment in + ok @@ (environment, type_environment) and s_full_environment ~v ~expr : T.full_environment w = fun (a , b) -> - let%bind a = todo ~v ~expr a in - let%bind b = bind_map_list (todo ~v ~expr) b in + let%bind a = s_small_environment ~v ~expr a in + let%bind b = bind_map_list (s_small_environment ~v ~expr) b in ok (a , b) - and s_variable ~v ~expr : T.name w = fun var -> todo + and s_variable ~v ~expr : T.name w = fun var -> + let () = ignore (v, expr) in + ok var - and s_type_variable ~v ~expr : T.name w = fun tvar -> todo + and s_type_variable ~v ~expr : T.name w = fun tvar -> + let _TODO = ignore (v, expr, tvar) in + failwith "TODO: subst: unimplemented case s_type_variable" + (* if String.equal tvar v then + * expr + * else + * ok tvar *) - and s_type_value ~v ~expr : T.type_value w = fun { type_value'; simplified } -> todo + and s_type_value' ~v ~expr : T.type_value' w = fun _ -> + let _TODO = (v, expr) in + failwith "TODO: subst: unimplemented case s_type_value'" + and s_type_expression ~v ~expr : Ast_simplified.type_expression w = fun _ -> + let _TODO = (v, expr) in + failwith "TODO: subst: unimplemented case s_type_expression" + + and s_type_value ~v ~expr : T.type_value w = fun { type_value'; simplified } -> + let%bind type_value' = s_type_value' ~v ~expr type_value' in + let%bind simplified = bind_map_option (s_type_expression ~v ~expr) simplified in + ok @@ T.{ type_value'; simplified } + and s_literal ~v ~expr : T.literal w = fun _ -> + let _TODO = v, expr in + failwith "TODO: subst: unimplemented case s_literal" + and s_matching_expr ~v ~expr : T.matching_expr w = fun _ -> + let _TODO = v, expr in + failwith "TODO: subst: unimplemented case s_matching" + and s_named_type_value ~v ~expr : T.named_type_value w = fun _ -> + let _TODO = v, expr in + failwith "TODO: subst: unimplemented case s_named_type_value" + and s_access_path ~v ~expr : T.access_path w = fun _ -> + let _TODO = v, expr in + failwith "TODO: subst: unimplemented case s_access_path" and s_expression ~v ~expr : T.expression w = function | T.E_literal x -> @@ -62,11 +112,13 @@ module Substitution = struct let%bind val_ = s_annotated_expression ~v ~expr val_ in ok @@ T.E_constructor (tvar, val_) | T.E_record aemap -> - let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> - let key = s_type_variable ~v ~expr key in - let val_ = s_annotated_expression ~v ~expr val_ in - ok @@ (key , val_)) aemap in - ok @@ T.E_record aemap + let _TODO = aemap in + failwith "TODO: subst in record" + (* let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> + * let key = s_type_variable ~v ~expr key in + * let val_ = s_annotated_expression ~v ~expr val_ in + * ok @@ (key , val_)) aemap in + * ok @@ T.E_record aemap *) | T.E_record_accessor (val_, tvar) -> let%bind val_ = s_annotated_expression ~v ~expr val_ in let%bind tvar = s_type_variable ~v ~expr tvar in @@ -75,29 +127,29 @@ module Substitution = struct let%bind val_val_list = bind_map_list (fun (val1 , val2) -> let%bind val1 = s_annotated_expression ~v ~expr val1 in let%bind val2 = s_annotated_expression ~v ~expr val2 in - (val1 , val2) + ok @@ (val1 , val2) ) val_val_list in ok @@ T.E_map val_val_list | T.E_big_map val_val_list -> let%bind val_val_list = bind_map_list (fun (val1 , val2) -> let%bind val1 = s_annotated_expression ~v ~expr val1 in let%bind val2 = s_annotated_expression ~v ~expr val2 in - (val1 , val2) + ok @@ (val1 , val2) ) val_val_list in ok @@ T.E_big_map val_val_list | T.E_list vals -> - let%bind vals = bind_map_list s_annotated_expression ~v ~expr vals in + let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in ok @@ T.E_list vals | T.E_set vals -> - let%bind vals = bind_map_list s_annotated_expression ~v ~expr vals in + let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in ok @@ T.E_set vals | T.E_look_up (val1, val2) -> let%bind val1 = s_annotated_expression ~v ~expr val1 in let%bind val2 = s_annotated_expression ~v ~expr val2 in ok @@ T.E_look_up (val1 , val2) - | T.E_matching (val_ , matching) -> + | T.E_matching (val_ , matching_expr) -> let%bind val_ = s_annotated_expression ~v ~expr val_ in - let%bind matching = s_matching matching in + let%bind matching = s_matching_expr ~v ~expr matching_expr in ok @@ T.E_matching (val_ , matching) | T.E_sequence (val1, val2) -> let%bind val1 = s_annotated_expression ~v ~expr val1 in @@ -121,22 +173,24 @@ module Substitution = struct ok T.{ expression; type_annotation; environment; location } and s_named_expression ~v ~expr : T.named_expression w = fun { name; annotated_expression } -> - let name = name in - let annotated_expression = s_annotated_expression annotated_expression in + let%bind name = s_type_variable ~v ~expr name in + let%bind annotated_expression = s_annotated_expression ~v ~expr annotated_expression in ok T.{ name; annotated_expression } and s_declaration ~v ~expr : T.declaration w = function Ast_typed.Declaration_constant (e, (env1, env2)) -> - let e = s_named_expression ~v ~expr e in - let env1 = s_full_environment ~v ~expr env1 in - let env2 = s_full_environment ~v ~expr env2 in + let%bind e = s_named_expression ~v ~expr e in + let%bind env1 = s_full_environment ~v ~expr env1 in + let%bind env2 = s_full_environment ~v ~expr env2 in ok @@ Ast_typed.Declaration_constant (e, (env1, env2)) and s_declaration_wrap ~v ~expr : T.declaration Location.wrap w = fun d -> Trace.bind_map_location (s_declaration ~v ~expr) d - and program ~(p : Ast_typed.program) ~v ~expr : Ast_typed.program Trace.result = + (* Replace the type variable ~v with ~expr everywhere within the + program ~p. TODO: issues with scoping/shadowing. *) + and program ~(p : Ast_typed.program) ~(v:type_variable) ~expr : Ast_typed.program Trace.result = Trace.bind_map_list (s_declaration_wrap ~v ~expr) p (* From c0397f68a09afa1c766c1171fd4fc1bbe772c834 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 30 Oct 2019 12:50:19 -0400 Subject: [PATCH 30/39] Wrap type names with a constructor Type_name, so that merlin does not think that all strings are type names --- src/passes/4-typer/solver.ml | 80 ++++++++++++------------- src/passes/4-typer/typer.ml | 10 ++-- src/passes/6-transpiler/transpiler.ml | 36 +++++------ src/passes/6-transpiler/untranspiler.ml | 36 +++++------ src/stages/ast_typed/PP.ml | 6 +- src/stages/ast_typed/combinators.ml | 74 +++++++++++------------ src/stages/ast_typed/combinators.mli | 2 +- src/stages/ast_typed/misc.ml | 2 +- src/stages/ast_typed/types.ml | 2 +- src/stages/typesystem/misc.ml | 2 +- 10 files changed, 125 insertions(+), 125 deletions(-) diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer/solver.ml index fc95a2885..e132784ee 100644 --- a/src/passes/4-typer/solver.ml +++ b/src/passes/4-typer/solver.ml @@ -42,8 +42,8 @@ module Wrap = struct P_constant (C_record, Map.String.to_list @@ Map.String.map type_expression_to_type_value kvmap) | T_function (arg , ret) -> P_constant (C_arrow, List.map type_expression_to_type_value [ arg ; ret ]) - | T_variable type_name -> P_variable type_name - | T_constant (type_name , args) -> + | T_variable (Type_name type_name) -> P_variable type_name + | T_constant (Type_name type_name , args) -> let csttag = Core.(match type_name with | "arrow" -> C_arrow | "option" -> C_option @@ -105,15 +105,15 @@ module Wrap = struct let type_name = Core.fresh_type_variable () in [] , type_name - let variable : I.name -> T.type_value -> (constraints * O.type_variable) = fun _name expr -> + let variable : I.name -> T.type_value -> (constraints * T.type_name) = fun _name expr -> let pattern = type_expression_to_type_value expr in let type_name = Core.fresh_type_variable () in - [C_equation (P_variable (type_name) , pattern)] , type_name + [C_equation (P_variable (type_name) , pattern)] , Type_name type_name - let literal : T.type_value -> (constraints * O.type_variable) = fun t -> + let literal : T.type_value -> (constraints * T.type_name) = fun t -> let pattern = type_expression_to_type_value t in let type_name = Core.fresh_type_variable () in - [C_equation (P_variable (type_name) , pattern)] , type_name + [C_equation (P_variable (type_name) , pattern)] , Type_name type_name (* let literal_bool : unit -> (constraints * O.type_variable) = fun () -> @@ -127,11 +127,11 @@ module Wrap = struct [C_equation (P_variable (type_name) , pattern)] , type_name *) - let tuple : T.type_value list -> (constraints * O.type_variable) = fun tys -> + let tuple : T.type_value list -> (constraints * T.type_name) = fun tys -> let patterns = List.map type_expression_to_type_value tys in let pattern = O.(P_constant (C_tuple , patterns)) in let type_name = Core.fresh_type_variable () in - [C_equation (P_variable (type_name) , pattern)] , type_name + [C_equation (P_variable (type_name) , pattern)] , Type_name type_name (* let t_tuple = ('label:int, 'v) … -> record ('label : 'v) … *) (* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *) @@ -158,15 +158,15 @@ module Wrap = struct end (* TODO: I think we should take an I.expression for the base+label *) - let access_label ~(base : T.type_value) ~(label : O.label) : (constraints * O.type_variable) = + let access_label ~(base : T.type_value) ~(label : O.label) : (constraints * T.type_name) = let base' = type_expression_to_type_value base in let expr_type = Core.fresh_type_variable () in - [O.C_access_label (base' , label , expr_type)] , expr_type + [O.C_access_label (base' , label , expr_type)] , Type_name expr_type let access_int ~base ~index = access_label ~base ~label:(L_int index) let access_string ~base ~property = access_label ~base ~label:(L_string property) - let access_map : base:T.type_value -> key:T.type_value -> (constraints * O.type_variable) = + let access_map : base:T.type_value -> key:T.type_value -> (constraints * T.type_name) = let mk_map_type key_type element_type = O.P_constant O.(C_map , [P_variable element_type; P_variable key_type]) in fun ~base ~key -> @@ -178,10 +178,10 @@ module Wrap = struct let expr_type = Core.fresh_type_variable () in O.[C_equation (base' , base_expected); C_equation (key' , P_variable key_type); - C_equation (P_variable expr_type , P_variable element_type)] , expr_type + C_equation (P_variable expr_type , P_variable element_type)] , Type_name expr_type let constructor - : T.type_value -> T.type_value -> T.type_value -> (constraints * O.type_variable) + : T.type_value -> T.type_value -> T.type_value -> (constraints * T.type_name) = fun t_arg c_arg sum -> let t_arg = type_expression_to_type_value t_arg in let c_arg = type_expression_to_type_value c_arg in @@ -190,14 +190,14 @@ module Wrap = struct [ C_equation (P_variable (whole_expr) , sum) ; C_equation (t_arg , c_arg) - ] , whole_expr + ] , Type_name whole_expr - let record : T.type_value I.type_name_map -> (constraints * O.type_variable) = fun fields -> + let record : T.type_value I.type_name_map -> (constraints * T.type_name) = fun fields -> let record_type = type_expression_to_type_value (T.t_record fields ()) in let whole_expr = Core.fresh_type_variable () in - [C_equation (P_variable whole_expr , record_type)] , whole_expr + [C_equation (P_variable whole_expr , record_type)] , Type_name whole_expr - let collection : O.constant_tag -> T.type_value list -> (constraints * O.type_variable) = + let collection : O.constant_tag -> T.type_value list -> (constraints * T.type_name) = fun ctor element_tys -> let elttype = O.P_variable (Core.fresh_type_variable ()) in let aux elt = @@ -207,12 +207,12 @@ module Wrap = struct let whole_expr = Core.fresh_type_variable () in O.[ C_equation (P_variable whole_expr , O.P_constant (ctor , [elttype])) - ] @ equations , whole_expr + ] @ equations , Type_name whole_expr let list = collection O.C_list let set = collection O.C_set - let map : (T.type_value * T.type_value) list -> (constraints * O.type_variable) = + let map : (T.type_value * T.type_value) list -> (constraints * T.type_name) = fun kv_tys -> let k_type = O.P_variable (Core.fresh_type_variable ()) in let v_type = O.P_variable (Core.fresh_type_variable ()) in @@ -227,9 +227,9 @@ module Wrap = struct let whole_expr = Core.fresh_type_variable () in O.[ C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type])) - ] @ equations_k @ equations_v , whole_expr + ] @ equations_k @ equations_v , Type_name whole_expr - let big_map : (T.type_value * T.type_value) list -> (constraints * O.type_variable) = + let big_map : (T.type_value * T.type_value) list -> (constraints * T.type_name) = fun kv_tys -> let k_type = O.P_variable (Core.fresh_type_variable ()) in let v_type = O.P_variable (Core.fresh_type_variable ()) in @@ -246,18 +246,18 @@ module Wrap = struct (* TODO: this doesn't tag big_maps uniquely (i.e. if two big_map have the same type, they can be swapped. *) C_equation (P_variable whole_expr , O.P_constant (C_big_map , [k_type ; v_type])) - ] @ equations_k @ equations_v , whole_expr + ] @ equations_k @ equations_v , Type_name whole_expr - let application : T.type_value -> T.type_value -> (constraints * O.type_variable) = + let application : T.type_value -> T.type_value -> (constraints * T.type_name) = fun f arg -> let whole_expr = Core.fresh_type_variable () in let f' = type_expression_to_type_value f in let arg' = type_expression_to_type_value arg in O.[ C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr])) - ] , whole_expr + ] , Type_name whole_expr - let look_up : T.type_value -> T.type_value -> (constraints * O.type_variable) = + let look_up : T.type_value -> T.type_value -> (constraints * T.type_name) = fun ds ind -> let ds' = type_expression_to_type_value ds in let ind' = type_expression_to_type_value ind in @@ -266,9 +266,9 @@ module Wrap = struct O.[ C_equation (ds' , P_constant (C_map, [ind' ; P_variable v])) ; C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v])) - ] , whole_expr + ] , Type_name whole_expr - let sequence : T.type_value -> T.type_value -> (constraints * O.type_variable) = + let sequence : T.type_value -> T.type_value -> (constraints * T.type_name) = fun a b -> let a' = type_expression_to_type_value a in let b' = type_expression_to_type_value b in @@ -276,9 +276,9 @@ module Wrap = struct O.[ C_equation (a' , P_constant (C_unit , [])) ; C_equation (b' , P_variable whole_expr) - ] , whole_expr + ] , Type_name whole_expr - let loop : T.type_value -> T.type_value -> (constraints * O.type_variable) = + let loop : T.type_value -> T.type_value -> (constraints * T.type_name) = fun expr body -> let expr' = type_expression_to_type_value expr in let body' = type_expression_to_type_value body in @@ -287,9 +287,9 @@ module Wrap = struct C_equation (expr' , P_constant (C_bool , [])) ; C_equation (body' , P_constant (C_unit , [])) ; C_equation (P_variable whole_expr , P_constant (C_unit , [])) - ] , whole_expr + ] , Type_name whole_expr - let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * O.type_variable) = + let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * T.type_name) = fun rhs rhs_tv_opt result -> let rhs' = type_expression_to_type_value rhs in let result' = type_expression_to_type_value result in @@ -299,9 +299,9 @@ module Wrap = struct let whole_expr = Core.fresh_type_variable () in O.[ C_equation (result' , P_variable whole_expr) - ] @ rhs_tv_opt', whole_expr + ] @ rhs_tv_opt', Type_name whole_expr - let assign : T.type_value -> T.type_value -> (constraints * O.type_variable) = + let assign : T.type_value -> T.type_value -> (constraints * T.type_name) = fun v e -> let v' = type_expression_to_type_value v in let e' = type_expression_to_type_value e in @@ -309,9 +309,9 @@ module Wrap = struct O.[ C_equation (v' , e') ; C_equation (P_variable whole_expr , P_constant (C_unit , [])) - ] , whole_expr + ] , Type_name whole_expr - let annotation : T.type_value -> T.type_value -> (constraints * O.type_variable) = + let annotation : T.type_value -> T.type_value -> (constraints * T.type_name) = fun e annot -> let e' = type_expression_to_type_value e in let annot' = type_expression_to_type_value annot in @@ -319,14 +319,14 @@ module Wrap = struct O.[ C_equation (e' , annot') ; C_equation (e' , P_variable whole_expr) - ] , whole_expr + ] , Type_name whole_expr - let matching : T.type_value list -> (constraints * O.type_variable) = + let matching : T.type_value list -> (constraints * T.type_name) = fun es -> let whole_expr = Core.fresh_type_variable () in let type_values = (List.map type_expression_to_type_value es) in let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values - in cs, whole_expr + in cs, Type_name whole_expr let fresh_binder () = Core.fresh_type_variable () @@ -335,7 +335,7 @@ module Wrap = struct : T.type_value -> T.type_value option -> T.type_value option -> - (constraints * O.type_variable) = + (constraints * T.type_name) = fun fresh arg body -> let whole_expr = Core.fresh_type_variable () in let unification_arg = Core.fresh_type_variable () in @@ -351,7 +351,7 @@ module Wrap = struct C_equation (P_variable whole_expr , P_constant (C_arrow , [P_variable unification_arg ; P_variable unification_body])) - ] @ arg' @ body' , whole_expr + ] @ arg' @ body' , Type_name whole_expr end diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index f6f51b482..6a82ba9a6 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -389,7 +389,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = ok tv | T_constant (cst, lst) -> let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in - return (T_constant(cst, lst')) + return (T_constant(Type_name cst, lst')) and type_expression : environment -> Solver.state -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ae -> let open Solver in @@ -867,7 +867,7 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate let%bind input_type' = bind_map_option (evaluate_type e) input_type in let%bind output_type' = bind_map_option (evaluate_type e) output_type in - let fresh : O.type_value = t_variable (Wrap.fresh_binder ()) () in + let fresh : O.type_value = t_variable (Type_name (Wrap.fresh_binder ())) () in let e' = Environment.add_ez_binder (fst binder) fresh e in let%bind (result , state') = type_expression e' state result in @@ -945,7 +945,7 @@ let type_program (p : I.program) : (O.program * Solver.state) result = let%bind (env, state, program) = type_program_returns_state p in let subst_all = let assignments = state.structured_dbs.assignments in - let aux (v : O.type_name) (expr : Solver.c_constructor_simpl) (p:O.program result) = + let aux (v : string (* this string is a type_name or type_variable I think *)) (expr : Solver.c_constructor_simpl) (p:O.program result) = let%bind p = p in Typesystem.Misc.Substitution.Pattern.program ~p ~v ~expr in (* let p = TSMap.bind_fold_Map aux program assignments in *) (* TODO: Module magic: this does not work *) @@ -991,10 +991,10 @@ let rec untype_type_expression (t:O.type_value) : (I.type_expression) result = | O.T_record x -> let%bind x' = bind_map_smap untype_type_expression x in ok @@ I.T_record x' - | O.T_constant (tag, args) -> + | O.T_constant (Type_name tag, args) -> let%bind args' = bind_map_list untype_type_expression args in ok @@ I.T_constant (tag, args') - | O.T_variable name -> ok @@ I.T_variable name (* TODO: is this the right conversion? *) + | O.T_variable (Type_name name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *) | O.T_function (a , b) -> let%bind a' = untype_type_expression a in let%bind b' = untype_type_expression b in diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 66e841689..7c7cd3e1c 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -114,36 +114,36 @@ open Errors let rec transpile_type (t:AST.type_value) : type_value result = match t.type_value' with - | T_variable name -> fail @@ no_type_variable name - | T_constant ("bool", []) -> ok (T_base Base_bool) - | T_constant ("int", []) -> ok (T_base Base_int) - | T_constant ("nat", []) -> ok (T_base Base_nat) - | T_constant ("tez", []) -> ok (T_base Base_tez) - | T_constant ("string", []) -> ok (T_base Base_string) - | T_constant ("bytes", []) -> ok (T_base Base_bytes) - | T_constant ("address", []) -> ok (T_base Base_address) - | T_constant ("timestamp", []) -> ok (T_base Base_timestamp) - | T_constant ("unit", []) -> ok (T_base Base_unit) - | T_constant ("operation", []) -> ok (T_base Base_operation) - | T_constant ("contract", [x]) -> + | T_variable (Type_name name) -> fail @@ no_type_variable name + | T_constant (Type_name "bool", []) -> ok (T_base Base_bool) + | T_constant (Type_name "int", []) -> ok (T_base Base_int) + | T_constant (Type_name "nat", []) -> ok (T_base Base_nat) + | T_constant (Type_name "tez", []) -> ok (T_base Base_tez) + | T_constant (Type_name "string", []) -> ok (T_base Base_string) + | T_constant (Type_name "bytes", []) -> ok (T_base Base_bytes) + | T_constant (Type_name "address", []) -> ok (T_base Base_address) + | T_constant (Type_name "timestamp", []) -> ok (T_base Base_timestamp) + | T_constant (Type_name "unit", []) -> ok (T_base Base_unit) + | T_constant (Type_name "operation", []) -> ok (T_base Base_operation) + | T_constant (Type_name "contract", [x]) -> let%bind x' = transpile_type x in ok (T_contract x') - | T_constant ("map", [key;value]) -> + | T_constant (Type_name "map", [key;value]) -> let%bind kv' = bind_map_pair transpile_type (key, value) in ok (T_map kv') - | T_constant ("big_map", [key;value] ) -> + | T_constant (Type_name "big_map", [key;value] ) -> let%bind kv' = bind_map_pair transpile_type (key, value) in ok (T_big_map kv') - | T_constant ("list", [t]) -> + | T_constant (Type_name "list", [t]) -> let%bind t' = transpile_type t in ok (T_list t') - | T_constant ("set", [t]) -> + | T_constant (Type_name "set", [t]) -> let%bind t' = transpile_type t in ok (T_set t') - | T_constant ("option", [o]) -> + | T_constant (Type_name "option", [o]) -> let%bind o' = transpile_type o in ok (T_option o') - | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name + | T_constant (Type_name name , _lst) -> fail @@ unrecognized_type_constant name (* TODO hmm *) | T_sum m -> let node = Append_tree.of_list @@ kv_list_of_map m in diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml index fb5a7c97b..86b2964e2 100644 --- a/src/passes/6-transpiler/untranspiler.ml +++ b/src/passes/6-transpiler/untranspiler.ml @@ -53,61 +53,61 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression let open! AST in let return e = ok (make_a_e_empty e t) in match t.type_value' with - | T_constant ("unit", []) -> ( + | T_constant (Type_name "unit", []) -> ( let%bind () = trace_strong (wrong_mini_c_value "unit" v) @@ get_unit v in return (E_literal Literal_unit) ) - | T_constant ("bool", []) -> ( + | T_constant (Type_name "bool", []) -> ( let%bind b = trace_strong (wrong_mini_c_value "bool" v) @@ get_bool v in return (E_literal (Literal_bool b)) ) - | T_constant ("int", []) -> ( + | T_constant (Type_name "int", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "int" v) @@ get_int v in return (E_literal (Literal_int n)) ) - | T_constant ("nat", []) -> ( + | T_constant (Type_name "nat", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "nat" v) @@ get_nat v in return (E_literal (Literal_nat n)) ) - | T_constant ("timestamp", []) -> ( + | T_constant (Type_name "timestamp", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "timestamp" v) @@ get_timestamp v in return (E_literal (Literal_timestamp n)) ) - | T_constant ("tez", []) -> ( + | T_constant (Type_name "tez", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "tez" v) @@ get_mutez v in return (E_literal (Literal_mutez n)) ) - | T_constant ("string", []) -> ( + | T_constant (Type_name "string", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "string" v) @@ get_string v in return (E_literal (Literal_string n)) ) - | T_constant ("bytes", []) -> ( + | T_constant (Type_name "bytes", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "bytes" v) @@ get_bytes v in return (E_literal (Literal_bytes n)) ) - | T_constant ("address", []) -> ( + | T_constant (Type_name "address", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "address" v) @@ get_string v in return (E_literal (Literal_address n)) ) - | T_constant ("option", [o]) -> ( + | T_constant (Type_name "option", [o]) -> ( let%bind opt = trace_strong (wrong_mini_c_value "option" v) @@ get_option v in @@ -117,7 +117,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression let%bind s' = untranspile s o in ok (e_a_empty_some s') ) - | T_constant ("map", [k_ty;v_ty]) -> ( + | T_constant (Type_name "map", [k_ty;v_ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "map" v) @@ get_map v in @@ -129,7 +129,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_map lst') ) - | T_constant ("big_map", [k_ty;v_ty]) -> ( + | T_constant (Type_name "big_map", [k_ty;v_ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "big_map" v) @@ get_big_map v in @@ -141,7 +141,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_big_map lst') ) - | T_constant ("list", [ty]) -> ( + | T_constant (Type_name "list", [ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "list" v) @@ get_list v in @@ -150,7 +150,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_list lst') ) - | T_constant ("set", [ty]) -> ( + | T_constant (Type_name "set", [ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "set" v) @@ get_set v in @@ -159,15 +159,15 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_set lst') ) - | T_constant ("contract" , [_ty]) -> + | T_constant (Type_name "contract" , [_ty]) -> fail @@ bad_untranspile "contract" v - | T_constant ("operation" , []) -> ( + | T_constant (Type_name "operation" , []) -> ( let%bind op = trace_strong (wrong_mini_c_value "operation" v) @@ get_operation v in return (E_literal (Literal_operation op)) ) - | T_constant (name , _lst) -> + | T_constant (Type_name name , _lst) -> fail @@ unknown_untranspile name v | T_sum m -> let lst = kv_list_of_map m in @@ -203,4 +203,4 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression let m' = map_of_kv_list lst in return (E_record m') | T_function _ -> fail @@ bad_untranspile "function" v - | T_variable v -> return (E_variable v) + | T_variable (Type_name v) -> return (E_variable v) diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index d77334e87..b8533fc5b 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -12,9 +12,9 @@ let rec type_value' ppf (tv':type_value') : unit = | T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_value) m | T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_value) m | T_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b - | T_constant (c, []) -> fprintf ppf "%s" c - | T_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n - | T_variable name -> fprintf ppf "%s" name + | T_constant (Type_name c, []) -> fprintf ppf "%s" c + | T_constant (Type_name c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n + | T_variable (Type_name name) -> fprintf ppf "%s" name and type_value ppf (tv:type_value) : unit = type_value' ppf tv.type_value' diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 5700cb0f5..d2f562e47 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -11,24 +11,24 @@ let make_a_e ?(location = Location.generated) expression type_annotation environ let make_n_e name a_e = { name ; annotated_expression = a_e } let make_n_t type_name type_value = { type_name ; type_value } -let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s -let t_string ?s () : type_value = make_t (T_constant ("string", [])) s -let t_bytes ?s () : type_value = make_t (T_constant ("bytes", [])) s -let t_key ?s () : type_value = make_t (T_constant ("key", [])) s -let t_key_hash ?s () : type_value = make_t (T_constant ("key_hash", [])) s -let t_int ?s () : type_value = make_t (T_constant ("int", [])) s -let t_address ?s () : type_value = make_t (T_constant ("address", [])) s -let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s -let t_nat ?s () : type_value = make_t (T_constant ("nat", [])) s -let t_mutez ?s () : type_value = make_t (T_constant ("tez", [])) s -let t_timestamp ?s () : type_value = make_t (T_constant ("timestamp", [])) s -let t_unit ?s () : type_value = make_t (T_constant ("unit", [])) s -let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s +let t_bool ?s () : type_value = make_t (T_constant (Type_name "bool", [])) s +let t_string ?s () : type_value = make_t (T_constant (Type_name "string", [])) s +let t_bytes ?s () : type_value = make_t (T_constant (Type_name "bytes", [])) s +let t_key ?s () : type_value = make_t (T_constant (Type_name "key", [])) s +let t_key_hash ?s () : type_value = make_t (T_constant (Type_name "key_hash", [])) s +let t_int ?s () : type_value = make_t (T_constant (Type_name "int", [])) s +let t_address ?s () : type_value = make_t (T_constant (Type_name "address", [])) s +let t_operation ?s () : type_value = make_t (T_constant (Type_name "operation", [])) s +let t_nat ?s () : type_value = make_t (T_constant (Type_name "nat", [])) s +let t_mutez ?s () : type_value = make_t (T_constant (Type_name "tez", [])) s +let t_timestamp ?s () : type_value = make_t (T_constant (Type_name "timestamp", [])) s +let t_unit ?s () : type_value = make_t (T_constant (Type_name "unit", [])) s +let t_option o ?s () : type_value = make_t (T_constant (Type_name "option", [o])) s let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s let t_variable t ?s () : type_value = make_t (T_variable t) s -let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s -let t_set t ?s () : type_value = make_t (T_constant ("set", [t])) s -let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s +let t_list t ?s () : type_value = make_t (T_constant (Type_name "list", [t])) s +let t_set t ?s () : type_value = make_t (T_constant (Type_name "set", [t])) s +let t_contract t ?s () : type_value = make_t (T_constant (Type_name "contract", [t])) s let t_pair a b ?s () = t_tuple [a ; b] ?s () let t_record m ?s () : type_value = make_t (T_record m) s @@ -40,8 +40,8 @@ let ez_t_record lst ?s () : type_value = let m = SMap.of_list lst in t_record m ?s () -let t_map key value ?s () = make_t (T_constant ("map", [key ; value])) s -let t_big_map key value ?s () = make_t (T_constant ("big_map", [key ; value])) s +let t_map key value ?s () = make_t (T_constant (Type_name "map", [key ; value])) s +let t_big_map key value ?s () = make_t (T_constant (Type_name "big_map", [key ; value])) s let t_sum m ?s () : type_value = make_t (T_sum m) s let make_t_ez_sum (lst:(string * type_value) list) : type_value = @@ -67,59 +67,59 @@ let get_lambda_with_type e = | _ -> simple_fail "not a lambda with functional type" let get_t_bool (t:type_value) : unit result = match t.type_value' with - | T_constant ("bool", []) -> ok () + | T_constant (Type_name "bool", []) -> ok () | _ -> simple_fail "not a bool" let get_t_int (t:type_value) : unit result = match t.type_value' with - | T_constant ("int", []) -> ok () + | T_constant (Type_name "int", []) -> ok () | _ -> simple_fail "not a int" let get_t_nat (t:type_value) : unit result = match t.type_value' with - | T_constant ("nat", []) -> ok () + | T_constant (Type_name "nat", []) -> ok () | _ -> simple_fail "not a nat" let get_t_unit (t:type_value) : unit result = match t.type_value' with - | T_constant ("unit", []) -> ok () + | T_constant (Type_name "unit", []) -> ok () | _ -> simple_fail "not a unit" let get_t_mutez (t:type_value) : unit result = match t.type_value' with - | T_constant ("tez", []) -> ok () + | T_constant (Type_name "tez", []) -> ok () | _ -> simple_fail "not a tez" let get_t_bytes (t:type_value) : unit result = match t.type_value' with - | T_constant ("bytes", []) -> ok () + | T_constant (Type_name "bytes", []) -> ok () | _ -> simple_fail "not a bytes" let get_t_string (t:type_value) : unit result = match t.type_value' with - | T_constant ("string", []) -> ok () + | T_constant (Type_name "string", []) -> ok () | _ -> simple_fail "not a string" let get_t_contract (t:type_value) : type_value result = match t.type_value' with - | T_constant ("contract", [x]) -> ok x + | T_constant (Type_name "contract", [x]) -> ok x | _ -> simple_fail "not a contract" let get_t_option (t:type_value) : type_value result = match t.type_value' with - | T_constant ("option", [o]) -> ok o + | T_constant (Type_name "option", [o]) -> ok o | _ -> simple_fail "not a option" let get_t_list (t:type_value) : type_value result = match t.type_value' with - | T_constant ("list", [o]) -> ok o + | T_constant (Type_name "list", [o]) -> ok o | _ -> simple_fail "not a list" let get_t_set (t:type_value) : type_value result = match t.type_value' with - | T_constant ("set", [o]) -> ok o + | T_constant (Type_name "set", [o]) -> ok o | _ -> simple_fail "not a set" let get_t_key (t:type_value) : unit result = match t.type_value' with - | T_constant ("key", []) -> ok () + | T_constant (Type_name "key", []) -> ok () | _ -> simple_fail "not a key" let get_t_signature (t:type_value) : unit result = match t.type_value' with - | T_constant ("signature", []) -> ok () + | T_constant (Type_name "signature", []) -> ok () | _ -> simple_fail "not a signature" let get_t_key_hash (t:type_value) : unit result = match t.type_value' with - | T_constant ("key_hash", []) -> ok () + | T_constant (Type_name "key_hash", []) -> ok () | _ -> simple_fail "not a key_hash" let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with @@ -148,12 +148,12 @@ let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' let get_t_map (t:type_value) : (type_value * type_value) result = match t.type_value' with - | T_constant ("map", [k;v]) -> ok (k, v) + | T_constant (Type_name "map", [k;v]) -> ok (k, v) | _ -> simple_fail "get: not a map" let get_t_big_map (t:type_value) : (type_value * type_value) result = match t.type_value' with - | T_constant ("big_map", [k;v]) -> ok (k, v) + | T_constant (Type_name "big_map", [k;v]) -> ok (k, v) | _ -> simple_fail "get: not a big_map" let get_t_map_key : type_value -> type_value result = fun t -> @@ -201,7 +201,7 @@ let assert_t_bytes = fun t -> let assert_t_operation (t:type_value) : unit result = match t.type_value' with - | T_constant ("operation" , []) -> ok () + | T_constant (Type_name "operation" , []) -> ok () | _ -> simple_fail "assert: not an operation" let assert_t_list_operation (t : type_value) : unit result = @@ -209,11 +209,11 @@ let assert_t_list_operation (t : type_value) : unit result = assert_t_operation t' let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with - | T_constant ("int", []) -> ok () + | T_constant (Type_name "int", []) -> ok () | _ -> simple_fail "not an int" let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with - | T_constant ("nat", []) -> ok () + | T_constant (Type_name "nat", []) -> ok () | _ -> simple_fail "not an nat" let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/ast_typed/combinators.mli index 12b922013..518f96012 100644 --- a/src/stages/ast_typed/combinators.mli +++ b/src/stages/ast_typed/combinators.mli @@ -24,7 +24,7 @@ val t_option : type_value -> ?s:S.type_expression -> unit -> type_value val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_list : type_value -> ?s:S.type_expression -> unit -> type_value val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value -val t_variable : name -> ?s:S.type_expression -> unit -> type_value +val t_variable : type_name -> ?s:S.type_expression -> unit -> type_value val t_record : tv_map -> ?s:S.type_expression -> unit -> type_value val make_t_ez_record : (string * type_value) list -> type_value (* diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 105057905..fe21ea7e7 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -296,7 +296,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m bind_list_iter assert_type_value_eq (List.combine ta tb) ) | T_tuple _, _ -> fail @@ different_kinds a b - | T_constant (ca, lsta), T_constant (cb, lstb) -> ( + | T_constant (Type_name ca, lsta), T_constant (Type_name cb, lstb) -> ( let%bind _ = trace_strong (different_size_constants a b) @@ Assert.assert_true List.(length lsta = length lstb) in diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 3ecf979d5..c26466f9d 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -5,7 +5,7 @@ module S = Ast_simplified module SMap = Map.String type name = string -type type_name = string +type type_name = Type_name of string type constructor_name = string type 'a name_map = 'a SMap.t diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 8223c192a..7a1a1ab73 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -190,7 +190,7 @@ module Substitution = struct (* Replace the type variable ~v with ~expr everywhere within the program ~p. TODO: issues with scoping/shadowing. *) - and program ~(p : Ast_typed.program) ~(v:type_variable) ~expr : Ast_typed.program Trace.result = + and program ~(p : Ast_typed.program) ~(v:string (* this string is a type_name or type_variable I think *)) ~expr : Ast_typed.program Trace.result = Trace.bind_map_list (s_declaration_wrap ~v ~expr) p (* From 770bdda9df27381ac2c83e60db0ab7ddce0dda46 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 30 Oct 2019 19:35:26 +0100 Subject: [PATCH 31/39] commenting a little bit the typesystem --- src/stages/typesystem/core.ml | 124 +++++++++++++++------------- src/stages/typesystem/misc.ml | 29 +++---- src/stages/typesystem/shorthands.ml | 1 + 3 files changed, 81 insertions(+), 73 deletions(-) diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index 8aef87157..264ae8a9d 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -1,68 +1,74 @@ - type type_variable = string +type type_variable = (*Type_variable *) string - let fresh_type_variable : ?name:string -> unit -> type_variable = - let id = ref 0 in - let inc () = id := !id + 1 in - fun ?name () -> - inc () ; - match name with - | None -> "type_variable_" ^ (string_of_int !id) - | Some name -> "tv_" ^ name ^ "_" ^ (string_of_int !id) +(* generate a new type variable and gave it an id *) +let fresh_type_variable : ?name:string -> unit -> type_variable = + let id = ref 0 in + let inc () = id := !id + 1 in + fun ?name () -> + inc () ; + match name with + | None -> (*Type_variable*) "type_variable_" ^ (string_of_int !id) + | Some name -> (*Type_variable*)"tv_" ^ name ^ "_" ^ (string_of_int !id) - type constant_tag = - | C_arrow (* * -> * -> * *) - | C_option (* * -> * *) - | C_tuple (* * … -> * *) - | C_record (* ( label , * ) … -> * *) - | C_variant (* ( label , * ) … -> * *) - | C_map (* * -> * -> * *) - | C_big_map (* * -> * -> * *) - | C_list (* * -> * *) - | C_set (* * -> * *) - | C_unit (* * *) - | C_bool (* * *) - | C_string (* * *) - | C_nat (* * *) - | C_tez (* * *) - | C_timestamp (* * *) - | C_int (* * *) - | C_address (* * *) - | C_bytes (* * *) - | C_key_hash (* * *) - | C_key (* * *) - | C_signature (* * *) - | C_operation (* * *) - | C_contract (* * -> * *) +(* add information on the type or the kind for operator*) +type constant_tag = + | C_arrow (* * -> * -> * *) (* isn't this wrong*) + | C_option (* * -> * *) + | C_tuple (* * … -> * *) + | C_record (* ( label , * ) … -> * *) + | C_variant (* ( label , * ) … -> * *) + | C_map (* * -> * -> * *) + | C_big_map (* * -> * -> * *) + | C_list (* * -> * *) + | C_set (* * -> * *) + | C_unit (* * *) + | C_bool (* * *) + | C_string (* * *) + | C_nat (* * *) + | C_tez (* * *) + | C_timestamp (* * *) + | C_int (* * *) + | C_address (* * *) + | C_bytes (* * *) + | C_key_hash (* * *) + | C_key (* * *) + | C_signature (* * *) + | C_operation (* * *) + | C_contract (* * -> * *) - type label = - | L_int of int - | L_string of string +type label = + | L_int of int + | L_string of string - type type_value = - | P_forall of p_forall - | P_variable of type_variable - | P_constant of (constant_tag * type_value list) - | P_apply of (type_value * type_value) +(* Weird stuff; please explain *) +type type_value = + | P_forall of p_forall + | P_variable of type_variable (* how a value can be a variable? *) + | P_constant of (constant_tag * type_value list) + | P_apply of (type_value * type_value) - and p_forall = { - binder : type_variable ; - constraints : type_constraint list ; - body : type_value - } +and p_forall = { + binder : type_variable ; + constraints : type_constraint list ; + body : type_value +} - and simple_c_constructor = (constant_tag * type_variable list) (* non-empty list *) - and simple_c_constant = (constant_tag) (* for type constructors that do not take arguments *) - and c_const = (type_variable * type_value) - and c_equation = (type_value * type_value) - and c_typeclass = (type_value list * typeclass) - and c_access_label = (type_value * label * type_variable) +(* Different type of constraint *) (* why isn't this a variant ? *) +and simple_c_constructor = (constant_tag * type_variable list) (* non-empty list *) +and simple_c_constant = (constant_tag) (* for type constructors that do not take arguments *) +and c_const = (type_variable * type_value) +and c_equation = (type_value * type_value) +and c_typeclass = (type_value list * typeclass) +and c_access_label = (type_value * label * type_variable) - and type_constraint = - (* | C_assignment of (type_variable * type_pattern) *) - | C_equation of c_equation (* TVA = TVB *) - | C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *) - | C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *) - (* | … *) +(*What i was saying just before *) +and type_constraint = + (* | C_assignment of (type_variable * type_pattern) *) + | C_equation of c_equation (* TVA = TVB *) + | C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *) + | C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *) +(* | … *) - and typeclass = type_value list list +(* is the first list in case on of the type of the type class as a kind *->*->* ? *) +and typeclass = type_value list list diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 7a1a1ab73..1290f500d 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -3,6 +3,7 @@ open Core let pair_map = fun f (x , y) -> (f x , f y) module Substitution = struct + (* Replace Types variables by the infered type *) module Pattern = struct @@ -14,11 +15,11 @@ module Substitution = struct let rec rec_yes = true and s_environment_element_definition ~v ~expr = function - | T.ED_binder -> ok @@ T.ED_binder - | T.ED_declaration (val_, free_variables) -> - let%bind val_ = s_annotated_expression ~v ~expr val_ in - let%bind free_variables = bind_map_list (s_type_variable ~v ~expr) free_variables in - ok @@ T.ED_declaration (val_, free_variables) + | T.ED_binder -> ok @@ T.ED_binder + | T.ED_declaration (val_, free_variables) -> + let%bind val_ = s_annotated_expression ~v ~expr val_ in + let%bind free_variables = bind_map_list (s_type_variable ~v ~expr) free_variables in + ok @@ T.ED_declaration (val_, free_variables) and s_environment ~v ~expr = fun lst -> bind_map_list (fun (type_variable, T.{ type_value; source_environment; definition }) -> let _ = type_value in @@ -47,10 +48,10 @@ module Substitution = struct and s_type_variable ~v ~expr : T.name w = fun tvar -> let _TODO = ignore (v, expr, tvar) in failwith "TODO: subst: unimplemented case s_type_variable" - (* if String.equal tvar v then - * expr - * else - * ok tvar *) + (* if String.equal tvar v then + * expr + * else + * ok tvar *) and s_type_value' ~v ~expr : T.type_value' w = fun _ -> let _TODO = (v, expr) in @@ -114,11 +115,11 @@ module Substitution = struct | T.E_record aemap -> let _TODO = aemap in failwith "TODO: subst in record" - (* let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> - * let key = s_type_variable ~v ~expr key in - * let val_ = s_annotated_expression ~v ~expr val_ in - * ok @@ (key , val_)) aemap in - * ok @@ T.E_record aemap *) + (* let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> + * let key = s_type_variable ~v ~expr key in + * let val_ = s_annotated_expression ~v ~expr val_ in + * ok @@ (key , val_)) aemap in + * ok @@ T.E_record aemap *) | T.E_record_accessor (val_, tvar) -> let%bind val_ = s_annotated_expression ~v ~expr val_ in let%bind tvar = s_type_variable ~v ~expr tvar in diff --git a/src/stages/typesystem/shorthands.ml b/src/stages/typesystem/shorthands.ml index c4d794f87..0d772415d 100644 --- a/src/stages/typesystem/shorthands.ml +++ b/src/stages/typesystem/shorthands.ml @@ -14,6 +14,7 @@ let forall_tc binder f = let (tc, ty) = f (P_variable freshvar) in P_forall { binder = freshvar ; constraints = tc ; body = ty } +(* chained forall *) let forall2 a b f = forall a @@ fun a' -> forall b @@ fun b' -> From dce15a79c6e20d98fb8efbb52627b505dac73e82 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 31 Oct 2019 13:21:05 -0400 Subject: [PATCH 32/39] WIP on understanding where in the AST we need the subst. --- src/stages/ast_typed/types.ml | 16 ++++--- src/stages/typesystem/misc.ml | 84 +++++++++++++++++++++++++---------- 2 files changed, 70 insertions(+), 30 deletions(-) diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index c26466f9d..ba34c433e 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -24,18 +24,18 @@ and environment_element_definition = and free_variables = name list and environment_element = { - type_value : type_value ; + type_value : type_value ; (* SUBST ??? *) source_environment : full_environment ; definition : environment_element_definition ; } and environment = (string * environment_element) list -and type_environment = (string * type_value) list +and type_environment = (string * type_value) list (* SUBST ??? *) and small_environment = (environment * type_environment) and full_environment = small_environment List.Ne.t and annotated_expression = { expression : expression ; - type_annotation : tv ; + type_annotation : tv ; (* SUBST *) environment : full_environment ; location : Location.t ; } @@ -54,20 +54,24 @@ and type_value' = | T_tuple of tv list | T_sum of tv_map | T_record of tv_map - | T_constant of type_name * tv list - | T_variable of type_name + | T_constant of type_name * tv list (* SUBST ??? I think not, at least not necessary for now and the types don't match *) + | T_variable of type_name (* SUBST *) | T_function of (tv * tv) and type_value = { type_value' : type_value' ; - simplified : S.type_expression option ; + simplified : S.type_expression option ; (* If we have the simplified this AST fragment comes from, it is stored here, for easier untyping. *) } +(* This is used in E_assign of (named_type_value * access_path * ae). + In mini_c, we need the type associated with `x` in the assignment + expression `x.y.z := 42`, so it is stored here. *) and named_type_value = { type_name: name ; type_value : type_value ; } +(* E_lamba and other expressions are always wrapped as an annotated_expression. *) and lambda = { binder : name ; (* input_type: tv ; diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 1290f500d..9d64dc372 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -3,7 +3,6 @@ open Core let pair_map = fun f (x , y) -> (f x , f y) module Substitution = struct - (* Replace Types variables by the infered type *) module Pattern = struct @@ -29,9 +28,11 @@ module Substitution = struct let%bind definition = s_environment_element_definition ~v ~expr definition in ok @@ (type_variable, T.{ type_value; source_environment; definition }) ) lst - and s_type_environment ~v ~expr : T.type_environment w = fun _ -> - let _TODO = (v, expr) in - failwith "TODO: subst: unimplemented case s_type_environment" + and s_type_environment ~v ~expr : T.type_environment w = fun tenv -> + bind_map_list (fun (type_variable , type_value) -> + let%bind type_variable = s_type_variable ~v ~expr type_variable in + let%bind type_value = s_type_value ~v ~expr type_value in + ok @@ (type_variable , type_value)) tenv and s_small_environment ~v ~expr : T.small_environment w = fun (environment, type_environment) -> let%bind environment = s_environment ~v ~expr environment in let%bind type_environment = s_type_environment ~v ~expr type_environment in @@ -46,27 +47,62 @@ module Substitution = struct ok var and s_type_variable ~v ~expr : T.name w = fun tvar -> - let _TODO = ignore (v, expr, tvar) in - failwith "TODO: subst: unimplemented case s_type_variable" - (* if String.equal tvar v then - * expr - * else - * ok tvar *) + let _TODO = ignore (v, expr) in + Printf.printf "TODO: subst: unimplemented case s_type_variable"; + ok @@ tvar + (* if String.equal tvar v then + * expr + * else + * ok tvar *) - and s_type_value' ~v ~expr : T.type_value' w = fun _ -> - let _TODO = (v, expr) in - failwith "TODO: subst: unimplemented case s_type_value'" - and s_type_expression ~v ~expr : Ast_simplified.type_expression w = fun _ -> - let _TODO = (v, expr) in - failwith "TODO: subst: unimplemented case s_type_expression" + and s_type_name_constant ~v ~expr : T.type_name w = fun type_name -> + (* TODO: we don't need to subst anything, right? *) + let () = ignore (v , expr) in + ok @@ type_name + + and s_type_value' ~v ~expr : T.type_value' w = function + | T.T_tuple type_value_list -> + let%bind type_value_list = bind_map_list (s_type_value ~v ~expr) type_value_list in + ok @@ T.T_tuple type_value_list + | T.T_sum _ -> failwith "TODO: T_sum" + | T.T_record _ -> failwith "TODO: T_record" + | T.T_constant (type_name, type_value_list) -> + let%bind type_name = s_type_name_constant ~v ~expr type_name in + let%bind type_value_list = bind_map_list (s_type_value ~v ~expr) type_value_list in + ok @@ T.T_constant (type_name, type_value_list) + | T.T_variable _ -> failwith "TODO: T_variable" + | T.T_function _ -> + let _TODO = (v, expr) in + failwith "TODO: T_function" + + and s_type_expression ~v ~expr : Ast_simplified.type_expression w = function + | Ast_simplified.T_tuple _ -> failwith "TODO: subst: unimplemented case s_type_expression" + | Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression" + | Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression" + | Ast_simplified.T_function (_, _) -> failwith "TODO: subst: unimplemented case s_type_expression" + | Ast_simplified.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression" + | Ast_simplified.T_constant (_, _) -> + let _TODO = (v, expr) in + failwith "TODO: subst: unimplemented case s_type_expression" and s_type_value ~v ~expr : T.type_value w = fun { type_value'; simplified } -> let%bind type_value' = s_type_value' ~v ~expr type_value' in let%bind simplified = bind_map_option (s_type_expression ~v ~expr) simplified in ok @@ T.{ type_value'; simplified } - and s_literal ~v ~expr : T.literal w = fun _ -> - let _TODO = v, expr in - failwith "TODO: subst: unimplemented case s_literal" + and s_literal ~v ~expr : T.literal w = function + | T.Literal_unit -> + let () = ignore (v, expr) in + ok @@ T.Literal_unit + | (T.Literal_bool _ as x) + | (T.Literal_int _ as x) + | (T.Literal_nat _ as x) + | (T.Literal_timestamp _ as x) + | (T.Literal_mutez _ as x) + | (T.Literal_string _ as x) + | (T.Literal_bytes _ as x) + | (T.Literal_address _ as x) + | (T.Literal_operation _ as x) -> + ok @@ x and s_matching_expr ~v ~expr : T.matching_expr w = fun _ -> let _TODO = v, expr in failwith "TODO: subst: unimplemented case s_matching" @@ -115,11 +151,11 @@ module Substitution = struct | T.E_record aemap -> let _TODO = aemap in failwith "TODO: subst in record" - (* let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> - * let key = s_type_variable ~v ~expr key in - * let val_ = s_annotated_expression ~v ~expr val_ in - * ok @@ (key , val_)) aemap in - * ok @@ T.E_record aemap *) + (* let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ -> + * let key = s_type_variable ~v ~expr key in + * let val_ = s_annotated_expression ~v ~expr val_ in + * ok @@ (key , val_)) aemap in + * ok @@ T.E_record aemap *) | T.E_record_accessor (val_, tvar) -> let%bind val_ = s_annotated_expression ~v ~expr val_ in let%bind tvar = s_type_variable ~v ~expr tvar in From 5c3e1ad642790f9e5ef9bb7a7d7a0e5d3b817d2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 31 Oct 2019 17:19:01 -0400 Subject: [PATCH 33/39] Hack for E_constant with loops shouldn't be necessary in new typer, thanks to typeclasses? --- src/passes/4-typer/typer.ml | 36 ------------------------------------ 1 file changed, 36 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index ab2ecd61d..6a82ba9a6 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -707,42 +707,6 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate * let%bind (name', tv) = * type_constant name tv_lst tv_opt ae.location in * return (E_constant (name' , lst')) tv *) - | E_constant ( ("LIST_FOLD"|"MAP_FOLD"|"SET_FOLD") as opname , - [ collect ; - init_record ; - ( { expression = (I.E_lambda { binder = (lname, None) ; - input_type = None ; - output_type = None ; - result }) ; - location = _ }) as _lambda - ] ) -> -let _TODO = (opname, collect, init_record, lname, result) in -failwith "TODO: E_constant merge" -(* ******************************************************************************************************************************************************** *) -(* - (* this special case is here force annotation of the untyped lambda - generated by pascaligo's for_collect loop *) - let%bind (v_col , v_initr ) = bind_map_pair (type_expression e) (collect , init_record ) in - let tv_col = get_type_annotation v_col in (* this is the type of the collection *) - let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*) - let%bind input_type = match tv_col.type_value' with - | O.T_constant ( ("list"|"set") , t) -> ok @@ t_tuple (tv_out::t) () - | O.T_constant ( "map" , t) -> ok @@ t_tuple (tv_out::[(t_tuple t ())]) () - | _ -> - let wtype = Format.asprintf - "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in - fail @@ simple_error wtype in - let e' = Environment.add_ez_binder lname input_type e in - let%bind body = type_expression ?tv_opt:(Some tv_out) e' result in - let output_type = body.type_annotation in - let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in - let lst' = [v_col; v_initr ; lambda'] in - let tv_lst = List.map get_type_annotation lst' in - let%bind (opname', tv) = - type_constant opname tv_lst tv_opt ae.location in - return (E_constant (opname' , lst')) tv -*) -(* ******************************************************************************************************************************************************** *) | E_application (f, arg) -> let%bind (f' , state') = type_expression e state f in let%bind (arg , state'') = type_expression e state' arg in From d57a87a3ea0b7f6ac1f68a4aee31c0b49aa05321 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 31 Oct 2019 17:43:44 -0400 Subject: [PATCH 34/39] Moving new typer to separate folder --- src/passes/{4-typer => 4-typer-new}/dune | 0 src/passes/{4-typer => 4-typer-new}/solver.ml | 0 src/passes/{4-typer => 4-typer-new}/typer.ml | 0 src/passes/{4-typer => 4-typer-new}/typer.ml.old | 0 src/passes/{4-typer => 4-typer-new}/typer.mli | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename src/passes/{4-typer => 4-typer-new}/dune (100%) rename src/passes/{4-typer => 4-typer-new}/solver.ml (100%) rename src/passes/{4-typer => 4-typer-new}/typer.ml (100%) rename src/passes/{4-typer => 4-typer-new}/typer.ml.old (100%) rename src/passes/{4-typer => 4-typer-new}/typer.mli (100%) diff --git a/src/passes/4-typer/dune b/src/passes/4-typer-new/dune similarity index 100% rename from src/passes/4-typer/dune rename to src/passes/4-typer-new/dune diff --git a/src/passes/4-typer/solver.ml b/src/passes/4-typer-new/solver.ml similarity index 100% rename from src/passes/4-typer/solver.ml rename to src/passes/4-typer-new/solver.ml diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer-new/typer.ml similarity index 100% rename from src/passes/4-typer/typer.ml rename to src/passes/4-typer-new/typer.ml diff --git a/src/passes/4-typer/typer.ml.old b/src/passes/4-typer-new/typer.ml.old similarity index 100% rename from src/passes/4-typer/typer.ml.old rename to src/passes/4-typer-new/typer.ml.old diff --git a/src/passes/4-typer/typer.mli b/src/passes/4-typer-new/typer.mli similarity index 100% rename from src/passes/4-typer/typer.mli rename to src/passes/4-typer-new/typer.mli From 45347e3e886e3d3c1e374460f53a2d0b9193b828 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 31 Oct 2019 18:19:01 -0400 Subject: [PATCH 35/39] Bring back copy of the old typer (part 2: changes) --- src/main/compile/dune | 1 + src/main/run/dune | 1 + src/passes/4-typer-new/dune | 4 +- src/passes/4-typer/dune | 15 + src/passes/4-typer/typer.ml | 917 +++++++++++++++++++++++++++++++++++ src/passes/4-typer/typer.mli | 59 +++ 6 files changed, 995 insertions(+), 2 deletions(-) create mode 100644 src/passes/4-typer/dune create mode 100644 src/passes/4-typer/typer.ml create mode 100644 src/passes/4-typer/typer.mli diff --git a/src/main/compile/dune b/src/main/compile/dune index 705ed50b9..59b561ef0 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -8,6 +8,7 @@ simplify ast_simplified self_ast_simplified + typer_new typer ast_typed transpiler diff --git a/src/main/run/dune b/src/main/run/dune index 34f7986af..f39c18a69 100644 --- a/src/main/run/dune +++ b/src/main/run/dune @@ -7,6 +7,7 @@ parser simplify ast_simplified + typer_new typer ast_typed transpiler diff --git a/src/passes/4-typer-new/dune b/src/passes/4-typer-new/dune index ec35ab2ce..ef18cd078 100644 --- a/src/passes/4-typer-new/dune +++ b/src/passes/4-typer-new/dune @@ -1,6 +1,6 @@ (library - (name typer) - (public_name ligo.typer) + (name typer_new) + (public_name ligo.typer_new) (libraries simple-utils tezos-utils diff --git a/src/passes/4-typer/dune b/src/passes/4-typer/dune new file mode 100644 index 000000000..0ee58cc43 --- /dev/null +++ b/src/passes/4-typer/dune @@ -0,0 +1,15 @@ +(library + (name typer) + (public_name ligo.typer) + (libraries + simple-utils + tezos-utils + ast_simplified + ast_typed + operators + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml new file mode 100644 index 000000000..2751225eb --- /dev/null +++ b/src/passes/4-typer/typer.ml @@ -0,0 +1,917 @@ +open Trace + +module I = Ast_simplified +module O = Ast_typed +open O.Combinators + +module SMap = O.SMap + +module Environment = O.Environment + +module Solver = struct + type state = Placeholder_for_state_of_new_typer + let discard_state (_ : state) = () + let initial_state = Placeholder_for_state_of_new_typer +end + +type environment = Environment.t + +module Errors = struct + let unbound_type_variable (e:environment) (n:string) () = + let title = (thunk "unbound type variable") in + let message () = "" in + let data = [ + ("variable" , fun () -> Format.asprintf "%s" n) ; + (* TODO: types don't have srclocs for now. *) + (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) + ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) + ] in + error ~data title message () + + let unbound_variable (e:environment) (n:string) (loc:Location.t) () = + let title = (thunk "unbound variable") in + let message () = "" in + let data = [ + ("variable" , fun () -> Format.asprintf "%s" n) ; + ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "match with no cases") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ = + fun matching loc () -> + let title = (thunk "missing case in match") in + let message () = "" in + let data = [ + ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let unbound_constructor (e:environment) (n:string) (loc:Location.t) () = + let title = (thunk "unbound constructor") in + let message () = "" in + let data = [ + ("constructor" , fun () -> Format.asprintf "%s" n) ; + ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let unrecognized_constant (n:string) (loc:Location.t) () = + let title = (thunk "unrecognized constant") in + let message () = "" in + let data = [ + ("constant" , fun () -> Format.asprintf "%s" n) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () = + let title () = "wrong arity" in + let message () = "" in + let data = [ + ("function" , fun () -> Format.asprintf "%s" n) ; + ("expected" , fun () -> Format.asprintf "%d" expected) ; + ("actual" , fun () -> Format.asprintf "%d" actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () = + let title () = "matching tuple of different size" in + let message () = "" in + let data = [ + ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ; + ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + (* TODO: this should be a trace_info? *) + let program_error (p:I.program) () = + let message () = "" in + let title = (thunk "typing program") in + let data = [ + ("program" , fun () -> Format.asprintf "%a" I.PP.program p) + ] in + error ~data title message () + + let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () = + let title = (thunk "typing constant declaration") in + let message () = "" in + let data = [ + ("constant" , fun () -> Format.asprintf "%s" name) ; + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("expected" , fun () -> + match expected with + None -> "(no annotation for the expected type)" + | Some expected -> Format.asprintf "%a" O.PP.type_value expected) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) + ] in + error ~data title message () + + let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ = + fun ?(msg = "") ~expected ~actual loc () -> + let title = (thunk "typing match") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let needs_annotation (e : I.expression) (case : string) () = + let title = (thunk "this expression must be annotated with its type") in + let message () = Format.asprintf "%s needs an annotation" case in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp e.location) + ] in + error ~data title message () + + let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () = + let title = (thunk "type error") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%s" expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () = + let title = (thunk "type error") in + let message () = msg in + let data = [ + ("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected); + ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () = + let title = (thunk "invalid tuple index") in + let message () = "" in + let data = [ + ("index" , fun () -> Format.asprintf "%d" index) ; + ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () = + let title = (thunk "invalid record field") in + let message () = "" in + let data = [ + ("field" , fun () -> Format.asprintf "%s" field) ; + ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let not_supported_yet (message : string) (ae : I.expression) () = + let title = (thunk "not suported yet") in + let message () = message in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) + ] in + error ~data title message () + + let not_supported_yet_untranspile (message : string) (ae : O.expression) () = + let title = (thunk "not suported yet") in + let message () = message in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae) + ] in + error ~data title message () + + let constant_error loc lst tv_opt = + let title () = "typing constant" in + let message () = "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp loc ) ; + ("argument_types" , fun () -> Format.asprintf "%a" PP_helpers.(list_sep Ast_typed.PP.type_value (const " , ")) lst) ; + ("type_opt" , fun () -> Format.asprintf "%a" PP_helpers.(option Ast_typed.PP.type_value) tv_opt) ; + ] in + error ~data title message +end +open Errors + +let rec type_program (p:I.program) : (O.program * Solver.state) result = + let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = + let%bind ed' = (bind_map_location (type_declaration e Solver.Placeholder_for_state_of_new_typer)) d in + let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in + let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in + match d' with + | None -> ok (e', acc) + | Some d' -> ok (e', loc ed' d' :: acc) + in + let%bind (_, lst) = + trace (fun () -> program_error p ()) @@ + bind_fold_list aux (Environment.full_empty, []) p in + ok @@ (List.rev lst , Solver.Placeholder_for_state_of_new_typer) + +and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) : I.declaration -> (environment * Solver.state * O.declaration option) result = function + | Declaration_type (type_name , type_expression) -> + let%bind tv = evaluate_type env type_expression in + let env' = Environment.add_type type_name tv env in + ok (env', Solver.Placeholder_for_state_of_new_typer , None) + | Declaration_constant (name , tv_opt , expression) -> ( + let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in + let%bind ae' = + trace (constant_declaration_error name expression tv'_opt) @@ + type_expression' ?tv_opt:tv'_opt env expression in + let env' = Environment.add_ez_ae name ae' env in + ok (env', Solver.Placeholder_for_state_of_new_typer , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) + ) + +and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> I.expression -> Location.t -> o O.matching result = + fun f e t i ae loc -> match i with + | Match_bool {match_true ; match_false} -> + let%bind _ = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_bool t in + let%bind match_true = f e match_true in + let%bind match_false = f e match_false in + ok (O.Match_bool {match_true ; match_false}) + | Match_option {match_none ; match_some} -> + let%bind t_opt = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_option t in + let%bind match_none = f e match_none in + let (n, b) = match_some in + let n' = n, t_opt in + let e' = Environment.add_ez_binder n t_opt e in + let%bind b' = f e' b in + ok (O.Match_option {match_none ; match_some = (n', b')}) + | Match_list {match_nil ; match_cons} -> + let%bind t_list = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_list t in + let%bind match_nil = f e match_nil in + let (hd, tl, b) = match_cons in + let e' = Environment.add_ez_binder hd t_list e in + let e' = Environment.add_ez_binder tl t e' in + let%bind b' = f e' b in + ok (O.Match_list {match_nil ; match_cons = (((hd , t_list), (tl , t)), b')}) + | Match_tuple (lst, b) -> + let%bind t_tuple = + trace_strong (match_error ~expected:i ~actual:t loc) + @@ get_t_tuple t in + let%bind lst' = + generic_try (match_tuple_wrong_arity t_tuple lst loc) + @@ (fun () -> List.combine lst t_tuple) in + let aux prev (name, tv) = Environment.add_ez_binder name tv prev in + let e' = List.fold_left aux e lst' in + let%bind b' = f e' b in + ok (O.Match_tuple (lst, b')) + | Match_variant lst -> + let%bind variant_opt = + let aux acc ((constructor_name , _) , _) = + let%bind (_ , variant) = + trace_option (unbound_constructor e constructor_name loc) @@ + Environment.get_constructor constructor_name e in + let%bind acc = match acc with + | None -> ok (Some variant) + | Some variant' -> ( + trace (type_error + ~msg:"in match variant" + ~expected:variant + ~actual:variant' + ~expression:ae + loc + ) @@ + Ast_typed.assert_type_value_eq (variant , variant') >>? fun () -> + ok (Some variant) + ) in + ok acc in + trace (simple_info "in match variant") @@ + bind_fold_list aux None lst in + let%bind variant = + trace_option (match_empty_variant i loc) @@ + variant_opt in + let%bind () = + let%bind variant_cases' = + trace (match_error ~expected:i ~actual:t loc) + @@ Ast_typed.Combinators.get_t_sum variant in + let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in + let match_cases = List.map (Function.compose fst fst) lst in + let test_case = fun c -> + Assert.assert_true (List.mem c match_cases) + in + let%bind () = + trace_strong (match_missing_case i loc) @@ + bind_iter_list test_case variant_cases in + let%bind () = + trace_strong (match_redundant_case i loc) @@ + Assert.assert_true List.(length variant_cases = length match_cases) in + ok () + in + let%bind lst' = + let aux ((constructor_name , name) , b) = + let%bind (constructor , _) = + trace_option (unbound_constructor e constructor_name loc) @@ + Environment.get_constructor constructor_name e in + let e' = Environment.add_ez_binder name constructor e in + let%bind b' = f e' b in + ok ((constructor_name , name) , b') + in + bind_map_list aux lst in + ok (O.Match_variant (lst' , variant)) + +and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = + let return tv' = ok (make_t tv' (Some t)) in + match t with + | T_function (a, b) -> + let%bind a' = evaluate_type e a in + let%bind b' = evaluate_type e b in + return (T_function (a', b')) + | T_tuple lst -> + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + return (T_tuple lst') + | T_sum m -> + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + return (T_sum m) + | T_record m -> + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + return (T_record m) + | T_variable name -> + let%bind tv = + trace_option (unbound_type_variable e name) + @@ Environment.get_type_opt name e in + ok tv + | T_constant (cst, lst) -> + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + return (T_constant(Type_name cst, lst')) + +and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result + = fun e _placeholder_for_state_of_new_typer ?tv_opt ae -> + let%bind res = type_expression' e ?tv_opt ae in + ok (res, Solver.Placeholder_for_state_of_new_typer) +and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result = fun e ?tv_opt ae -> + let module L = Logger.Stateful() in + let return expr tv = + let%bind () = + match tv_opt with + | None -> ok () + | Some tv' -> O.assert_type_value_eq (tv' , tv) in + let location = ae.location in + ok @@ make_a_e ~location expr tv e in + let main_error = + let title () = "typing expression" in + let content () = "" in + let data = [ + ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; + ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) ; + ("misc" , fun () -> L.get ()) ; + ] in + error ~data title content in + trace main_error @@ + match ae.expression with + (* Basic *) + | E_variable name -> + let%bind tv' = + trace_option (unbound_variable e name ae.location) + @@ Environment.get_opt name e in + return (E_variable name) tv'.type_value + | E_literal (Literal_bool b) -> + return (E_literal (Literal_bool b)) (t_bool ()) + | E_literal Literal_unit | E_skip -> + return (E_literal (Literal_unit)) (t_unit ()) + | E_literal (Literal_string s) -> + return (E_literal (Literal_string s)) (t_string ()) + | E_literal (Literal_bytes s) -> + return (E_literal (Literal_bytes s)) (t_bytes ()) + | E_literal (Literal_int n) -> + return (E_literal (Literal_int n)) (t_int ()) + | E_literal (Literal_nat n) -> + return (E_literal (Literal_nat n)) (t_nat ()) + | E_literal (Literal_timestamp n) -> + return (E_literal (Literal_timestamp n)) (t_timestamp ()) + | E_literal (Literal_mutez n) -> + return (E_literal (Literal_mutez n)) (t_mutez ()) + | E_literal (Literal_address s) -> + return (e_address s) (t_address ()) + | E_literal (Literal_operation op) -> + return (e_operation op) (t_operation ()) + (* Tuple *) + | E_tuple lst -> + let%bind lst' = bind_list @@ List.map (type_expression' e) lst in + let tv_lst = List.map get_type_annotation lst' in + return (E_tuple lst') (t_tuple tv_lst ()) + | E_accessor (ae', path) -> + let%bind e' = type_expression' e ae' in + let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = + match a with + | Access_tuple index -> ( + let%bind tpl_tv = get_t_tuple prev.type_annotation in + let%bind tv = + generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) + @@ (fun () -> List.nth tpl_tv index) in + return (E_tuple_accessor (prev , index)) tv + ) + | Access_record property -> ( + let%bind r_tv = get_t_record prev.type_annotation in + let%bind tv = + generic_try (bad_record_access property ae' prev.type_annotation ae.location) + @@ (fun () -> SMap.find property r_tv) in + return (E_record_accessor (prev , property)) tv + ) + | Access_map ae' -> ( + let%bind ae'' = type_expression' e ae' in + let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in + let%bind () = + Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in + return (E_look_up (prev , ae'')) v + ) + in + trace (simple_info "accessing") @@ + bind_fold_list aux e' path + (* Sum *) + | E_constructor (c, expr) -> + let%bind (c_tv, sum_tv) = + let error = + let title () = "no such constructor" in + let content () = + Format.asprintf "%s in:\n%a\n" + c O.Environment.PP.full_environment e + in + error title content in + trace_option error @@ + Environment.get_constructor c e in + let%bind expr' = type_expression' e expr in + let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in + return (E_constructor (c , expr')) sum_tv + (* Record *) + | E_record m -> + let aux prev k expr = + let%bind expr' = type_expression' e expr in + ok (SMap.add k expr' prev) + in + let%bind m' = bind_fold_smap aux (ok SMap.empty) m in + return (E_record m') (t_record (SMap.map get_type_annotation m') ()) + (* Data-structure *) + | E_list lst -> + let%bind lst' = bind_map_list (type_expression' e) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind init = match tv_opt with + | None -> ok None + | Some ty -> + let%bind ty' = get_t_list ty in + ok (Some ty') in + let%bind ty = + let%bind opt = bind_fold_list aux init + @@ List.map get_type_annotation lst' in + trace_option (needs_annotation ae "empty list") opt in + ok (t_list ty ()) + in + return (E_list lst') tv + | E_set lst -> + let%bind lst' = bind_map_list (type_expression' e) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind init = match tv_opt with + | None -> ok None + | Some ty -> + let%bind ty' = get_t_set ty in + ok (Some ty') in + let%bind ty = + let%bind opt = bind_fold_list aux init + @@ List.map get_type_annotation lst' in + trace_option (needs_annotation ae "empty set") opt in + ok (t_set ty ()) + in + return (E_set lst') tv + | E_map lst -> + let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_map key_type value_type ()) + in + return (E_map lst') tv + | E_big_map lst -> + let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in + let%bind tv = + let aux opt c = + match opt with + | None -> ok (Some c) + | Some c' -> + let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in + ok (Some c') in + let%bind key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_big_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_big_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_big_map key_type value_type ()) + in + return (E_big_map lst') tv + | E_lambda { + binder ; + input_type ; + output_type ; + result ; + } -> ( + let%bind input_type = + let%bind input_type = + (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *) + let default_action e () = fail @@ (needs_annotation e "the returned value") in + match input_type with + | Some ty -> ok ty + | None -> ( + match result.expression with + | I.E_let_in li -> ( + match li.rhs.expression with + | I.E_variable name when name = (fst binder) -> ( + match snd li.binder with + | Some ty -> ok ty + | None -> default_action li.rhs () + ) + | _ -> default_action li.rhs () + ) + | _ -> default_action result () + ) + in + evaluate_type e input_type in + let%bind output_type = + bind_map_option (evaluate_type e) output_type + in + let e' = Environment.add_ez_binder (fst binder) input_type e in + let%bind body = type_expression' ?tv_opt:output_type e' result in + let output_type = body.type_annotation in + return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) + ) + | E_constant ( ("LIST_FOLD"|"MAP_FOLD"|"SET_FOLD") as opname , + [ collect ; + init_record ; + ( { expression = (I.E_lambda { binder = (lname, None) ; + input_type = None ; + output_type = None ; + result }) ; + location = _ }) as _lambda + ] ) -> + (* this special case is here force annotation of the untyped lambda + generated by pascaligo's for_collect loop *) + let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in + let tv_col = get_type_annotation v_col in (* this is the type of the collection *) + let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*) + let%bind input_type = match tv_col.type_value' with + | O.T_constant ( (Type_name "list"|Type_name "set") , t) -> ok @@ t_tuple (tv_out::t) () + | O.T_constant ( Type_name "map" , t) -> ok @@ t_tuple (tv_out::[(t_tuple t ())]) () + | _ -> + let wtype = Format.asprintf + "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in + fail @@ simple_error wtype in + let e' = Environment.add_ez_binder lname input_type e in + let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in + let output_type = body.type_annotation in + let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in + let lst' = [v_col; v_initr ; lambda'] in + let tv_lst = List.map get_type_annotation lst' in + let%bind (opname', tv) = + type_constant opname tv_lst tv_opt ae.location in + return (E_constant (opname' , lst')) tv + | E_constant (name, lst) -> + let%bind lst' = bind_list @@ List.map (type_expression' e) lst in + let tv_lst = List.map get_type_annotation lst' in + let%bind (name', tv) = + type_constant name tv_lst tv_opt ae.location in + return (E_constant (name' , lst')) tv + | E_application (f, arg) -> + let%bind f' = type_expression' e f in + let%bind arg = type_expression' e arg in + let%bind tv = match f'.type_annotation.type_value' with + | T_function (param, result) -> + let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in + ok result + | _ -> + fail @@ type_error_approximate + ~expected:"should be a function type" + ~expression:f + ~actual:f'.type_annotation + f'.location + in + return (E_application (f' , arg)) tv + | E_look_up dsi -> + let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in + let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in + return (E_look_up (ds , ind)) (t_option dst ()) + (* Advanced *) + | E_matching (ex, m) -> ( + let%bind ex' = type_expression' e ex in + let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_annotation m ae ae.location in + let tvs = + let aux (cur:O.value O.matching) = + match cur with + | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] + | Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] + | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] + | Match_tuple (_ , match_tuple) -> [ match_tuple ] + | Match_variant (lst , _) -> List.map snd lst in + List.map get_type_annotation @@ aux m' in + let aux prec cur = + let%bind () = + match prec with + | None -> ok () + | Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in + ok (Some cur) in + let%bind tv_opt = bind_fold_list aux None tvs in + let%bind tv = + trace_option (match_empty_variant m ae.location) @@ + tv_opt in + return (O.E_matching (ex', m')) tv + ) + | E_sequence (a , b) -> + let%bind a' = type_expression' e a in + let%bind b' = type_expression' e b in + let a'_type_annot = get_type_annotation a' in + let%bind () = + trace_strong (type_error + ~msg:"first part of the sequence should be of unit type" + ~expected:(O.t_unit ()) + ~actual:a'_type_annot + ~expression:a + a'.location) @@ + Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in + return (O.E_sequence (a' , b')) (get_type_annotation b') + | E_loop (expr , body) -> + let%bind expr' = type_expression' e expr in + let%bind body' = type_expression' e body in + let t_expr' = get_type_annotation expr' in + let%bind () = + trace_strong (type_error + ~msg:"while condition isn't of type bool" + ~expected:(O.t_bool ()) + ~actual:t_expr' + ~expression:expr + expr'.location) @@ + Ast_typed.assert_type_value_eq (t_bool () , t_expr') in + let t_body' = get_type_annotation body' in + let%bind () = + trace_strong (type_error + ~msg:"while body isn't of unit type" + ~expected:(O.t_unit ()) + ~actual:t_body' + ~expression:body + body'.location) @@ + Ast_typed.assert_type_value_eq (t_unit () , t_body') in + return (O.E_loop (expr' , body')) (t_unit ()) + | E_assign (name , path , expr) -> + let%bind typed_name = + let%bind ele = Environment.get_trace name e in + ok @@ make_n_t name ele.type_value in + let%bind (assign_tv , path') = + let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path -> + match cur_path with + | Access_tuple index -> ( + let%bind tpl = get_t_tuple prec_tv in + let%bind tv' = + trace_option (bad_tuple_index index ae prec_tv ae.location) @@ + List.nth_opt tpl index in + ok (tv' , prec_path @ [O.Access_tuple index]) + ) + | Access_record property -> ( + let%bind m = get_t_record prec_tv in + let%bind tv' = + trace_option (bad_record_access property ae prec_tv ae.location) @@ + Map.String.find_opt property m in + ok (tv' , prec_path @ [O.Access_record property]) + ) + | Access_map _ -> + fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae + in + bind_fold_list aux (typed_name.type_value , []) path in + let%bind expr' = type_expression' e ~tv_opt:assign_tv expr in + let t_expr' = get_type_annotation expr' in + let%bind () = + trace_strong (type_error + ~msg:"type of the expression to assign doesn't match left-hand-side" + ~expected:assign_tv + ~actual:t_expr' + ~expression:expr + expr'.location) @@ + Ast_typed.assert_type_value_eq (assign_tv , t_expr') in + return (O.E_assign (typed_name , path' , expr')) (t_unit ()) + | E_let_in {binder ; rhs ; result} -> + let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in + let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in + let e' = Environment.add_ez_declaration (fst binder) rhs e in + let%bind result = type_expression' e' result in + return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation + | E_annotation (expr , te) -> + let%bind tv = evaluate_type e te in + let%bind expr' = type_expression' ~tv_opt:tv e expr in + let%bind type_annotation = + O.merge_annotation + (Some tv) + (Some expr'.type_annotation) + (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in + ok {expr' with type_annotation} + + +and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result = + (* Constant poorman's polymorphism *) + let ct = Operators.Typer.constant_typers in + let%bind typer = + trace_option (unrecognized_constant name loc) @@ + Map.String.find_opt name ct in + trace (constant_error loc lst tv_opt) @@ + typer lst tv_opt + +let untype_type_value (t:O.type_value) : (I.type_expression) result = + match t.simplified with + | Some s -> ok s + | _ -> fail @@ internal_assertion_failure "trying to untype generated type" + +let untype_literal (l:O.literal) : I.literal result = + let open I in + match l with + | Literal_unit -> ok Literal_unit + | Literal_bool b -> ok (Literal_bool b) + | Literal_nat n -> ok (Literal_nat n) + | Literal_timestamp n -> ok (Literal_timestamp n) + | Literal_mutez n -> ok (Literal_mutez n) + | Literal_int n -> ok (Literal_int n) + | Literal_string s -> ok (Literal_string s) + | Literal_bytes b -> ok (Literal_bytes b) + | Literal_address s -> ok (Literal_address s) + | Literal_operation s -> ok (Literal_operation s) + +let rec untype_expression (e:O.annotated_expression) : (I.expression) result = + let open I in + let return e = ok e in + match e.expression with + | E_literal l -> + let%bind l = untype_literal l in + return (e_literal l) + | E_constant (n, lst) -> + let%bind lst' = bind_map_list untype_expression lst in + return (e_constant n lst') + | E_variable n -> + return (e_variable n) + | E_application (f, arg) -> + let%bind f' = untype_expression f in + let%bind arg' = untype_expression arg in + return (e_application f' arg') + | E_lambda {binder ; body} -> ( + let%bind io = get_t_function e.type_annotation in + let%bind (input_type , output_type) = bind_map_pair untype_type_value io in + let%bind result = untype_expression body in + return (e_lambda binder (Some input_type) (Some output_type) result) + ) + | E_tuple lst -> + let%bind lst' = bind_list + @@ List.map untype_expression lst in + return (e_tuple lst') + | E_tuple_accessor (tpl, ind) -> + let%bind tpl' = untype_expression tpl in + return (e_accessor tpl' [Access_tuple ind]) + | E_constructor (n, p) -> + let%bind p' = untype_expression p in + return (e_constructor n p') + | E_record r -> + let%bind r' = bind_smap + @@ SMap.map untype_expression r in + return (e_record r') + | E_record_accessor (r, s) -> + let%bind r' = untype_expression r in + return (e_accessor r' [Access_record s]) + | E_map m -> + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_map m') + | E_big_map m -> + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_big_map m') + | E_list lst -> + let%bind lst' = bind_map_list untype_expression lst in + return (e_list lst') + | E_set lst -> + let%bind lst' = bind_map_list untype_expression lst in + return (e_set lst') + | E_look_up dsi -> + let%bind (a , b) = bind_map_pair untype_expression dsi in + return (e_look_up a b) + | E_matching (ae, m) -> + let%bind ae' = untype_expression ae in + let%bind m' = untype_matching untype_expression m in + return (e_matching ae' m') + | E_sequence _ + | E_loop _ + | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression + | E_let_in {binder;rhs;result} -> + let%bind tv = untype_type_value rhs.type_annotation in + let%bind rhs = untype_expression rhs in + let%bind result = untype_expression result in + return (e_let_in (binder , (Some tv)) rhs result) + +and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> + let open I in + match m with + | Match_bool {match_true ; match_false} -> + let%bind match_true = f match_true in + let%bind match_false = f match_false in + ok @@ Match_bool {match_true ; match_false} + | Match_tuple (lst, b) -> + let%bind b = f b in + ok @@ Match_tuple (lst, b) + | Match_option {match_none ; match_some = (v, some)} -> + let%bind match_none = f match_none in + let%bind some = f some in + let match_some = fst v, some in + ok @@ Match_option {match_none ; match_some} + | Match_list {match_nil ; match_cons = (((hd_name , _) , (tl_name , _)), cons)} -> + let%bind match_nil = f match_nil in + let%bind cons = f cons in + let match_cons = hd_name , tl_name , cons in + ok @@ Match_list {match_nil ; match_cons} + | Match_variant (lst , _) -> + let aux ((a,b),c) = + let%bind c' = f c in + ok ((a,b),c') in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant lst' diff --git a/src/passes/4-typer/typer.mli b/src/passes/4-typer/typer.mli new file mode 100644 index 000000000..ddc2ebb59 --- /dev/null +++ b/src/passes/4-typer/typer.mli @@ -0,0 +1,59 @@ +open Trace + +module I = Ast_simplified +module O = Ast_typed + +module SMap = O.SMap +module Environment = O.Environment + +module Solver : sig + type state = Placeholder_for_state_of_new_typer + val discard_state : state -> unit + val initial_state : state +end + +type environment = Environment.t + +module Errors : sig + (* + val unbound_type_variable : environment -> string -> unit -> error + val unbound_variable : environment -> string -> Location.t -> unit -> error + val match_empty_variant : 'a I.matching -> Location.t -> unit -> error + val match_missing_case : 'a I.matching -> Location.t -> unit -> error + val match_redundant_case : 'a I.matching -> Location.t -> unit -> error + val unbound_constructor : environment -> string -> Location.t -> unit -> error + val unrecognized_constant : string -> Location.t -> unit -> error + *) + val wrong_arity : string -> int -> int -> Location.t -> unit -> error + (* + val match_tuple_wrong_arity : 'a list -> 'b list -> Location.t -> unit -> error + + (* TODO: this should be a trace_info? *) + val program_error : I.program -> unit -> error + val constant_declaration_error : string -> I.expr -> O.type_value option -> unit -> error + val match_error : ?msg:string -> expected:'a I.matching -> actual:O.type_value -> Location.t -> unit -> error + val needs_annotation : I.expression -> string -> unit -> error + val type_error_approximate : ?msg:string -> expected:string -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error + val type_error : ?msg:string -> expected:O.type_value -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error + val bad_tuple_index : int -> I.expression -> O.type_value -> Location.t -> unit -> error + val bad_record_access : string -> I.expression -> O.type_value -> Location.t -> unit -> error + val not_supported_yet : string -> I.expression -> unit -> error + val not_supported_yet_untranspile : string -> O.expression -> unit -> error + val constant_error : Location.t -> O.type_value list -> O.type_value option -> unit -> error + *) +end + +val type_program : I.program -> (O.program * Solver.state) result +val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result +(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *) +val evaluate_type : environment -> I.type_expression -> O.type_value result +val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result +val type_constant : string -> O.type_value list -> O.type_value option -> Location.t -> (string * O.type_value) result +(* +val untype_type_value : O.type_value -> (I.type_expression) result +val untype_literal : O.literal -> I.literal result +*) +val untype_expression : O.annotated_expression -> I.expression result +(* +val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result +*) From 865cf80c77f15a46a7b17be1054892673f82e903 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 1 Nov 2019 09:48:09 -0400 Subject: [PATCH 36/39] Tests pass again, using the old typer --- src/main/compile/of_simplified.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index a443001a5..56ad30c28 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -21,13 +21,23 @@ let compile_expression_as_function_entry (program : program) entry_point : _ res let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) ae : Michelson.t result = let%bind (typed , state) = Typer.type_expression env state ae in (* TODO: move this to typer.ml *) - let typed = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed in + let typed = + if false then + let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed + else + typed + in Of_typed.compile_expression_as_value typed let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) : _ result = let%bind (typed , state) = Typer.type_expression env state ae in (* TODO: move this to typer.ml *) - let typed = let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed in + let typed = + if false then + let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed + else + typed + in Of_typed.compile_expression_as_function typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = From f41625ceb3c8ef20b3944f7a3720b0f622271ab6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Mon, 4 Nov 2019 18:39:56 +0000 Subject: [PATCH 37/39] Rename 4-typer to 4-typer-old (part 1: move files) --- src/passes/{4-typer => 4-typer-old}/dune | 0 src/passes/{4-typer => 4-typer-old}/typer.ml | 0 src/passes/{4-typer => 4-typer-old}/typer.mli | 0 3 files changed, 0 insertions(+), 0 deletions(-) rename src/passes/{4-typer => 4-typer-old}/dune (100%) rename src/passes/{4-typer => 4-typer-old}/typer.ml (100%) rename src/passes/{4-typer => 4-typer-old}/typer.mli (100%) diff --git a/src/passes/4-typer/dune b/src/passes/4-typer-old/dune similarity index 100% rename from src/passes/4-typer/dune rename to src/passes/4-typer-old/dune diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer-old/typer.ml similarity index 100% rename from src/passes/4-typer/typer.ml rename to src/passes/4-typer-old/typer.ml diff --git a/src/passes/4-typer/typer.mli b/src/passes/4-typer-old/typer.mli similarity index 100% rename from src/passes/4-typer/typer.mli rename to src/passes/4-typer-old/typer.mli From 40b318eff68157b849db324a89a5b5ae9151189a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Mon, 4 Nov 2019 18:40:49 +0000 Subject: [PATCH 38/39] Rename 4-typer to 4-typer-old (part 2: make changes) --- src/main/compile/of_simplified.ml | 2 +- src/passes/4-typer-new/solver.ml | 2 ++ src/passes/4-typer-new/typer.ml | 3 ++- src/passes/4-typer-new/typer.mli | 2 +- src/passes/4-typer-new/typer_new.ml | 1 + src/passes/4-typer-old/dune | 5 +++-- src/passes/4-typer-old/typer.ml | 14 +++++++------- src/passes/4-typer-old/typer.mli | 4 ++-- src/passes/4-typer-old/typer_old.ml | 1 + src/passes/4-typer/dune | 17 +++++++++++++++++ src/passes/4-typer/typer.ml | 15 +++++++++++++++ src/passes/4-typer/typer.mli | 18 ++++++++++++++++++ 12 files changed, 70 insertions(+), 14 deletions(-) create mode 100644 src/passes/4-typer-new/typer_new.ml create mode 100644 src/passes/4-typer-old/typer_old.ml create mode 100644 src/passes/4-typer/dune create mode 100644 src/passes/4-typer/typer.ml create mode 100644 src/passes/4-typer/typer.mli diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 56ad30c28..2c816338d 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -22,7 +22,7 @@ let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ~(stat let%bind (typed , state) = Typer.type_expression env state ae in (* TODO: move this to typer.ml *) let typed = - if false then + if Typer.use_new_typer then let () = failwith "TODO : subst all" in let _todo = ignore (env, state) in typed else typed diff --git a/src/passes/4-typer-new/solver.ml b/src/passes/4-typer-new/solver.ml index e132784ee..6f9100d2a 100644 --- a/src/passes/4-typer-new/solver.ml +++ b/src/passes/4-typer-new/solver.ml @@ -1113,3 +1113,5 @@ let aggregate_constraints : state -> type_constraint list -> state result = fun constraints, and that all existential variables are instantiated (possibly by first generalizing the type and then using the polymorphic type argument to instantiate the existential). *) + +let placeholder_for_state_of_new_typer () = initial_state diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index 6a82ba9a6..6f7b82eea 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -391,7 +391,8 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in return (T_constant(Type_name cst, lst')) -and type_expression : environment -> Solver.state -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ae -> +and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ?tv_opt ae -> + let () = ignore tv_opt in (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *) let open Solver in let module L = Logger.Stateful() in let return : _ -> Solver.state -> _ -> _ (* return of type_expression *) = fun expr state constraints type_name -> diff --git a/src/passes/4-typer-new/typer.mli b/src/passes/4-typer-new/typer.mli index e60ce51bb..386313702 100644 --- a/src/passes/4-typer-new/typer.mli +++ b/src/passes/4-typer-new/typer.mli @@ -44,7 +44,7 @@ val type_program' : I.program -> (O.program) result (* TODO: merge with type_pro val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *) val evaluate_type : environment -> I.type_expression -> O.type_value result -val type_expression : environment -> Solver.state -> I.expression -> (O.annotated_expression * Solver.state) result +val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result val type_constant : string -> O.type_value list -> O.type_value option -> Location.t -> (string * O.type_value) result (* val untype_type_value : O.type_value -> (I.type_expression) result diff --git a/src/passes/4-typer-new/typer_new.ml b/src/passes/4-typer-new/typer_new.ml new file mode 100644 index 000000000..ba132b977 --- /dev/null +++ b/src/passes/4-typer-new/typer_new.ml @@ -0,0 +1 @@ +include Typer diff --git a/src/passes/4-typer-old/dune b/src/passes/4-typer-old/dune index 0ee58cc43..29e48c79e 100644 --- a/src/passes/4-typer-old/dune +++ b/src/passes/4-typer-old/dune @@ -1,11 +1,12 @@ (library - (name typer) - (public_name ligo.typer) + (name typer_old) + (public_name ligo.typer_old) (libraries simple-utils tezos-utils ast_simplified ast_typed + typer_new operators ) (preprocess diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 2751225eb..c21943e5e 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -8,11 +8,11 @@ module SMap = O.SMap module Environment = O.Environment -module Solver = struct +module Solver = Typer_new.Solver (* struct type state = Placeholder_for_state_of_new_typer let discard_state (_ : state) = () let initial_state = Placeholder_for_state_of_new_typer -end +end *) type environment = Environment.t @@ -226,7 +226,7 @@ open Errors let rec type_program (p:I.program) : (O.program * Solver.state) result = let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = - let%bind ed' = (bind_map_location (type_declaration e Solver.Placeholder_for_state_of_new_typer)) d in + let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in match d' with @@ -236,20 +236,20 @@ let rec type_program (p:I.program) : (O.program * Solver.state) result = let%bind (_, lst) = trace (fun () -> program_error p ()) @@ bind_fold_list aux (Environment.full_empty, []) p in - ok @@ (List.rev lst , Solver.Placeholder_for_state_of_new_typer) + ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ())) and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) : I.declaration -> (environment * Solver.state * O.declaration option) result = function | Declaration_type (type_name , type_expression) -> let%bind tv = evaluate_type env type_expression in let env' = Environment.add_type type_name tv env in - ok (env', Solver.Placeholder_for_state_of_new_typer , None) + ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None) | Declaration_constant (name , tv_opt , expression) -> ( let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind ae' = trace (constant_declaration_error name expression tv'_opt) @@ type_expression' ?tv_opt:tv'_opt env expression in let env' = Environment.add_ez_ae name ae' env in - ok (env', Solver.Placeholder_for_state_of_new_typer , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) + ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) ) and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> I.expression -> Location.t -> o O.matching result = @@ -384,7 +384,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result = and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result = fun e _placeholder_for_state_of_new_typer ?tv_opt ae -> let%bind res = type_expression' e ?tv_opt ae in - ok (res, Solver.Placeholder_for_state_of_new_typer) + ok (res, (Solver.placeholder_for_state_of_new_typer ())) and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result = fun e ?tv_opt ae -> let module L = Logger.Stateful() in let return expr tv = diff --git a/src/passes/4-typer-old/typer.mli b/src/passes/4-typer-old/typer.mli index ddc2ebb59..315d38c84 100644 --- a/src/passes/4-typer-old/typer.mli +++ b/src/passes/4-typer-old/typer.mli @@ -6,11 +6,11 @@ module O = Ast_typed module SMap = O.SMap module Environment = O.Environment -module Solver : sig +module Solver : module type of Typer_new.Solver (* sig type state = Placeholder_for_state_of_new_typer val discard_state : state -> unit val initial_state : state -end +end *) type environment = Environment.t diff --git a/src/passes/4-typer-old/typer_old.ml b/src/passes/4-typer-old/typer_old.ml new file mode 100644 index 000000000..ba132b977 --- /dev/null +++ b/src/passes/4-typer-old/typer_old.ml @@ -0,0 +1 @@ +include Typer diff --git a/src/passes/4-typer/dune b/src/passes/4-typer/dune new file mode 100644 index 000000000..dc6164c4f --- /dev/null +++ b/src/passes/4-typer/dune @@ -0,0 +1,17 @@ +(library + (name typer) + (public_name ligo.typer) + (libraries + simple-utils + tezos-utils + ast_simplified + ast_typed + typer_old + typer_new + operators + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml new file mode 100644 index 000000000..cd06f1a79 --- /dev/null +++ b/src/passes/4-typer/typer.ml @@ -0,0 +1,15 @@ +let use_new_typer = false + +module I = Ast_simplified +module O = Ast_typed + +module SMap = O.SMap +module Environment = O.Environment + +module Solver = Typer_new.Solver (* Both the old typer and the new typer use the same solver state. *) + +type environment = Environment.t + +let type_program = if use_new_typer then Typer_new.type_program else Typer_old.type_program +let type_expression = if use_new_typer then Typer_new.type_expression else Typer_old.type_expression +let untype_expression = if use_new_typer then Typer_new.untype_expression else Typer_old.untype_expression diff --git a/src/passes/4-typer/typer.mli b/src/passes/4-typer/typer.mli new file mode 100644 index 000000000..4468ed042 --- /dev/null +++ b/src/passes/4-typer/typer.mli @@ -0,0 +1,18 @@ +val use_new_typer : bool + +open Trace + +module I = Ast_simplified +module O = Ast_typed + +module SMap = O.SMap +module Environment = O.Environment + +module Solver = Typer_new.Solver + +type environment = Environment.t + +val type_program : I.program -> (O.program * Solver.state) result +val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result +val untype_expression : O.annotated_expression -> I.expression result + From 0b7a84e9491c9adacc22b7d188e4d2ad7490b5f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 5 Nov 2019 21:51:30 +0000 Subject: [PATCH 39/39] Fixed qwerty typo + small cleanup --- src/passes/4-typer-new/solver.ml | 2 +- src/passes/4-typer-old/typer.ml | 6 +----- src/passes/4-typer-old/typer.mli | 6 +----- 3 files changed, 3 insertions(+), 11 deletions(-) diff --git a/src/passes/4-typer-new/solver.ml b/src/passes/4-typer-new/solver.ml index 6f9100d2a..f134ddf6e 100644 --- a/src/passes/4-typer-new/solver.ml +++ b/src/passes/4-typer-new/solver.ml @@ -1070,7 +1070,7 @@ let initial_state : state = (* { inferred for all bindings and expressions, etc. Also, we should check at these places that we indeed do not need the - state any further. Suwanne *) + state any further. Suzanne *) let discard_state (_ : state) = () (* let replace_var_in_state = fun (v : type_variable) (state : state) -> *) diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index c21943e5e..8abdca6db 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -8,11 +8,7 @@ module SMap = O.SMap module Environment = O.Environment -module Solver = Typer_new.Solver (* struct - type state = Placeholder_for_state_of_new_typer - let discard_state (_ : state) = () - let initial_state = Placeholder_for_state_of_new_typer -end *) +module Solver = Typer_new.Solver type environment = Environment.t diff --git a/src/passes/4-typer-old/typer.mli b/src/passes/4-typer-old/typer.mli index 315d38c84..361ffa612 100644 --- a/src/passes/4-typer-old/typer.mli +++ b/src/passes/4-typer-old/typer.mli @@ -6,11 +6,7 @@ module O = Ast_typed module SMap = O.SMap module Environment = O.Environment -module Solver : module type of Typer_new.Solver (* sig - type state = Placeholder_for_state_of_new_typer - val discard_state : state -> unit - val initial_state : state -end *) +module Solver : module type of Typer_new.Solver type environment = Environment.t