diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml index c9f17ac5f..e85aace9d 100644 --- a/src/stages/4-ast_typed/ast.ml +++ b/src/stages/4-ast_typed/ast.ml @@ -4,7 +4,8 @@ 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. *) + be specified for a given polymorphic type. The implementation is + provided by the Comparable module *) (*@ typeclass poly_unionfind comparable *) (*@ typeclass poly_set comparable *) 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 index d69704a1f..9a4cdc413 100644 --- a/src/stages/4-ast_typed/compare_generic.ml +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -1,7 +1,8 @@ open Types -open Fold +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 = | NoState @@ -164,10 +165,23 @@ module M = struct let mk_compare : (t fold_config -> t -> '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 -> + { compare = mk_compare fold } end -include Fold.Folds(struct +(* Generate a comparison function for each type, named like the type itself. *) +include Folds(struct type 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 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/fold.ml b/src/stages/4-ast_typed/fold.ml index f1a08e4cb..cc02b5fba 100644 --- a/src/stages/4-ast_typed/fold.ml +++ b/src/stages/4-ast_typed/fold.ml @@ -1,3 +1,3 @@ include Generated_fold -module M1 = struct include Generated_map end -module M2 = struct include Generated_o end +include Generated_map +include Generated_o diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 99c5c1a56..c30e144c8 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -232,6 +232,10 @@ $*OUT = open $folder_filename, :w; # 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 qstate . the_folds -> qstate fold_config -> qstate -> $builtin -> 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 = {'; @@ -247,11 +251,17 @@ $*OUT = open $folder_filename, :w; { say " let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> 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;;" } } + # 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 ""; 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;;"; } + # 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"; } @@ -291,8 +301,8 @@ $*OUT = open $mapper_filename, :w; say ""; for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t { my $ty = $t[0]; - my $tc = $typeclasses{$t}; - say " val extra_info__{$ty}__$tc : $ty extra_info__$tc;;"; } + my $typeclass = $typeclasses{$t}; + say " val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; } say "end"; say ""; @@ -491,8 +501,9 @@ $*OUT = open $combinators_filename, :w; say ""; for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t { my $ty = $t[0]; - my $tc = $typeclasses{$t}; - say "let extra_info__{$ty}__$tc : $ty extra_info__$tc = \{ compare = (fun a b -> let () = failwith \"TODO\" in Pervasives.compare a b) \};;"; } + 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;;";