diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml index 9ada9130e..1e503ace6 100644 --- a/src/stages/4-ast_typed/PP_generic.ml +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -4,14 +4,16 @@ open Format open PP_helpers module M = struct + type no_state = NoState let needs_parens = { - generic = (fun state info -> + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance _ -> false | VariantInstance _ -> true | PolyInstance { poly =_; arguments=_; poly_continue } -> - (poly_continue state) + (poly_continue NoState) ); + generic_empty_ctor = (fun _ -> false) ; type_variable = (fun _ _ _ -> true) ; bool = (fun _ _ _ -> false) ; int = (fun _ _ _ -> false) ; @@ -37,83 +39,81 @@ module M = struct typeVariableMap = (fun _ _ _ _ -> false) ; } - let op ppf = { - generic = (fun () info -> + 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 : 'x Adt_info.ctor_or_field_instance) = - fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in + 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 false - then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () + 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) () + fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue ()) + (poly_continue NoState) ); - 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 -> + 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 ()) v in + 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 () lmap -> + 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 ()) v in + 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 () lst -> + list = (fun _visitor continue NoState lst -> let aux ppf elt = - fprintf ppf "%a" (fun _ppf -> continue ()) elt in + 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 () lwrap -> + 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 ()) 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 -> + 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 ()) v) ; - poly_unionfind = (fun _visitor continue () p -> + | 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 ()) (UnionFind.Poly2.repr (List.hd l) p) - (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in + (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 () set -> + poly_set = (fun _visitor continue NoState 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 -> + 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 ()) v in + 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 = M.print ;; end) diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml index 9a4cdc413..e630f1e3a 100644 --- a/src/stages/4-ast_typed/compare_generic.ml +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -5,7 +5,7 @@ module M = struct let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *) type 'a lz = unit -> 'a (* Lazy values *) type t = - | NoState + | EmptyCtor | Record of string * (string * t lz) list | VariantConstructor of string * string * t lz | Bool of inline @@ -30,12 +30,14 @@ module M = struct | 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 : t fold_config = { - generic = (fun _state info -> + let op : (no_state, t) fold_config = { + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance { fields } -> - let aux (fld : 'x Adt_info.ctor_or_field_instance) = + 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 ; _ } -> @@ -43,6 +45,7 @@ module M = struct | 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) ; @@ -72,7 +75,7 @@ module M = struct (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 () -> NoState) + | 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 @@ -89,13 +92,17 @@ module M = struct TypeVariableMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); } - let serialize : (t fold_config -> t -> 'a -> t) -> 'a -> t = fun fold v -> + 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 - | NoState -> 0 + | EmptyCtor -> 0 | Record _ -> 1 | VariantConstructor _ -> 2 | Bool _ -> 3 @@ -129,7 +136,7 @@ module M = struct and compare_lz_t a b = compare_t (a ()) (b ()) and compare_t (a : t) (b : t) = match (a, b) with - | (NoState, NoState) -> failwith "Should not happen (unless for ctors with no args?)" + | (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 @@ -158,21 +165,22 @@ module M = struct | (Set a, Set b) -> List.compare ~compare:compare_lz_t a b | (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry a b - | ((NoState | 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), - ((NoState | 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) -> + | ((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 : (t fold_config -> t -> 'a -> t) -> 'a -> 'a -> int = fun fold a 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 : (t fold_config -> t -> 'a -> t) -> 'a extra_info__comparable = fun fold -> + 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 state = M.t ;; + type in_state = M.no_state ;; + type out_state = M.t ;; type 'a t = 'a -> 'a -> int ;; let f = M.mk_compare ;; end) @@ -180,7 +188,8 @@ end) module Comparable = struct (* Generate a comparator typeclass-like object for each type, named like the type itself. *) include Folds(struct - type state = M.t ;; + type in_state = M.no_state ;; + type out_state = M.t ;; type 'a t = 'a extra_info__comparable ;; let f = M.mk_comparable ;; end) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index c30e144c8..aa5de686b 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -96,29 +96,30 @@ $*OUT = open $folder_filename, :w; say ""; say " include Adt_generator.Generic.BlahBluh"; - say " type ('state , 'adt_info_node_instance_info) _fold_config = \{"; - say " generic : 'state -> 'adt_info_node_instance_info -> 'state;"; + 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 : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; } + { 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 . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } + { 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 ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;"; + 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 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;"; + 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 : 'state . the_folds -> 'state fold_config -> 'state -> $t -> 'state;"; + { 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 : 'state . the_folds -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } + { 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 @@ -132,7 +133,7 @@ $*OUT = open $folder_filename, :w; say " type_ = \"$c\";"; say ' };;'; # say ""; - say " let continue_info__$t__$c : type qstate . the_folds -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{"; + 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);"; @@ -154,7 +155,7 @@ $*OUT = open $folder_filename, :w; say ' };;'; # say ""; # TODO: factor out some of the common bits here. - say " let continue_info__$t : type qstate . the_folds -> qstate fold_config -> $t -> qstate Adt_info.instance = fun the_folds visitor x ->"; + 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 { @@ -208,9 +209,9 @@ $*OUT = open $folder_filename, :w; # fold functions say ""; for $adts.list -> $t - { say " let fold__$t : type qstate . the_folds -> qstate fold_config -> qstate -> $t -> qstate = fun the_folds visitor state x ->"; + { 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 : qstate Adt_info.node_instance_info = {'; + 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'; @@ -218,11 +219,11 @@ $*OUT = open $folder_filename, :w; say " visitor.generic state node_instance_info;;"; # say ""; for $t.list -> $c - { say " let fold__$t__$c : type qstate . the_folds -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun the_folds { $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"; + { 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; state;;"; + 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 { @@ -234,7 +235,7 @@ $*OUT = open $folder_filename, :w; } # 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 qstate . the_folds -> qstate fold_config -> qstate -> $builtin -> qstate = fun the_folds visitor state x ->"; + { 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 ""; @@ -248,15 +249,15 @@ $*OUT = open $folder_filename, :w; # 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 the_folds visitor state x;;"; + { 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 qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c the_folds visitor state x;;" } } + { 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 qstate . qstate fold_config -> qstate -> $builtin -> qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; } + { 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 state type 'a t val f : (state fold_config -> state -> 'a -> state) -> 'a t end) = struct"; + 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 '') diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml index 46b014be6..f1ad0fcb8 100644 --- a/src/stages/adt_generator/generic.ml +++ b/src/stages/adt_generator/generic.ml @@ -10,35 +10,35 @@ module BlahBluh = struct 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/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 4ee398516..e6277f76e 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -63,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 ()