diff --git a/src/passes/1-parser/cameligo/Scoping.ml b/src/passes/1-parser/cameligo/Scoping.ml index 651306022..e1332b96d 100644 --- a/src/passes/1-parser/cameligo/Scoping.ml +++ b/src/passes/1-parser/cameligo/Scoping.ml @@ -22,7 +22,7 @@ module Ord = struct type t = AST.variable let compare v1 v2 = - compare v1.value v2.value + String.compare v1.value v2.value end module VarSet = Set.Make (Ord) diff --git a/src/passes/1-parser/pascaligo/Scoping.ml b/src/passes/1-parser/pascaligo/Scoping.ml index 64a8eea52..3fc439efb 100644 --- a/src/passes/1-parser/pascaligo/Scoping.ml +++ b/src/passes/1-parser/pascaligo/Scoping.ml @@ -23,7 +23,7 @@ module Ord = struct type t = AST.variable let compare v1 v2 = - compare v1.value v2.value + String.compare v1.value v2.value end module VarSet = Set.Make (Ord) diff --git a/src/stages/4-ast_typed/.gitignore b/src/stages/4-ast_typed/.gitignore index 39f5407d5..189a4ee60 100644 --- a/src/stages/4-ast_typed/.gitignore +++ b/src/stages/4-ast_typed/.gitignore @@ -1,2 +1,3 @@ /generated_fold.ml - +/generated_map.ml +/generated_o.ml diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml index c36fcebcb..1e503ace6 100644 --- a/src/stages/4-ast_typed/PP_generic.ml +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -1,116 +1,119 @@ +open Types open Fold open Format open PP_helpers -let needs_parens = { - generic = (fun state info -> - match info.node_instance.instance_kind with - | RecordInstance _ -> false - | VariantInstance _ -> true - | PolyInstance { poly =_; arguments=_; poly_continue } -> - (poly_continue state) - ); - type_variable = (fun _ _ _ -> true) ; - bool = (fun _ _ _ -> false) ; - int = (fun _ _ _ -> false) ; - z = (fun _ _ _ -> false) ; - string = (fun _ _ _ -> false) ; - ligo_string = (fun _ _ _ -> false) ; - bytes = (fun _ _ _ -> false) ; - unit = (fun _ _ _ -> false) ; - packed_internal_operation = (fun _ _ _ -> false) ; - expression_variable = (fun _ _ _ -> false) ; - constructor' = (fun _ _ _ -> false) ; - location = (fun _ _ _ -> false) ; - label = (fun _ _ _ -> false) ; - ast_core_type_expression = (fun _ _ _ -> true) ; - constructor_map = (fun _ _ _ _ -> false) ; - label_map = (fun _ _ _ _ -> false) ; - list = (fun _ _ _ _ -> false) ; - location_wrap = (fun _ _ _ _ -> false) ; - option = (fun _visitor _continue _state o -> - match o with None -> false | Some _ -> true) ; - poly_unionfind = (fun _ _ _ _ -> false) ; - poly_set = (fun _ _ _ _ -> false) ; - typeVariableMap = (fun _ _ _ _ -> false) ; - } +module M = struct + type no_state = NoState + let needs_parens = { + generic = (fun NoState info -> + match info.node_instance.instance_kind with + | RecordInstance _ -> false + | VariantInstance _ -> true + | PolyInstance { poly =_; arguments=_; poly_continue } -> + (poly_continue NoState) + ); + generic_empty_ctor = (fun _ -> false) ; + type_variable = (fun _ _ _ -> true) ; + bool = (fun _ _ _ -> false) ; + int = (fun _ _ _ -> false) ; + z = (fun _ _ _ -> false) ; + string = (fun _ _ _ -> false) ; + ligo_string = (fun _ _ _ -> false) ; + bytes = (fun _ _ _ -> false) ; + unit = (fun _ _ _ -> false) ; + packed_internal_operation = (fun _ _ _ -> false) ; + expression_variable = (fun _ _ _ -> false) ; + constructor' = (fun _ _ _ -> false) ; + location = (fun _ _ _ -> false) ; + label = (fun _ _ _ -> false) ; + ast_core_type_expression = (fun _ _ _ -> true) ; + constructor_map = (fun _ _ _ _ -> false) ; + label_map = (fun _ _ _ _ -> false) ; + list = (fun _ _ _ _ -> false) ; + location_wrap = (fun _ _ _ _ -> false) ; + option = (fun _visitor _continue _state o -> + match o with None -> false | Some _ -> true) ; + poly_unionfind = (fun _ _ _ _ -> false) ; + poly_set = (fun _ _ _ _ -> false) ; + typeVariableMap = (fun _ _ _ _ -> false) ; + } -let op ppf = { - generic = (fun () info -> - match info.node_instance.instance_kind with - | RecordInstance { fields } -> - let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) = - fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in - fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields - | VariantInstance { constructor ; _ } -> - if constructor.cf_new_fold needs_parens false - then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () - else let spc = if String.equal constructor.cf.type_ "" then "" else " " in - fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) () - | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue ()) - ); - int = (fun _visitor () i -> fprintf ppf "%i" i ); - type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; - bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ; - z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ; - string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ; - ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ; - bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ; - unit = (fun _visitor () () -> fprintf ppf "()") ; - packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ; - expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ; - constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ; - location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ; - label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ; - ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; - constructor_map = (fun _visitor continue () cmap -> - let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in - let aux ppf (Constructor k, v) = - fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in - fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); - label_map = (fun _visitor continue () lmap -> - let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in - let aux ppf (Label k, v) = - fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in - fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); - list = (fun _visitor continue () lst -> - let aux ppf elt = - fprintf ppf "%a" (fun _ppf -> continue ()) elt in - fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); - location_wrap = (fun _visitor continue () lwrap -> - let ({ wrap_content; location } : _ Location.wrap) = lwrap in - fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location); - (* list_ne = (fun _visitor continue () (first, lst) -> - let aux ppf elt = - fprintf ppf "%a" (fun _ppf -> continue ()) elt in - fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *) - option = (fun _visitor continue () o -> - match o with - | None -> fprintf ppf "None" - | Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ; - poly_unionfind = (fun _visitor continue () p -> - let lst = (UnionFind.Poly2.partitions p) in - let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]" - (fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p) - (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in - let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in - fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst); - poly_set = (fun _visitor continue () set -> - let lst = (RedBlackTrees.PolySet.elements set) in - fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst); - typeVariableMap = (fun _visitor continue () tvmap -> - let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in - let aux ppf (k, v) = - fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in - fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); - } + let op ppf : (no_state, unit) fold_config = { + generic = (fun NoState info -> + match info.node_instance.instance_kind with + | RecordInstance { fields } -> + let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) = + fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in + fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields + | VariantInstance { constructor ; _ } -> + if constructor.cf_new_fold needs_parens NoState + then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState + else let spc = if String.equal constructor.cf.type_ "" then "" else " " in + fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState + | PolyInstance { poly=_; arguments=_; poly_continue } -> + (poly_continue NoState) + ); + generic_empty_ctor = (fun NoState -> ()) ; + int = (fun _visitor NoState i -> fprintf ppf "%i" i ); + type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; + bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ; + z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ; + string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ; + ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ; + bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ; + unit = (fun _visitor NoState () -> fprintf ppf "()") ; + packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ; + expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ; + constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ; + location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ; + label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ; + ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; + constructor_map = (fun _visitor continue NoState cmap -> + let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in + let aux ppf (Constructor k, v) = + fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in + fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); + label_map = (fun _visitor continue NoState lmap -> + let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in + let aux ppf (Label k, v) = + fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in + fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); + list = (fun _visitor continue NoState lst -> + let aux ppf elt = + fprintf ppf "%a" (fun _ppf -> continue NoState) elt in + fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); + location_wrap = (fun _visitor continue NoState lwrap -> + let ({ wrap_content; location } : _ Location.wrap) = lwrap in + fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location); + option = (fun _visitor continue NoState o -> + match o with + | None -> fprintf ppf "None" + | Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ; + poly_unionfind = (fun _visitor continue NoState p -> + let lst = (UnionFind.Poly2.partitions p) in + let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]" + (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p) + (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in + let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in + fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst); + poly_set = (fun _visitor continue NoState set -> + let lst = (RedBlackTrees.PolySet.elements set) in + fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst); + typeVariableMap = (fun _visitor continue NoState tvmap -> + let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in + let aux ppf (k, v) = + fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in + fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); + } -let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> - fold (op ppf) () v + let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> + fold (op ppf) NoState v +end include Fold.Folds(struct - type state = unit ;; + type in_state = M.no_state ;; + type out_state = unit ;; type 'a t = formatter -> 'a -> unit ;; - let f = print ;; + let f = M.print ;; end) diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml new file mode 100644 index 000000000..e85aace9d --- /dev/null +++ b/src/stages/4-ast_typed/ast.ml @@ -0,0 +1,622 @@ +[@@@warning "-30"] + +open Types_utils + +(* pseudo-typeclasses: interfaces that must be provided for arguments + of the givent polymmorphic types. For now, only one typeclass can + be specified for a given polymorphic type. The implementation is + provided by the Comparable module *) +(*@ typeclass poly_unionfind comparable *) +(*@ typeclass poly_set comparable *) + +type type_constant = + | TC_unit + | TC_string + | TC_bytes + | TC_nat + | TC_int + | TC_mutez + | TC_operation + | TC_address + | TC_key + | TC_key_hash + | TC_chain_id + | TC_signature + | TC_timestamp + | TC_void + +type te_cmap = ctor_content constructor_map +and te_lmap = field_content label_map +and type_meta = ast_core_type_expression option + +and type_content = + | T_sum of te_cmap + | T_record of te_lmap + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of type_operator + +and arrow = { + type1: type_expression; + type2: type_expression; + } + +and annot_option = string option + +and ctor_content = { + ctor_type : type_expression; + michelson_annotation : annot_option; + ctor_decl_pos : int; +} + +and field_content = { + field_type : type_expression; + michelson_annotation : annot_option; + field_decl_pos : int; +} + +and type_map_args = { + k : type_expression; + v : type_expression; + } + +and michelson_or_args = { + l : type_expression; + r : type_expression; + } + +and type_operator = + | TC_contract of type_expression + | TC_option of type_expression + | TC_list of type_expression + | TC_set of type_expression + | TC_map of type_map_args + | TC_big_map of type_map_args + | TC_map_or_big_map of type_map_args + +and type_expression = { + type_content: type_content; + type_meta: type_meta; + location: location; + } + +type literal = + | Literal_unit + | Literal_int of z + | Literal_nat of z + | Literal_timestamp of z + | Literal_mutez of z + | Literal_string of ligo_string + | Literal_bytes of bytes + | Literal_address of string + | Literal_signature of string + | Literal_key of string + | Literal_key_hash of string + | Literal_chain_id of string + | Literal_void + | Literal_operation of packed_internal_operation + + +and matching_content_cons = { + hd : expression_variable; + tl : expression_variable; + body : expression; + tv : type_expression; + } + +and matching_content_list = { + match_nil : expression ; + match_cons : matching_content_cons; + } + +and matching_content_some = { + opt : expression_variable ; + body : expression ; + tv : type_expression ; + } + +and matching_content_option = { + match_none : expression ; + match_some : matching_content_some ; + } + +and expression_variable_list = expression_variable list +and type_expression_list = type_expression list + +and matching_content_tuple = { + vars : expression_variable_list ; + body : expression ; + tvs : type_expression_list ; + } + +and matching_content_case = { + constructor : constructor' ; + pattern : expression_variable ; + body : expression ; + } + +and matching_content_case_list = matching_content_case list + +and matching_content_variant = { + cases: matching_content_case_list; + tv: type_expression; + } + +and matching_expr = + | Match_list of matching_content_list + | Match_option of matching_content_option + | Match_tuple of matching_content_tuple + | Match_variant of matching_content_variant + +and constant' = + | C_INT + | C_UNIT + | C_NIL + | C_NOW + | C_IS_NAT + | C_SOME + | C_NONE + | C_ASSERTION + | C_ASSERT_INFERRED + | C_FAILWITH + | C_UPDATE + (* Loops *) + | C_ITER + | C_FOLD_WHILE + | C_FOLD_CONTINUE + | C_FOLD_STOP + | C_LOOP_LEFT + | C_LOOP_CONTINUE + | C_LOOP_STOP + | C_FOLD + (* MATH *) + | C_NEG + | C_ABS + | C_ADD + | C_SUB + | C_MUL + | C_EDIV + | C_DIV + | C_MOD + (* LOGIC *) + | C_NOT + | C_AND + | C_OR + | C_XOR + | C_LSL + | C_LSR + (* COMPARATOR *) + | C_EQ + | C_NEQ + | C_LT + | C_GT + | C_LE + | C_GE + (* Bytes/ String *) + | C_SIZE + | C_CONCAT + | C_SLICE + | C_BYTES_PACK + | C_BYTES_UNPACK + | C_CONS + (* Pair *) + | C_PAIR + | C_CAR + | C_CDR + | C_LEFT + | C_RIGHT + (* Set *) + | C_SET_EMPTY + | C_SET_LITERAL + | C_SET_ADD + | C_SET_REMOVE + | C_SET_ITER + | C_SET_FOLD + | C_SET_MEM + (* List *) + | C_LIST_EMPTY + | C_LIST_LITERAL + | C_LIST_ITER + | C_LIST_MAP + | C_LIST_FOLD + (* Maps *) + | C_MAP + | C_MAP_EMPTY + | C_MAP_LITERAL + | C_MAP_GET + | C_MAP_GET_FORCE + | C_MAP_ADD + | C_MAP_REMOVE + | C_MAP_UPDATE + | C_MAP_ITER + | C_MAP_MAP + | C_MAP_FOLD + | C_MAP_MEM + | C_MAP_FIND + | C_MAP_FIND_OPT + (* Big Maps *) + | C_BIG_MAP + | C_BIG_MAP_EMPTY + | C_BIG_MAP_LITERAL + (* Crypto *) + | C_SHA256 + | C_SHA512 + | C_BLAKE2b + | C_HASH + | C_HASH_KEY + | C_CHECK_SIGNATURE + | C_CHAIN_ID + (* Blockchain *) + | C_CALL + | C_CONTRACT + | C_CONTRACT_OPT + | C_CONTRACT_ENTRYPOINT + | C_CONTRACT_ENTRYPOINT_OPT + | C_AMOUNT + | C_BALANCE + | C_SOURCE + | C_SENDER + | C_ADDRESS + | C_SELF + | C_SELF_ADDRESS + | C_IMPLICIT_ACCOUNT + | C_SET_DELEGATE + | C_CREATE_CONTRACT + | C_CONVERT_TO_LEFT_COMB + | C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB + +and declaration_loc = declaration location_wrap + +and program = declaration_loc list + +and declaration_constant = { + binder : expression_variable ; + expr : expression ; + inline : bool ; + post_env : environment ; + } + +and declaration = + (* A Declaration_constant is described by + * a name + a type-annotated expression + * a boolean indicating whether it should be inlined + * the environment before the declaration (the original environment) + * the environment after the declaration (i.e. with that new declaration added to the original environment). *) + | Declaration_constant of declaration_constant + (* + | Declaration_type of (type_variable * type_expression) + | Declaration_constant of (named_expression * (environment * environment)) + *) +(* | Macro_declaration of macro_declaration *) + +and expression = { + expression_content: expression_content ; + location: location ; + type_expression: type_expression ; + environment: environment ; + } + +and map_kv = { + k : expression ; + v : expression ; + } + +and look_up = { + ds : expression; + ind : expression; + } + +and expression_label_map = expression label_map +and map_kv_list = map_kv list +and expression_list = expression list + +and expression_content = + (* Base *) + | E_literal of literal + | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *) + | E_variable of expression_variable + | E_application of application + | E_lambda of lambda + | E_recursive of recursive + | E_let_in of let_in + (* Variant *) + | E_constructor of constructor (* For user defined constructors *) + | E_matching of matching + (* Record *) + | E_record of expression_label_map + | E_record_accessor of record_accessor + | E_record_update of record_update + +and constant = { + cons_name: constant' ; + arguments: expression_list ; + } + +and application = { + lamb: expression ; + args: expression ; + } + +and lambda = { + binder: expression_variable ; + (* input_type: type_expression option ; *) + (* output_type: type_expression option ; *) + result: expression ; + } + +and let_in = { + let_binder: expression_variable ; + rhs: expression ; + let_result: expression ; + inline : bool ; + } + +and recursive = { + fun_name : expression_variable; + fun_type : type_expression; + lambda : lambda; +} + +and constructor = { + constructor: constructor'; + element: expression ; + } + +and record_accessor = { + record: expression ; + path: label ; + } + +and record_update = { + record: expression ; + path: label ; + update: expression ; + } + +and matching = { + matchee: expression ; + cases: matching_expr ; + } + +and ascription = { + anno_expr: expression ; + type_annotation: type_expression ; + } + +and environment_element_definition = + | ED_binder + | ED_declaration of environment_element_definition_declaration + +and environment_element_definition_declaration = { + expr: expression ; + free_variables: free_variables ; + } + +and free_variables = expression_variable list + +and environment_element = { + type_value: type_expression ; + source_environment: environment ; + definition: environment_element_definition ; + } + +and expression_environment = environment_binding list + +and environment_binding = { + expr_var: expression_variable ; + env_elt: environment_element ; + } + +and type_environment = type_environment_binding list + +and type_environment_binding = { + type_variable: type_variable ; + type_: type_expression ; +} + +and environment = { + expression_environment: expression_environment ; + type_environment: type_environment ; +} + +and named_type_content = { + type_name : type_variable; + type_value : type_expression; + } + + + + + +(* Solver types *) + +(* typevariable: to_string = (fun s -> Format.asprintf "%a" Var.pp s) *) +type unionfind = type_variable poly_unionfind + +(* core *) + +(* add information on the type or the kind for operator *) +type constant_tag = + | C_arrow (* * -> * -> * isn't this wrong? *) + | C_option (* * -> * *) + | C_record (* ( label , * ) … -> * *) + | C_variant (* ( label , * ) … -> * *) + | C_map (* * -> * -> * *) + | C_big_map (* * -> * -> * *) + | C_list (* * -> * *) + | C_set (* * -> * *) + | C_unit (* * *) + | C_string (* * *) + | C_nat (* * *) + | C_mutez (* * *) + | C_timestamp (* * *) + | C_int (* * *) + | C_address (* * *) + | C_bytes (* * *) + | C_key_hash (* * *) + | C_key (* * *) + | C_signature (* * *) + | C_operation (* * *) + | C_contract (* * -> * *) + | C_chain_id (* * *) + +(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *) +type type_value = + | P_forall of p_forall + | P_variable of type_variable + | P_constant of p_constant + | P_apply of p_apply + +and p_apply = { + tf : type_value ; + targ : type_value ; +} +and p_ctor_args = type_value list +and p_constant = { + p_ctor_tag : constant_tag ; + p_ctor_args : p_ctor_args ; + } +and p_constraints = type_constraint list +and p_forall = { + binder : type_variable ; + constraints : p_constraints ; + body : type_value ; +} + +(* Different type of constraint *) +and ctor_args = type_variable list (* non-empty list *) +and simple_c_constructor = { + ctor_tag : constant_tag ; + ctor_args : ctor_args ; + } +and simple_c_constant = { + constant_tag: constant_tag ; (* for type constructors that do not take arguments *) + } +and c_const = { + c_const_tvar : type_variable ; + c_const_tval : type_value ; + } +and c_equation = { + aval : type_value ; + bval : type_value ; +} +and tc_args = type_value list +and c_typeclass = { + tc_args : tc_args ; + typeclass : typeclass ; +} +and c_access_label = { + c_access_label_tval : type_value ; + accessor : label ; + c_access_label_tvar : type_variable ; + } + +and type_constraint = { + reason : string ; + c : type_constraint_ ; +} +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 *) +(* | … *) + +(* is the first list in case on of the type of the type class as a kind *->*->* ? *) +and tc_allowed = type_value list +and typeclass = tc_allowed list + +(* end core *) + +type c_constructor_simpl_typeVariableMap = c_constructor_simpl typeVariableMap +and constraints_typeVariableMap = constraints typeVariableMap +and type_constraint_simpl_list = type_constraint_simpl list +and 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(α,β)) *) + (* TODO : the rhs of the map should not repeat the variable name. *) + assignments : c_constructor_simpl_typeVariableMap ; + grouped_by_variable : constraints_typeVariableMap ; (* map from (unionfind) variables to constraints containing them *) + cycle_detection_toposort : unit ; (* example of structured db that we'll add later *) +} + +and c_constructor_simpl_list = c_constructor_simpl list +and c_poly_simpl_list = c_poly_simpl list +and c_typeclass_simpl_list = c_typeclass_simpl list +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 *) +} +and type_variable_list = type_variable list +and c_constructor_simpl = { + tv : type_variable; + c_tag : constant_tag; + tv_list : type_variable_list; +} +and c_const_e = { + c_const_e_tv : type_variable ; + c_const_e_te : type_expression ; + } +and c_equation_e = { + aex : type_expression ; + bex : type_expression ; + } +and c_typeclass_simpl = { + tc : typeclass ; + args : type_variable_list ; +} +and c_poly_simpl = { + tv : type_variable ; + forall : p_forall ; +} +and type_constraint_simpl = { + reason_simpl : string ; + c_simpl : type_constraint_simpl_ ; + } +and type_constraint_simpl_ = + | SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) + | SC_Alias of c_alias (* α = β *) + | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *) + | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) + +and c_alias = { + a : type_variable ; + b : type_variable ; + } + + +(* sub-sub component: lazy selector (don't re-try all selectors every time) *) +(* For now: just re-try everytime *) + +(* 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_specialize1 = { + poly : c_poly_simpl ; + a_k_var : c_constructor_simpl ; + } + +type m_break_ctor__already_selected = output_break_ctor poly_set +type m_specialize1__already_selected = output_specialize1 poly_set + +type already_selected = { + break_ctor : m_break_ctor__already_selected ; + specialize1 : m_specialize1__already_selected ; +} + +type typer_state = { + structured_dbs : structured_dbs ; + already_selected : already_selected ; +} diff --git a/src/stages/4-ast_typed/comparable.ml b/src/stages/4-ast_typed/comparable.ml new file mode 100644 index 000000000..255ed7fbe --- /dev/null +++ b/src/stages/4-ast_typed/comparable.ml @@ -0,0 +1 @@ +include Compare_generic.Comparable diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml new file mode 100644 index 000000000..e630f1e3a --- /dev/null +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -0,0 +1,196 @@ +open Types +open Generated_fold + +module M = struct + let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *) + type 'a lz = unit -> 'a (* Lazy values *) + type t = + | EmptyCtor + | Record of string * (string * t lz) list + | VariantConstructor of string * string * t lz + | Bool of inline + | Bytes of bytes + | Constructor' of string + | Expression_variable of expression_variable + | Int of int + | Label' of string + | Ligo_string of ligo_string + | Location of location + | Operation of packed_internal_operation + | Str of string + | Type_expression of ast_core_type_expression + | Unit of unit + | Var of type_variable + | Z of z + | List of t lz list + | Location_wrap of t lz Location.wrap + | CMap of (constructor' * t lz) list + | LMap of (label * t lz) list + | UnionFind of t lz list list + | Set of t lz list + | TypeVariableMap of (type_variable * t lz) list + + type no_state = NoState + + (* TODO: make these functions return a lazy stucture *) + let op : (no_state, t) fold_config = { + generic = (fun NoState info -> + match info.node_instance.instance_kind with + | RecordInstance { fields } -> + let aux (fld : ('xi, 'xo) Adt_info.ctor_or_field_instance) = + ( fld.cf.name , fun () -> fld.cf_continue NoState ) in + Record ("name_of_the_record", List.map aux fields) + | VariantInstance { constructor ; _ } -> + VariantConstructor ("name_of_the_variant", constructor.cf.name, fun () -> constructor.cf_continue NoState) + | PolyInstance { poly=_; arguments=_; poly_continue } -> + poly_continue NoState + ); + generic_empty_ctor = (fun NoState -> EmptyCtor) ; + int = (fun _visitor _state i -> Int i ); + type_variable = (fun _visitor _state type_variable -> Var type_variable) ; + bool = (fun _visitor _state b -> Bool b) ; + z = (fun _visitor _state i -> Z i) ; + string = (fun _visitor _state str -> Str str) ; + ligo_string = (fun _visitor _state str -> Ligo_string str) ; + bytes = (fun _visitor _state bytes -> Bytes bytes) ; + unit = (fun _visitor _state () -> Unit ()) ; + packed_internal_operation = (fun _visitor _state op -> Operation op) ; + expression_variable = (fun _visitor _state ev -> Expression_variable ev) ; + constructor' = (fun _visitor _state (Constructor c) -> Constructor' c) ; + location = (fun _visitor _state loc -> Location loc) ; + label = (fun _visitor _state (Label lbl) -> Label' lbl) ; + ast_core_type_expression = (fun _visitor _state te -> Type_expression te) ; + constructor_map = (fun _visitor continue _state cmap -> + let kcmp (Constructor a, _) (Constructor b, _) = String.compare a b in + let lst = List.sort kcmp (CMap.bindings cmap) in + CMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); + label_map = (fun _visitor continue _state lmap -> + let kcmp (Label a, _) (Label b, _) = String.compare a b in + let lst = List.sort kcmp (LMap.bindings lmap) in + LMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); + list = (fun _visitor continue _state lst -> + (List (List.map (fun x () -> continue NoState x) lst))); + location_wrap = (fun _visitor continue _state lwrap -> + let ({ wrap_content; location } : _ Location.wrap) = lwrap in + (Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location})); + option = (fun _visitor continue _state o -> + match o with + | None -> VariantConstructor ("built-in:option", "None", fun () -> EmptyCtor) + | Some v -> VariantConstructor ("built-in:option", "Some", fun () -> continue NoState v)); + poly_unionfind = (fun _visitor continue _state p -> + (* UnionFind.Poly2.partitions returns the partitions in a + deterministic order, and the elements within a given + partition also follow a deterministic order. *) + let lst = (UnionFind.Poly2.partitions p) in + let aux l = List.map (fun x () -> continue NoState x) l in + UnionFind (List.map aux lst)); + poly_set = (fun _visitor continue _state set -> + Set (List.map (fun x () -> continue NoState x) (RedBlackTrees.PolySet.elements set))); + typeVariableMap = (fun _visitor continue _state tvmap -> + let kcmp (a, _) (b, _) = Var.compare a b in + let lst = List.sort kcmp (RedBlackTrees.PolyMap.bindings tvmap) in + TypeVariableMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); + } + + let serialize : ((no_state, t) fold_config -> no_state -> 'a -> t) -> 'a -> t = fun fold v -> + fold op NoState v + + (* What follows should be roughly the same for all ASTs, so it + should be easy to share a single copy of that and of the t type + definition above. *) + + (* Generate a unique tag for each case handled below. We can then + compare data by their tag and contents. *) + let tag = function + | EmptyCtor -> 0 + | Record _ -> 1 + | VariantConstructor _ -> 2 + | Bool _ -> 3 + | Bytes _ -> 4 + | Constructor' _ -> 5 + | Expression_variable _ -> 6 + | Int _ -> 7 + | Label' _ -> 8 + | Ligo_string _ -> 9 + | Location _ -> 10 + | Operation _ -> 11 + | Str _ -> 12 + | Type_expression _ -> 13 + | Unit _ -> 14 + | Var _ -> 15 + | Z _ -> 16 + | List _ -> 17 + | Location_wrap _ -> 18 + | CMap _ -> 19 + | LMap _ -> 20 + | UnionFind _ -> 21 + | Set _ -> 22 + | TypeVariableMap _ -> 23 + + let cmp2 f a1 b1 g a2 b2 = match f a1 b1 with 0 -> g a2 b2 | c -> c + let cmp3 f a1 b1 g a2 b2 h a3 b3 = match f a1 b1 with 0 -> (match g a2 b2 with 0 -> h a3 b3 | c -> c) | c -> c + let rec compare_field (na, va) (nb, vb) = cmp2 String.compare na nb compare_lz_t va vb + and compare_cmap_entry (Constructor na, va) (Constructor nb, vb) = cmp2 String.compare na nb compare_lz_t va vb + and compare_lmap_entry (Label na, va) (Label nb, vb) = cmp2 String.compare na nb compare_lz_t va vb + and compare_tvmap_entry (tva, va) (tvb, vb) = cmp2 Var.compare tva tvb compare_lz_t va vb + and compare_lz_t a b = compare_t (a ()) (b ()) + and compare_t (a : t) (b : t) = + match (a, b) with + | (EmptyCtor, EmptyCtor) -> failwith "Should not happen (unless for ctors with no args?)" + | (Record (a, fa), Record (b, fb)) -> cmp2 String.compare a b (List.compare ~compare:compare_field) fa fb + | (VariantConstructor (va, ca, xa), VariantConstructor (vb, cb, xb)) -> + cmp3 + String.compare va vb + String.compare ca cb + compare_lz_t xa xb + | (Bool a, Bool b) -> (Pervasives.compare : bool -> bool -> int) a b + | (Bytes a, Bytes b) -> Bytes.compare a b + | (Constructor' a, Constructor' b) -> String.compare a b + | (Expression_variable a, Expression_variable b) -> Var.compare a b + | (Int a, Int b) -> Int.compare a b + | (Label' a, Label' b) -> String.compare a b + | (Ligo_string a, Ligo_string b) -> Simple_utils.Ligo_string.compare a b + | (Location a, Location b) -> Location.compare a b + | (Operation a, Operation b) -> Pervasives.compare a b (* TODO: is there a proper comparison function defined for packed_internal_operation ? *) + | (Str a, Str b) -> String.compare a b + | (Type_expression a, Type_expression b) -> Pervasives.compare a b (* TODO: is there a proper comparison function defined for ast_core_type_expression ? *) + | (Unit (), Unit ()) -> 0 + | (Var a, Var b) -> Var.compare a b + | (Z a, Z b) -> Z.compare a b + | (List a, List b) -> List.compare ~compare:compare_lz_t a b + | (Location_wrap a, Location_wrap b) -> Location.compare_wrap ~compare:compare_lz_t a b + | (CMap a, CMap b) -> List.compare ~compare:compare_cmap_entry a b + | (LMap a, LMap b) -> List.compare ~compare:compare_lmap_entry a b + | (UnionFind a, UnionFind b) -> List.compare ~compare:(List.compare ~compare:compare_lz_t) a b + | (Set a, Set b) -> List.compare ~compare:compare_lz_t a b + | (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry a b + + | ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a), + ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) -> + Int.compare (tag a) (tag b) + + + let mk_compare : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a -> 'a -> int = fun fold a b -> + compare_t (serialize fold a) (serialize fold b) + + let mk_comparable : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a extra_info__comparable = fun fold -> + { compare = mk_compare fold } +end + +(* Generate a comparison function for each type, named like the type itself. *) +include Folds(struct + type in_state = M.no_state ;; + type out_state = M.t ;; + type 'a t = 'a -> 'a -> int ;; + let f = M.mk_compare ;; +end) + +module Comparable = struct + (* Generate a comparator typeclass-like object for each type, named like the type itself. *) + include Folds(struct + type in_state = M.no_state ;; + type out_state = M.t ;; + type 'a t = 'a extra_info__comparable ;; + let f = M.mk_comparable ;; + end) +end diff --git a/src/stages/4-ast_typed/dune b/src/stages/4-ast_typed/dune index 874a19c0a..b2993c400 100644 --- a/src/stages/4-ast_typed/dune +++ b/src/stages/4-ast_typed/dune @@ -1,7 +1,7 @@ (rule - (target generated_fold.ml) - (deps ../adt_generator/generator.raku types.ml) - (action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml))) + (targets generated_fold.ml generated_map.ml generated_o.ml) + (deps ../adt_generator/generator.raku ast.ml) + (action (run perl6 ../adt_generator/generator.raku ast.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml)) (mode (promote (until-clean) (only *))) ) @@ -19,5 +19,6 @@ (preprocess (pps ppx_let bisect_ppx --conditional) ) +;; (modules_without_implementation generated_fold_x) (flags (:standard -open Simple_utils)) ) diff --git a/src/stages/4-ast_typed/fold.ml b/src/stages/4-ast_typed/fold.ml index 271974820..cc02b5fba 100644 --- a/src/stages/4-ast_typed/fold.ml +++ b/src/stages/4-ast_typed/fold.ml @@ -1 +1,3 @@ include Generated_fold +include Generated_map +include Generated_o diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index be7a7a287..6f4ee13b2 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -1,615 +1,5 @@ -[@@@warning "-30"] - +(* The content of types.ml has been split into Ast which contains only + type declarations, and Types_utils which contains some alias + declarations and other definitions used by the fold generator. *) include Types_utils - -type type_constant = - | TC_unit - | TC_string - | TC_bytes - | TC_nat - | TC_int - | TC_mutez - | TC_operation - | TC_address - | TC_key - | TC_key_hash - | TC_chain_id - | TC_signature - | TC_timestamp - | TC_void - -type te_cmap = ctor_content constructor_map -and te_lmap = field_content label_map -and type_meta = ast_core_type_expression option - -and type_content = - | T_sum of te_cmap - | T_record of te_lmap - | T_arrow of arrow - | T_variable of type_variable - | T_constant of type_constant - | T_operator of type_operator - -and arrow = { - type1: type_expression; - type2: type_expression; - } - -and annot_option = string option - -and ctor_content = { - ctor_type : type_expression; - michelson_annotation : annot_option; - ctor_decl_pos : int; -} - -and field_content = { - field_type : type_expression; - michelson_annotation : annot_option; - field_decl_pos : int; -} - -and type_map_args = { - k : type_expression; - v : type_expression; - } - -and michelson_or_args = { - l : type_expression; - r : type_expression; - } - -and type_operator = - | TC_contract of type_expression - | TC_option of type_expression - | TC_list of type_expression - | TC_set of type_expression - | TC_map of type_map_args - | TC_big_map of type_map_args - | TC_map_or_big_map of type_map_args - -and type_expression = { - type_content: type_content; - type_meta: type_meta; - location: location; - } - -type literal = - | Literal_unit - | Literal_int of z - | Literal_nat of z - | Literal_timestamp of z - | Literal_mutez of z - | Literal_string of ligo_string - | Literal_bytes of bytes - | Literal_address of string - | Literal_signature of string - | Literal_key of string - | Literal_key_hash of string - | Literal_chain_id of string - | Literal_void - | Literal_operation of packed_internal_operation - - -and matching_content_cons = { - hd : expression_variable; - tl : expression_variable; - body : expression; - tv : type_expression; - } - -and matching_content_list = { - match_nil : expression ; - match_cons : matching_content_cons; - } - -and matching_content_some = { - opt : expression_variable ; - body : expression ; - tv : type_expression ; - } - -and matching_content_option = { - match_none : expression ; - match_some : matching_content_some ; - } - -and expression_variable_list = expression_variable list -and type_expression_list = type_expression list - -and matching_content_tuple = { - vars : expression_variable_list ; - body : expression ; - tvs : type_expression_list ; - } - -and matching_content_case = { - constructor : constructor' ; - pattern : expression_variable ; - body : expression ; - } - -and matching_content_case_list = matching_content_case list - -and matching_content_variant = { - cases: matching_content_case_list; - tv: type_expression; - } - -and matching_expr = - | Match_list of matching_content_list - | Match_option of matching_content_option - | Match_tuple of matching_content_tuple - | Match_variant of matching_content_variant - -and constant' = - | C_INT - | C_UNIT - | C_NIL - | C_NOW - | C_IS_NAT - | C_SOME - | C_NONE - | C_ASSERTION - | C_ASSERT_INFERRED - | C_FAILWITH - | C_UPDATE - (* Loops *) - | C_ITER - | C_FOLD_WHILE - | C_FOLD_CONTINUE - | C_FOLD_STOP - | C_LOOP_LEFT - | C_LOOP_CONTINUE - | C_LOOP_STOP - | C_FOLD - (* MATH *) - | C_NEG - | C_ABS - | C_ADD - | C_SUB - | C_MUL - | C_EDIV - | C_DIV - | C_MOD - (* LOGIC *) - | C_NOT - | C_AND - | C_OR - | C_XOR - | C_LSL - | C_LSR - (* COMPARATOR *) - | C_EQ - | C_NEQ - | C_LT - | C_GT - | C_LE - | C_GE - (* Bytes/ String *) - | C_SIZE - | C_CONCAT - | C_SLICE - | C_BYTES_PACK - | C_BYTES_UNPACK - | C_CONS - (* Pair *) - | C_PAIR - | C_CAR - | C_CDR - | C_LEFT - | C_RIGHT - (* Set *) - | C_SET_EMPTY - | C_SET_LITERAL - | C_SET_ADD - | C_SET_REMOVE - | C_SET_ITER - | C_SET_FOLD - | C_SET_MEM - (* List *) - | C_LIST_EMPTY - | C_LIST_LITERAL - | C_LIST_ITER - | C_LIST_MAP - | C_LIST_FOLD - (* Maps *) - | C_MAP - | C_MAP_EMPTY - | C_MAP_LITERAL - | C_MAP_GET - | C_MAP_GET_FORCE - | C_MAP_ADD - | C_MAP_REMOVE - | C_MAP_UPDATE - | C_MAP_ITER - | C_MAP_MAP - | C_MAP_FOLD - | C_MAP_MEM - | C_MAP_FIND - | C_MAP_FIND_OPT - (* Big Maps *) - | C_BIG_MAP - | C_BIG_MAP_EMPTY - | C_BIG_MAP_LITERAL - (* Crypto *) - | C_SHA256 - | C_SHA512 - | C_BLAKE2b - | C_HASH - | C_HASH_KEY - | C_CHECK_SIGNATURE - | C_CHAIN_ID - (* Blockchain *) - | C_CALL - | C_CONTRACT - | C_CONTRACT_OPT - | C_CONTRACT_ENTRYPOINT - | C_CONTRACT_ENTRYPOINT_OPT - | C_AMOUNT - | C_BALANCE - | C_SOURCE - | C_SENDER - | C_ADDRESS - | C_SELF - | C_SELF_ADDRESS - | C_IMPLICIT_ACCOUNT - | C_SET_DELEGATE - | C_CREATE_CONTRACT - | C_CONVERT_TO_LEFT_COMB - | C_CONVERT_TO_RIGHT_COMB - | C_CONVERT_FROM_LEFT_COMB - | C_CONVERT_FROM_RIGHT_COMB - -and declaration_loc = declaration location_wrap - -and program = declaration_loc list - -and declaration_constant = { - binder : expression_variable ; - expr : expression ; - inline : bool ; - post_env : environment ; - } - -and declaration = - (* A Declaration_constant is described by - * a name + a type-annotated expression - * a boolean indicating whether it should be inlined - * the environment before the declaration (the original environment) - * the environment after the declaration (i.e. with that new declaration added to the original environment). *) - | Declaration_constant of declaration_constant - (* - | Declaration_type of (type_variable * type_expression) - | Declaration_constant of (named_expression * (environment * environment)) - *) -(* | Macro_declaration of macro_declaration *) - -and expression = { - expression_content: expression_content ; - location: location ; - type_expression: type_expression ; - environment: environment ; - } - -and map_kv = { - k : expression ; - v : expression ; - } - -and look_up = { - ds : expression; - ind : expression; - } - -and expression_label_map = expression label_map -and map_kv_list = map_kv list -and expression_list = expression list - -and expression_content = - (* Base *) - | E_literal of literal - | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *) - | E_variable of expression_variable - | E_application of application - | E_lambda of lambda - | E_recursive of recursive - | E_let_in of let_in - (* Variant *) - | E_constructor of constructor (* For user defined constructors *) - | E_matching of matching - (* Record *) - | E_record of expression_label_map - | E_record_accessor of record_accessor - | E_record_update of record_update - -and constant = { - cons_name: constant' ; - arguments: expression_list ; - } - -and application = { - lamb: expression ; - args: expression ; - } - -and lambda = { - binder: expression_variable ; - (* input_type: type_expression option ; *) - (* output_type: type_expression option ; *) - result: expression ; - } - -and let_in = { - let_binder: expression_variable ; - rhs: expression ; - let_result: expression ; - inline : bool ; - } - -and recursive = { - fun_name : expression_variable; - fun_type : type_expression; - lambda : lambda; -} - -and constructor = { - constructor: constructor'; - element: expression ; - } - -and record_accessor = { - record: expression ; - path: label ; - } - -and record_update = { - record: expression ; - path: label ; - update: expression ; - } - -and matching = { - matchee: expression ; - cases: matching_expr ; - } - -and ascription = { - anno_expr: expression ; - type_annotation: type_expression ; - } - -and environment_element_definition = - | ED_binder - | ED_declaration of environment_element_definition_declaration - -and environment_element_definition_declaration = { - expr: expression ; - free_variables: free_variables ; - } - -and free_variables = expression_variable list - -and environment_element = { - type_value: type_expression ; - source_environment: environment ; - definition: environment_element_definition ; - } - -and expression_environment = environment_binding list - -and environment_binding = { - expr_var: expression_variable ; - env_elt: environment_element ; - } - -and type_environment = type_environment_binding list - -and type_environment_binding = { - type_variable: type_variable ; - type_: type_expression ; -} - -and environment = { - expression_environment: expression_environment ; - type_environment: type_environment ; -} - -and named_type_content = { - type_name : type_variable; - type_value : type_expression; - } - - - - - -(* Solver types *) - -(* typevariable: to_string = (fun s -> Format.asprintf "%a" Var.pp s) *) -type unionfind = type_variable poly_unionfind - -(* core *) - -(* add information on the type or the kind for operator *) -type constant_tag = - | C_arrow (* * -> * -> * isn't this wrong? *) - | C_option (* * -> * *) - | C_record (* ( label , * ) … -> * *) - | C_variant (* ( label , * ) … -> * *) - | C_map (* * -> * -> * *) - | C_big_map (* * -> * -> * *) - | C_list (* * -> * *) - | C_set (* * -> * *) - | C_unit (* * *) - | C_string (* * *) - | C_nat (* * *) - | C_mutez (* * *) - | C_timestamp (* * *) - | C_int (* * *) - | C_address (* * *) - | C_bytes (* * *) - | C_key_hash (* * *) - | C_key (* * *) - | C_signature (* * *) - | C_operation (* * *) - | C_contract (* * -> * *) - | C_chain_id (* * *) - -(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *) -type type_value = - | P_forall of p_forall - | P_variable of type_variable - | P_constant of p_constant - | P_apply of p_apply - -and p_apply = { - tf : type_value ; - targ : type_value ; -} -and p_ctor_args = type_value list -and p_constant = { - p_ctor_tag : constant_tag ; - p_ctor_args : p_ctor_args ; - } -and p_constraints = type_constraint list -and p_forall = { - binder : type_variable ; - constraints : p_constraints ; - body : type_value ; -} - -(* Different type of constraint *) -and ctor_args = type_variable list (* non-empty list *) -and simple_c_constructor = { - ctor_tag : constant_tag ; - ctor_args : ctor_args ; - } -and simple_c_constant = { - constant_tag: constant_tag ; (* for type constructors that do not take arguments *) - } -and c_const = { - c_const_tvar : type_variable ; - c_const_tval : type_value ; - } -and c_equation = { - aval : type_value ; - bval : type_value ; -} -and tc_args = type_value list -and c_typeclass = { - tc_args : tc_args ; - typeclass : typeclass ; -} -and c_access_label = { - c_access_label_tval : type_value ; - accessor : label ; - c_access_label_tvar : type_variable ; - } - -and type_constraint = { - reason : string ; - c : type_constraint_ ; -} -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 *) -(* | … *) - -(* is the first list in case on of the type of the type class as a kind *->*->* ? *) -and tc_allowed = type_value list -and typeclass = tc_allowed list - -(* end core *) - -type c_constructor_simpl_typeVariableMap = c_constructor_simpl typeVariableMap -and constraints_typeVariableMap = constraints typeVariableMap -and type_constraint_simpl_list = type_constraint_simpl list -and 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(α,β)) *) - (* TODO : the rhs of the map should not repeat the variable name. *) - assignments : c_constructor_simpl_typeVariableMap ; - grouped_by_variable : constraints_typeVariableMap ; (* map from (unionfind) variables to constraints containing them *) - cycle_detection_toposort : unit ; (* example of structured db that we'll add later *) -} - -and c_constructor_simpl_list = c_constructor_simpl list -and c_poly_simpl_list = c_poly_simpl list -and c_typeclass_simpl_list = c_typeclass_simpl list -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 *) -} -and type_variable_list = type_variable list -and c_constructor_simpl = { - tv : type_variable; - c_tag : constant_tag; - tv_list : type_variable_list; -} -and c_const_e = { - c_const_e_tv : type_variable ; - c_const_e_te : type_expression ; - } -and c_equation_e = { - aex : type_expression ; - bex : type_expression ; - } -and c_typeclass_simpl = { - tc : typeclass ; - args : type_variable_list ; -} -and c_poly_simpl = { - tv : type_variable ; - forall : p_forall ; -} -and type_constraint_simpl = { - reason_simpl : string ; - c_simpl : type_constraint_simpl_ ; - } -and type_constraint_simpl_ = - | SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) - | SC_Alias of c_alias (* α = β *) - | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *) - | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) - -and c_alias = { - a : type_variable ; - b : type_variable ; - } - - -(* sub-sub component: lazy selector (don't re-try all selectors every time) *) -(* For now: just re-try everytime *) - -(* 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_specialize1 = { - poly : c_poly_simpl ; - a_k_var : c_constructor_simpl ; - } - -type m_break_ctor__already_selected = output_break_ctor poly_set -type m_specialize1__already_selected = output_specialize1 poly_set - -type already_selected = { - break_ctor : m_break_ctor__already_selected ; - specialize1 : m_specialize1__already_selected ; -} - -type typer_state = { - structured_dbs : structured_dbs ; - already_selected : already_selected ; -} +include Ast diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 2c77f5c7d..337e76ba0 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -32,6 +32,10 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe type location = Location.t type inline = bool +type 'a extra_info__comparable = { + compare : 'a -> 'a -> int ; +} + let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result = fun f state m -> let aux k v acc = @@ -93,9 +97,9 @@ type 'v typeVariableMap = (type_variable, 'v) RedBlackTrees.PolyMap.t type 'a poly_set = 'a RedBlackTrees.PolySet.t -let fold_map__poly_unionfind : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result = - fun f state l -> - ignore (f, state, l) ; failwith "TODO +let fold_map__poly_unionfind : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result = + fun extra_info f state l -> + ignore (extra_info, f, state, l) ; failwith "TODO let aux acc element = let%bind state , l = acc in let%bind (state , new_element) = f state element in ok (state , new_element :: l) in @@ -114,12 +118,13 @@ let fold_map__PolyMap : type k v state new_v . (state -> v -> (state * new_v) re let fold_map__typeVariableMap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a typeVariableMap -> (state * new_a typeVariableMap) result = fold_map__PolyMap -let fold_map__poly_set : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result = - fun f state s -> - let new_compare : (new_a -> new_a -> int) = failwith "TODO: thread enough information about the target AST so that we may compare things here." in +let fold_map__poly_set : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result = + fun extra_info f state s -> + let new_compare : (new_a -> new_a -> int) = extra_info.compare in let aux elt ~acc = let%bind (state , s) = acc in let%bind (state , new_elt) = f state elt in ok (state , PolySet.add new_elt s) in let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in ok (state , m) + diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 8b323c157..aa5de686b 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -8,17 +8,27 @@ use worries; # TODO: shorthand for `foo list` etc. in field and constructor types # TODO: error when reserved names are used ("state", … please list them here) -my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_"); +my $inputADTfile = @*ARGS[0]; +my $oModuleName = @*ARGS[1]; +my $combinators_filename = @*ARGS[2]; +my $folder_filename = @*ARGS[3]; +my $mapper_filename = @*ARGS[4]; + +my $moduleName = $inputADTfile.subst(/\.ml$/, '').samecase("A_"); my $variant = "_ _variant"; my $record = "_ _ record"; sub poly { $^type_name } -my $l = @*ARGS[0].IO.lines; +my $l = $inputADTfile.IO.lines; $l = $l.map(*.subst: /(^\s+|\s+$)/, ""); $l = $l.list.cache; my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/; my $statements = $l.grep($statement_re); $l = $l.grep(none $statement_re); +$l = $l.list.cache; +my $typeclass_re = /^\(\*\@ \s* typeclass \s+ (\w+) \s+ (\w+) \s* \*\)/; +my $typeclasses = %($l.grep($typeclass_re).map({ do given $_ { when $typeclass_re { %{ "$/[0]" => "$/[1]" } } } }).flat); +$l = $l.grep(none $typeclass_re); $statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, '')); $l = $l.cache.map(*.subst: /^type\s+/, "\nand "); # TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose. @@ -50,424 +60,452 @@ $l = $l.map: { "kind" => $kind , "ctorsOrFields" => $ctorsOrFields } - # $_[0].subst: , '' } }; -# $l.perl.say; -# exit; - -# ($cf, $isBuiltin, $type) - # { - # name => $cf , - # newName => "$cf'" , - # isBuiltin => $isBuiltin , - # type => $type , - # newType => $isBuiltin ?? $type !! "$type'" - # } - - - -# my @adts_raw = [ -# # typename, kind, fields_or_ctors -# ["root", $variant, [ -# # ctor, builtin?, type -# ["A", False, "rootA"], -# ["B", False, "rootB"], -# ["C", True, "string"], -# ]], -# ["a", $record, [ -# # field, builtin?, type -# ["a1", False, "ta1"], -# ["a2", False, "ta2"], -# ]], -# ["ta1", $variant, [ -# ["X", False, "root"], -# ["Y", False, "ta2"], -# ]], -# ["ta2", $variant, [ -# ["Z", False, "ta2"], -# ["W", True, "unit"], -# ]], -# # polymorphic type -# ["rootA", poly("list"), -# [ -# # Position (0..n-1), builtin?, type argument -# [0, False, "a"], -# ], -# ], -# ["rootB", poly("list"), -# [ -# # Position (0..n-1), builtin?, type argument -# [0, True, "int"], -# ], -# ], -# ]; - -# # say $adts_raw.perl; -# my $adts = (map -> ($name , $kind, @ctorsOrFields) { -# { -# "name" => $name , -# "newName" => "$name'" , -# "kind" => $kind , -# "ctorsOrFields" => @(map -> ($cf, $isBuiltin, $type) { -# { -# name => $cf , -# newName => "$cf'" , -# isBuiltin => $isBuiltin , -# type => $type , -# newType => $isBuiltin ?? $type !! "$type'" -# } -# }, @ctorsOrFields), -# } -# }, @adts_raw).list; my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) { { "name" => $name , - "newName" => "{$name}__'" , + "oNewName" => "O.{$name}", # ($kind ne $record && $kind ne $variant) ?? "$name" !! "O.{$name}", + "newName" => $name , "kind" => $kind , "ctorsOrFields" => @(map -> ($cf, $type) { - my $isBuiltin = (! $type) || (! $l.cache.first({ $_ eq $type })); + my $resolvedType = $type && $l.cache.first({ $_ eq $type }); + my $isBuiltin = (! $type) || (! $resolvedType); + # my $isPoly = $resolvedType && $resolvedType ne $record && $resolvedType ne $variant; { name => $cf , - newName => "{$cf}__'" , + oNewName => "O.{$cf}" , + newName => $cf , isBuiltin => $isBuiltin , type => $type , - newType => $isBuiltin ?? "$type" !! "{$type}__'" + oNewType => $isBuiltin ?? "$type" !! "O.{$type}" , + newType => $type , } }, @ctorsOrFields), } }, @$l.cache).list; -# say $adts.perl; -# say $adts.perl ; - -say "(* This is an auto-generated file. Do not edit. *)"; - -say ""; -for $statements -> $statement { - say "$statement" -} -say "open Adt_generator.Common;;"; -say "open $moduleName;;"; - -say ""; -say "(* must be provided by one of the open or include statements: *)"; -for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly -{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a, _) monad) -> state -> a $poly -> (state * new_a $poly , _) monad = fold_map__$poly;;"; } - -say ""; -for $adts.kv -> $index, $t { - my $typeOrAnd = $index == 0 ?? "type" !! "and"; - say "$typeOrAnd $t ="; - if ($t eq $variant) { - for $t.list -> $c { - given $c { - when '' { say " | $c" } - default { say " | $c of $c" } - } - } - say ""; - } elsif ($t eq $record) { - say ' {'; - for $t.list -> $f - { say " $f : $f ;"; } - say ' }'; - } else { - print " "; - for $t.list -> $a - { print "$a "; } - print "$t"; - say ""; - } -} -say ";;"; - -say ""; -for $adts.list -> $t { - say "type ('state, 'err) _continue_fold_map__$t = \{"; - say " node__$t : 'state -> $t -> ('state * $t , 'err) monad ;"; - for $t.list -> $c - { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'} , 'err) monad ;" } - say ' };;'; -} - -say "type ('state , 'err) _continue_fold_map__$moduleName = \{"; -for $adts.list -> $t { - say " $t : ('state , 'err) _continue_fold_map__$t ;"; -} -say ' };;'; - -say ""; -for $adts.list -> $t -{ say "type ('state, 'err) fold_map_config__$t = \{"; - say " node__$t : 'state -> $t -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t , 'err) monad ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__pre_state : 'state -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__post_state : 'state -> $t -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) - for $t.list -> $c - { say " $t__$c : 'state -> {$c || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*) - } - say '};;' } - -say "type ('state, 'err) fold_map_config__$moduleName ="; -say ' {'; -for $adts.list -> $t -{ say " $t : ('state, 'err) fold_map_config__$t;" } -say ' };;'; - -say "include Adt_generator.Generic.BlahBluh"; -say "type ('state , 'adt_info_node_instance_info) _fold_config ="; -say ' {'; -say " generic : 'state -> 'adt_info_node_instance_info -> 'state;"; -# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') -for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin -{ say " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; } -# look for built-in polymorphic types -for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly -{ say " $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } -say ' };;'; -say "module Arg = struct"; -say " type nonrec ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;"; -say "end;;"; -say "module Adt_info = Adt_generator.Generic.Adt_info (Arg);;"; -say "include Adt_info;;"; -say "type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;"; - -say ""; -say 'type blahblah = {'; -for $adts.list -> $t -{ say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;"; - for $t.list -> $c - { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } -say '};;'; - -# generic programming info about the nodes and fields -say ""; -for $adts.list -> $t -{ for $t.list -> $c - { say "(* info for field or ctor $t.$c *)"; - say "let info__$t__$c : Adt_info.ctor_or_field = \{"; - say " name = \"$c\";"; - say " is_builtin = {$c ?? 'true' !! 'false'};"; - say " type_ = \"$c\";"; - say '}'; - say ""; - say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; - say " cf = info__$t__$c;"; - say " cf_continue = (fun state -> blahblah.fold__$t__$c blahblah visitor state x);"; - say " cf_new_fold = (fun visitor state -> blahblah.fold__$t__$c blahblah visitor state x);"; - say '};;'; - say ""; } - say "(* info for node $t *)"; - say "let info__$t : Adt_info.node = \{"; - my $kind = do given $t { - when $record { "Record" } - when $variant { "Variant" } - default { "Poly \"$_\"" } - }; - say " kind = $kind;"; - say " declaration_name = \"$t\";"; - print " ctors_or_fields = [ "; - for $t.list -> $c { print "info__$t__$c ; "; } - say "];"; - say '};;'; - say ""; - # TODO: factor out some of the common bits here. - say "let continue_info__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate Adt_info.instance = fun blahblah visitor x ->"; - say '{'; - say " instance_declaration_name = \"$t\";"; - do given $t { - when $record { - say ' instance_kind = RecordInstance {'; - print " fields = [ "; - for $t.list -> $c { print "continue_info__$t__$c blahblah visitor x.$c ; "; } - say " ];"; - say '};'; - } - when $variant { - say ' instance_kind = VariantInstance {'; - say " constructor = (match x with"; - for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c blahblah visitor { $c ?? 'v' !! '()' }"; } - say " );"; - print " variant = [ "; - for $t.list -> $c { print "info__$t__$c ; "; } - say "];"; - say '};'; - } - default { - say ' instance_kind = PolyInstance {'; - say " poly = \"$_\";"; - print " arguments = ["; - # TODO: sort by c (currently we only have one-argument - # polymorphic types so it happens to work but should be fixed. - for $t.list -> $c { print "\"$c\""; } - say "];"; - print " poly_continue = (fun state -> visitor.$_ visitor ("; - print $t - .map(-> $c { "(fun state x -> (continue_info__$t__$c blahblah visitor x).cf_continue state)" }) - .join(", "); - say ") state x);"; - say '};'; - } - }; - say '};;'; - say ""; } - -say ""; -say "(* info for adt $moduleName *)"; -print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; -for $adts.list -> $t -{ print "info__$t ; "; } -say "];;"; - -# fold functions -say ""; -for $adts.list -> $t -{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> qstate -> $t -> qstate = fun blahblah visitor state x ->"; - # TODO: add a non-generic continue_fold. - say ' let node_instance_info : qstate Adt_info.node_instance_info = {'; - say " adt = whole_adt_info () ;"; - say " node_instance = continue_info__$t blahblah visitor x"; - say ' } in'; - # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; - say " visitor.generic state node_instance_info;;"; - say ""; - for $t.list -> $c - { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun blahblah { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->"; - # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; - if ($c eq '') { - # nothing to do, this constructor has no arguments. - say " ignore blahblah; state;;"; - } elsif ($c) { - say " ignore blahblah; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) - } else { - say " blahblah.fold__$c blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) - } - # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; - say ""; } -} - -say ""; -say 'let blahblah : blahblah = {'; -for $adts.list -> $t -{ say " fold__$t;"; - for $t.list -> $c - { say " fold__$t__$c;" } } -say '};;'; - -# Tying the knot -say ""; -for $adts.list -> $t -{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x;;"; - for $t.list -> $c - { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x;;" } } - - -say ""; -say "type ('state, 'err) mk_continue_fold_map = \{"; -say " fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName"; -say '};;'; - - -# fold_map functions -say ""; -for $adts.list -> $t -{ say "let _fold_map__$t : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t, err) monad = fun mk_continue_fold_map visitor state x ->"; - say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; - say " visitor.$t.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " return (state, new_x);;"; - say ""; - for $t.list -> $c - { say "let _fold_map__$t__$c : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->"; - say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; - say " visitor.$t.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) - say ""; } } - -# make the "continue" object -say ""; -say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)'; -say "let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{ fn = fun self visitor ->"; -say ' {'; -for $adts.list -> $t -{ say " $t = \{"; - say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;"; - for $t.list -> $c - { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } - say ' };' } -say ' }'; -say '};;'; -say ""; - -# fold_map functions : tying the knot -say ""; -for $adts.list -> $t -{ say "let fold_map__$t : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t,err) monad ="; - say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;"; - for $t.list -> $c - { say "let fold_map__$t__$c : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' },err) monad ="; - say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } } - - -for $adts.list -> $t +# Auto-generated fold functions +$*OUT = open $folder_filename, :w; { - say "let no_op_node__$t : type state . state -> $t -> (state,_) _continue_fold_map__$moduleName -> (state * $t,_) monad ="; - say " fun state v continue ->"; # (*_info*) - say " match v with"; - if ($t eq $variant) { - for $t.list -> $c - { given $c { - when '' { say " | $c -> continue.$t.$t__$c state () >>? fun (state , ()) -> return (state , $c)"; } - default { say " | $c v -> continue.$t.$t__$c state v >>? fun (state , v) -> return (state , $c v)"; } } } - } elsif ($t eq $record) { - print ' { '; - for $t.list -> $f - { print "$f; "; } - say "} ->"; - for $t.list -> $f - { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; } - print ' return (state , ({ '; - for $t.list -> $f - { print "$f; "; } - say "\} : $t))"; - } else { - print " v -> fold_map__$t ( "; - print ( "continue.$t.$t__$_" for $t.list ).join(", "); - say " ) state v;;"; - } + say "(* This is an auto-generated file. Do not edit. *)"; + say ""; + for $statements -> $statement { say "$statement" } + say "open $moduleName;;"; + + say ""; + say " include Adt_generator.Generic.BlahBluh"; + say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{"; + say " generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;"; + say " generic_empty_ctor : 'in_state -> 'out_state;"; + # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') + for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin + { say " $builtin : ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> 'in_state -> $builtin -> 'out_state;"; } + # look for built-in polymorphic types + for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly + { say " $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_state;"; } + say ' };;'; + + say ""; + say " module Adt_info = Adt_generator.Generic.Adt_info (struct"; + say " type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config;;"; + say " end);;"; + say " include Adt_info;;"; + say " type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_state) Adt_info.node_instance_info) _fold_config;;"; + + say ""; + say ' type the_folds = {'; + for $adts.list -> $t + { say " fold__$t : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> $t -> 'out_state;"; + for $t.list -> $c + { say " fold__$t__$c : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> { $c || 'unit' } -> 'out_state;"; } } + say ' };;'; + + # generic programming info about the nodes and fields + say ""; + for $adts.list -> $t + { for $t.list -> $c + { say " (* info for field or ctor $t.$c *)"; + say " let info__$t__$c : Adt_info.ctor_or_field = \{"; + say " name = \"$c\";"; + say " is_builtin = {$c ?? 'true' !! 'false'};"; + say " type_ = \"$c\";"; + say ' };;'; + # say ""; + say " let continue_info__$t__$c : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c || 'unit'} -> (in_qstate, out_qstate) Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{"; + say " cf = info__$t__$c;"; + say " cf_continue = (fun state -> the_folds.fold__$t__$c the_folds visitor state x);"; + say " cf_new_fold = (fun visitor state -> the_folds.fold__$t__$c the_folds visitor state x);"; + say ' };;'; + # say ""; + } + say " (* info for node $t *)"; + say " let info__$t : Adt_info.node = \{"; + my $kind = do given $t { + when $record { "Record" } + when $variant { "Variant" } + default { "Poly \"$_\"" } + }; + say " kind = $kind;"; + say " declaration_name = \"$t\";"; + print " ctors_or_fields = [ "; + for $t.list -> $c { print "info__$t__$c ; "; } + say "];"; + say ' };;'; + # say ""; + # TODO: factor out some of the common bits here. + say " let continue_info__$t : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> $t -> (in_qstate , out_qstate) Adt_info.instance = fun the_folds visitor x ->"; + say ' {'; + say " instance_declaration_name = \"$t\";"; + do given $t { + when $record { + say ' instance_kind = RecordInstance {'; + print " fields = [ "; + for $t.list -> $c { print "continue_info__$t__$c the_folds visitor x.$c ; "; } + say " ];"; + say ' };'; + } + when $variant { + say " instance_kind ="; + say ' VariantInstance {'; + say " constructor ="; + say " (match x with"; + for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c the_folds visitor { $c ?? 'v' !! '()' }"; } + say " );"; + print " variant = [ "; + for $t.list -> $c { print "info__$t__$c ; "; } + say "];"; + say ' };'; + } + default { + say " instance_kind ="; + say ' PolyInstance {'; + say " poly = \"$_\";"; + print " arguments = ["; + # TODO: sort by c (currently we only have one-argument + # polymorphic types so it happens to work but should be fixed. + for $t.list -> $c { print "\"$c\""; } + say "];"; + print " poly_continue = (fun state -> visitor.$_ visitor ("; + print $t + .map(-> $c { "(fun state x -> (continue_info__$t__$c the_folds visitor x).cf_continue state)" }) + .join(", "); + say ") state x);"; + say ' };'; + } + }; + say ' };;'; + # say ""; + } + + say ""; + say " (* info for adt $moduleName *)"; + print " let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; + for $adts.list -> $t + { print "info__$t ; "; } + say "];;"; + + # fold functions + say ""; + for $adts.list -> $t + { say " let fold__$t : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $t -> out_qstate = fun the_folds visitor state x ->"; + # TODO: add a non-generic continue_fold. + say ' let node_instance_info : (in_qstate , out_qstate) Adt_info.node_instance_info = {'; + say " adt = whole_adt_info () ;"; + say " node_instance = continue_info__$t the_folds visitor x"; + say ' } in'; + # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; + say " visitor.generic state node_instance_info;;"; + # say ""; + for $t.list -> $c + { say " let fold__$t__$c : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> { $c || 'unit' } -> out_qstate = fun the_folds visitor state { $c ?? 'x' !! '()' } ->"; + # say " let ctor_or_field_instance_info : (in_qstate , out_qstate) Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; + if ($c eq '') { + # nothing to do, this constructor has no arguments. + say " ignore the_folds; visitor.generic_empty_ctor state;;"; + } elsif ($c) { + say " ignore the_folds; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + } else { + say " the_folds.fold__$c the_folds visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + } + # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; + # say ""; + } + } + # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') + for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin + { say " let fold__$builtin : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun the_folds visitor state x ->"; + say " ignore the_folds; visitor.$builtin visitor state x;;"; } # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + + say ""; + say ' let the_folds : the_folds = {'; + for $adts.list -> $t + { say " fold__$t;"; + for $t.list -> $c + { say " fold__$t__$c;" } } + say ' };;'; + + # Tying the knot + say ""; + for $adts.list -> $t + { say " let fold__$t : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $t -> out_qstate = fun visitor state x -> fold__$t the_folds visitor state x;;"; + for $t.list -> $c + { say " let fold__$t__$c : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> { $c || 'unit' } -> out_qstate = fun visitor state x -> fold__$t__$c the_folds visitor state x;;" } } + # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') + for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin + { say " let fold__$builtin : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; } + + say ""; + say " module Folds (M : sig type in_state type out_state type 'a t val f : ((in_state , out_state) fold_config -> in_state -> 'a -> out_state) -> 'a t end) = struct"; + for $adts.list -> $t + { say " let $t = M.f fold__$t;;"; } + # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') + for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin + { say " let $builtin = M.f fold__$builtin"; } + say " end"; } -for $adts.list -> $t -{ say "let no_op__$t : type state . (state,_) fold_map_config__$t = \{"; - say " node__$t = no_op_node__$t;"; - say " node__$t__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*) - say " node__$t__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*) - for $t.list -> $c - { print " $t__$c = (fun state v continue -> "; # (*_info*) - if ($c) { - print "ignore continue; return (state , v)"; - } else { - print "continue.$c.node__$c state v"; +# auto-generated fold_map functions +$*OUT = open $mapper_filename, :w; +{ + say "(* This is an auto-generated file. Do not edit. *)"; + say ""; + for $statements -> $statement { say "$statement" } + say "open Adt_generator.Common;;"; + say "open $moduleName;;"; + + say ""; + say "module type OSig = sig"; + for $adts.list -> $t { + say " type $t;;"; } - say ") ;"; } - say ' }' } -say "let no_op : type state . (state,_) fold_map_config__$moduleName = \{"; -for $adts.list -> $t -{ say " $t = no_op__$t;" } -say '};;'; + for $adts.list -> $t { + if ($t eq $variant) { + for $t.list -> $c { + say " val make__$t__$c : {$c ne '' ?? "$c " !! 'unit'} -> $t;;"; + } + } elsif ($t eq $record) { + print " val make__$t"; + say ' :'; + for $t.list -> $f + { say " {$f}:{$f} ->"; } + say " $t;;"; + } else { + print " val make__$t : ("; + print $t.map({$_}).join(" , "); + say ") $t -> $t;;"; + } + } -say ""; -for $adts.list -> $t -{ say "let with__$t : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; - say "let with__$t__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; - say "let with__$t__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; - for $t.list -> $c - { say "let with__$t__$c : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } + say ""; + for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t + { my $ty = $t[0]; + my $typeclass = $typeclasses{$t}; + say " val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; } + say "end"; -say ""; -say "module Folds (M : sig type state type 'a t val f : (state fold_config -> state -> 'a -> state) -> 'a t end) = struct"; -for $adts.list -> $t -{ say "let $t = M.f fold__$t;;"; } -say "end"; + say ""; + say "module Mapper (* O : OSig Functors are too slow and consume a lot of memory when compiling large files with OCaml. We're hardcoding the O module below for now. *) = struct"; + say " module O : OSig = $oModuleName"; + say ""; + say " (* must be provided by one of the open or include statements: *)"; + say " module CheckInputSignature = struct"; + for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly + { say " let fold_map__$poly : type a new_a state err .{ $typeclasses{$poly} ?? " new_a extra_info__{$typeclasses{$poly}} ->" !! "" } (state -> a -> (state * new_a, err) monad) -> state -> a $poly -> (state * new_a $poly , err) monad = fold_map__$poly;;"; } + say " end"; + + say ""; + for $adts.list -> $t { + say " type ('state, 'err) _continue_fold_map__$t = \{"; + say " node__$t : 'state -> $t -> ('state * $t , 'err) monad ;"; + for $t.list -> $c + { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'} , 'err) monad ;" } + say ' };;'; + } + + say " type ('state , 'err) _continue_fold_map__$moduleName = \{"; + for $adts.list -> $t { + say " $t : ('state , 'err) _continue_fold_map__$t ;"; + } + say ' };;'; + + say ""; + for $adts.list -> $t + { say " type ('state, 'err) fold_map_config__$t = \{"; + say " node__$t : 'state -> $t -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t , 'err) monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__pre_state : 'state -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__post_state : 'state -> $t -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) + for $t.list -> $c + { say " $t__$c : 'state -> {$c || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*) + } + say ' };;' } + + say " type ('state, 'err) fold_map_config__$moduleName = \{"; + for $adts.list -> $t + { say " $t : ('state, 'err) fold_map_config__$t;" } + say ' };;'; + + say ""; + say " type ('state, 'err) mk_continue_fold_map = \{"; + say " fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName"; + say ' };;'; + + + # fold_map functions + say ""; + for $adts.list -> $t + { say " let _fold_map__$t : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t, err) monad = fun mk_continue_fold_map visitor state x ->"; + say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; + say " visitor.$t.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " return (state, new_x);;"; + # say ""; + for $t.list -> $c + { say " let _fold_map__$t__$c : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->"; + say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; + say " visitor.$t.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + # say ""; + } + } + + # make the "continue" object + say ""; + say ' (* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)'; + say " let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{"; + say " fn ="; + say " fun self visitor ->"; + say ' {'; + for $adts.list -> $t + { say " $t = \{"; + say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;"; + for $t.list -> $c + { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } + say ' };' } + say ' }'; + say ' };;'; + say ""; + + # fold_map functions : tying the knot + say ""; + for $adts.list -> $t + { say " let fold_map__$t : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t,err) monad ="; + say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;"; + for $t.list -> $c + { say " let fold_map__$t__$c : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' },err) monad ="; + say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } } + + say ""; + for $adts.list -> $t + { + say " let no_op_node__$t : type state . state -> $t -> (state,_) _continue_fold_map__$moduleName -> (state * $t,_) monad ="; + say " fun state v continue ->"; # (*_info*) + say " match v with"; + if ($t eq $variant) { + for $t.list -> $c + { given $c { + when '' { say " | $c -> continue.$t.$t__$c state () >>? fun (state , ()) -> return (state , O.make__$t__$c ())"; } + default { say " | $c v -> continue.$t.$t__$c state v >>? fun (state , v) -> return (state , O.make__$t__$c v)"; } } } + } elsif ($t eq $record) { + print ' { '; + for $t.list -> $f + { print "$f; "; } + say "} ->"; + for $t.list -> $f + { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; } + print " return (state , (O.make__$t"; + for $t.list -> $f + { print " ~$f"; } + say " : $t))"; + } else { + print " v -> (fold_map__$t"; + if ($t ne $record && $t ne $variant && $typeclasses{$t}) { + for $t.list -> $a + { print " O.extra_info__$a__{$typeclasses{$t}}"; } + } + print " ( "; + print ( "continue.$t.$t__$_" for $t.list ).join(", "); + say " ) state v)"; + say " >>? fun (state, x) -> return (state, O.make__$t x);;"; + } + } + + for $adts.list -> $t + { say " let no_op__$t : type state . (state,_) fold_map_config__$t = \{"; + say " node__$t = no_op_node__$t;"; + say " node__$t__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*) + say " node__$t__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*) + for $t.list -> $c + { print " $t__$c = (fun state v continue -> "; # (*_info*) + if ($c) { + print "ignore continue; return (state , v)"; + } else { + print "continue.$c.node__$c state v"; + } + say ") ;"; } + say ' }' } + + say " let no_op : type state . (state,_) fold_map_config__$moduleName = \{"; + for $adts.list -> $t + { say " $t = no_op__$t;" } + say ' };;'; + + say ""; + for $adts.list -> $t + { say " let with__$t : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; + say " let with__$t__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; + say " let with__$t__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; + for $t.list -> $c + { say " let with__$t__$c : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } + say "end"; +} + +$*OUT = open $combinators_filename, :w; +{ + say "(* This is an auto-generated file. Do not edit. *)"; + say ""; + for $statements -> $statement { say "$statement" } + say "open $moduleName;;"; + say ""; + for $adts.list -> $t { + say "type nonrec $t = $t;;"; + } + + for $adts.list -> $t { + if ($t eq $variant) { + for $t.list -> $c { + say "let make__$t__$c : {$c ne '' ?? "$c " !! 'unit'} -> $t = fun {$c ne '' ?? 'v' !! '()'} -> $c {$c ne '' ?? 'v ' !! ''};;"; + } + } elsif ($t eq $record) { + print "let make__$t"; + print ' :'; + for $t.list -> $f + { print " {$f}:{$f} ->"; } + print " $t = fun"; + for $t.list -> $f + { print " ~{$f}"; } + print " -> \{"; + for $t.list -> $f + { print " {$f} ;"; } + say " \};;"; + } else { + print "let make__$t : ("; + print $t.map({$_}).join(" , "); + print ") $t -> $t = "; + print "fun x -> x"; + say ";;"; + } + } + + say ""; + for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t + { my $ty = $t[0]; + my $typeclass = $typeclasses{$t}; + say "let extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass = {tc $typeclass}.$ty;;"; + } + # Check that we won't have a cyclic module dependency when using the Folder to auto-generate the compare: + say "(* Check that we won't have a cyclic module dependency when using the Folder to auto-generate the compare: *)"; + say "module DummyTest_ = Generated_fold;;"; +} diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml index c48ca1ac1..f1ad0fcb8 100644 --- a/src/stages/adt_generator/generic.ml +++ b/src/stages/adt_generator/generic.ml @@ -1,44 +1,44 @@ module BlahBluh = struct -module StringMap = Map.Make(String);; -(* generic folds for nodes *) -type 'state generic_continue_fold_node = { - continue : 'state -> 'state ; - (* generic folds for each field *) - continue_ctors_or_fields : ('state -> 'state) StringMap.t ; -};; -(* map from node names to their generic folds *) -type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;; + module StringMap = Map.Make(String);; + (* generic folds for nodes *) + type 'state generic_continue_fold_node = { + continue : 'state -> 'state ; + (* generic folds for each field *) + continue_ctors_or_fields : ('state -> 'state) StringMap.t ; + };; + (* map from node names to their generic folds *) + type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;; end -module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_config end) = struct +module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct type kind = | Record | Variant | Poly of string - type 'state record_instance = { - fields : 'state ctor_or_field_instance list; + type ('in_state , 'out_state) record_instance = { + fields : ('in_state , 'out_state) ctor_or_field_instance list; } - and 'state constructor_instance = { - constructor : 'state ctor_or_field_instance ; + and ('in_state , 'out_state) constructor_instance = { + constructor : ('in_state , 'out_state) ctor_or_field_instance ; variant : ctor_or_field list } - and 'state poly_instance = { + and ('in_state , 'out_state) poly_instance = { poly : string; arguments : string list; - poly_continue : 'state -> 'state + poly_continue : 'in_state -> 'out_state } - and 'state kind_instance = - | RecordInstance of 'state record_instance - | VariantInstance of 'state constructor_instance - | PolyInstance of 'state poly_instance + and ('in_state , 'out_state) kind_instance = + | RecordInstance of ('in_state , 'out_state) record_instance + | VariantInstance of ('in_state , 'out_state) constructor_instance + | PolyInstance of ('in_state , 'out_state) poly_instance - and 'state instance = { + and ('in_state , 'out_state) instance = { instance_declaration_name : string; - instance_kind : 'state kind_instance; + instance_kind : ('in_state , 'out_state) kind_instance; } and ctor_or_field = @@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi type_ : string; } - and 'state ctor_or_field_instance = + and ('in_state , 'out_state) ctor_or_field_instance = { cf : ctor_or_field; - cf_continue : 'state -> 'state; - cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> 'state; + cf_continue : 'in_state -> 'out_state; + cf_new_fold : 'in_state 'out_state . ('in_state , 'out_state , (('in_state , 'out_state) node_instance_info)) M.fold_config -> 'in_state -> 'out_state; } and node = @@ -64,9 +64,9 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi (* TODO: rename things a bit in this file. *) and adt = node list - and 'state node_instance_info = { + and ('in_state , 'out_state) node_instance_info = { adt : adt ; - node_instance : 'state instance ; + node_instance : ('in_state , 'out_state) instance ; } - and 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance + and ('in_state , 'out_state) ctor_or_field_instance_info = adt * node * ('in_state , 'out_state) ctor_or_field_instance end diff --git a/src/test/adt_generator/.gitignore b/src/test/adt_generator/.gitignore index c1c657206..189a4ee60 100644 --- a/src/test/adt_generator/.gitignore +++ b/src/test/adt_generator/.gitignore @@ -1 +1,3 @@ /generated_fold.ml +/generated_map.ml +/generated_o.ml diff --git a/src/test/adt_generator/amodule.ml b/src/test/adt_generator/amodule.ml index ad8035380..abd5490ae 100644 --- a/src/test/adt_generator/amodule.ml +++ b/src/test/adt_generator/amodule.ml @@ -1,3 +1,4 @@ +[@@@warning "-33"] (* open Amodule_utils *) type root = diff --git a/src/test/adt_generator/dune b/src/test/adt_generator/dune index 1f82e7ad0..16af71a00 100644 --- a/src/test/adt_generator/dune +++ b/src/test/adt_generator/dune @@ -1,7 +1,7 @@ (rule - (target generated_fold.ml) + (targets generated_fold.ml generated_map.ml generated_o.ml) (deps ../../../src/stages/adt_generator/generator.raku amodule.ml) - (action (with-stdout-to generated_fold.ml (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml))) + (action (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml)) (mode (promote (until-clean) (only *))) ) diff --git a/src/test/adt_generator/fold.ml b/src/test/adt_generator/fold.ml index 271974820..fd817b4a3 100644 --- a/src/test/adt_generator/fold.ml +++ b/src/test/adt_generator/fold.ml @@ -1 +1,2 @@ include Generated_fold +include Generated_map.Mapper diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 484940341..e6277f76e 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -2,6 +2,8 @@ open Amodule open Fold open Simple_utils.Trace +module O = Fold.O + let (|>) v f = f v module Errors = struct @@ -22,9 +24,9 @@ let () = let op = no_op |> with__a (fun state the_a (*_info*) continue_fold -> - let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in - let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in - ok (state + 1, { a1__' ; a2__' })) + let%bind state, a1 = continue_fold.ta1.node__ta1 state the_a.a1 in + let%bind state, a2 = continue_fold.ta2.node__ta2 state the_a.a2 in + ok (state + 1, (O.make__a ~a1 ~a2 : O.a))) in let state = 0 in let%bind (state , _) = fold_map__root op state some_root in @@ -61,35 +63,33 @@ let () = let _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) let _nob : (bool, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) +type no_state = NoState let () = let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in - let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in - let nostate = false, "" in - let op = { - generic = (fun state info -> - assert_nostate state; + let op : ('i, 'o) Generated_fold.fold_config = { + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance { fields } -> - false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }" + false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }" | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } -> - (match cf_continue nostate with + (match cf_continue NoState with | true, arg -> true, name ^ " (" ^ arg ^ ")" | false, arg -> true, name ^ " " ^ arg) | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue nostate) + (poly_continue NoState) ) ; - string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ; - unit = (fun _visitor state () -> assert_nostate state; false , "()") ; - int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ; - list = (fun _visitor continue state lst -> - assert_nostate state; - false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ; + generic_empty_ctor = (fun NoState -> false, "") ; + string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ; + unit = (fun _visitor NoState () -> false , "()") ; + int = (fun _visitor NoState i -> false , string_of_int i) ; + list = (fun _visitor continue NoState lst -> + false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ; (* generic_ctor_or_field = (fun _info state -> * match _info () with * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" * ); *) } in - let (_ , state) = fold__root op nostate some_root in + let (_ , state) = Generated_fold.fold__root op NoState some_root in let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in if String.equal state expected; then () diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 7087fe899..32411d072 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -17,6 +17,12 @@ let pp = fun ppf t -> | Virtual s -> Format.fprintf ppf "%s" s | File f -> Format.fprintf ppf "%s" (f#to_string `Point) +let compare a b = match a,b with + | (File a, File b) -> Region.compare a b + | (File _, Virtual _) -> -1 + | (Virtual _, File _) -> 1 + | (Virtual a, Virtual b) -> String.compare a b + let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = (* TODO: give correct unicode offsets (the random number is here so @@ -35,6 +41,11 @@ type 'a wrap = { location : t ; } +let compare_wrap ~compare:compare_content { wrap_content = wca ; location = la } { wrap_content = wcb ; location = lb } = + match compare_content wca wcb with + | 0 -> compare la lb + | c -> c + let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc } let get_location x = x.location let unwrap { wrap_content ; _ } = wrap_content diff --git a/vendors/ligo-utils/simple-utils/region.ml b/vendors/ligo-utils/simple-utils/region.ml index a90c51604..dac76ec93 100644 --- a/vendors/ligo-utils/simple-utils/region.ml +++ b/vendors/ligo-utils/simple-utils/region.ml @@ -136,6 +136,11 @@ let lt r1 r2 = && Pos.lt r1#start r2#start && Pos.lt r1#stop r2#stop +let compare r1 r2 = + if equal r1 r2 then 0 + else if lt r1 r2 then -1 + else 1 + let cover r1 r2 = if r1#is_ghost then r2 diff --git a/vendors/ligo-utils/simple-utils/region.mli b/vendors/ligo-utils/simple-utils/region.mli index 378830350..415dc770d 100644 --- a/vendors/ligo-utils/simple-utils/region.mli +++ b/vendors/ligo-utils/simple-utils/region.mli @@ -135,6 +135,11 @@ val equal : t -> t -> bool [r2]. (See {! Pos.lt}.) *) val lt : t -> t -> bool +(** The call [compare r1 r2] has the value 0 if [equal r1 r2] returns + [true]. Otherwise it returns -1 if [lt r1 r2] returns [true], and 1 + if [lt r1 r2] returns [false]. *) +val compare : t -> t -> int + (** Given two regions [r1] and [r2], we may want the region [cover r1 r2] that covers [r1] and [r2]. We have the property [equal (cover r1 r2) (cover r2 r1)]. (In a sense, it is the maximum region, but diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 4b74c0261..38e48ff21 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -178,6 +178,17 @@ let rec assoc_opt ?compare:cmp x = [] -> None | (a,b)::l -> if compare a x = 0 then Some b else assoc_opt ~compare x l +let rec compare ?compare:cmp a b = + let cmp = unopt ~default:Pervasives.compare cmp in + match a,b with + [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | ha::ta, hb::tb -> + (match cmp ha hb with + 0 -> compare ta tb + | c -> c) + module Ne = struct diff --git a/vendors/ligo-utils/simple-utils/x_string.ml b/vendors/ligo-utils/simple-utils/x_string.ml index f7155375c..0f316ac26 100644 --- a/vendors/ligo-utils/simple-utils/x_string.ml +++ b/vendors/ligo-utils/simple-utils/x_string.ml @@ -6,6 +6,12 @@ let pp ppf = function Standard s -> Format.fprintf ppf "%S" s | Verbatim v -> Format.fprintf ppf "{|%s|}" v +let compare ?(compare=compare) a b = match a,b with + (Standard a, Standard b) -> compare a b + | (Standard _, Verbatim _) -> -1 + | (Verbatim _, Standard _) -> 1 + | (Verbatim a, Verbatim b) -> compare a b + let extract = function Standard s -> s | Verbatim v -> v diff --git a/vendors/ligo-utils/simple-utils/x_string.mli b/vendors/ligo-utils/simple-utils/x_string.mli index 5ded5f73f..14b8159f8 100644 --- a/vendors/ligo-utils/simple-utils/x_string.mli +++ b/vendors/ligo-utils/simple-utils/x_string.mli @@ -7,5 +7,6 @@ type t = Standard of string | Verbatim of string +val compare : ?compare:(string->string->int) -> t -> t -> int val pp : Format.formatter -> t -> unit val extract : t -> string