Use the auto-generated comparators as the implementations for the typeclass-like requirements for comparison functions

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 *)
 

src/stages/4-ast_typed/comparable.ml

@@ -0,0 +1 @@
+include Compare_generic.Comparable

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

src/stages/4-ast_typed/fold.ml

@@ -1,3 +1,3 @@
 include Generated_fold
-module M1 = struct include Generated_map end
+include Generated_map
-module M2 = struct include Generated_o end
+include Generated_o

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({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).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<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> the_folds visitor state x;;";
       for $t<ctorsOrFields>.list -> $c
       { say "  let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> the_folds visitor state x;;" } }
+    # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+    for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).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<name> = M.f fold__$t<name>;;"; }
+    # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+    for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
+    { say "  let $builtin = M.f fold__$builtin"; }
     say "  end";
 }
 
@@ -291,8 +301,8 @@ $*OUT = open $mapper_filename, :w;
     say "";
     for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
     { my $ty = $t<ctorsOrFields>[0]<type>;
-      my $tc = $typeclasses{$t<kind>};
+      my $typeclass = $typeclasses{$t<kind>};
-      say "  val extra_info__{$ty}__$tc : $ty extra_info__$tc;;"; }
+      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({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
     { my $ty = $t<ctorsOrFields>[0]<type>;
-      my $tc = $typeclasses{$t<kind>};
+      my $typeclass = $typeclasses{$t<kind>};
-      say "let extra_info__{$ty}__$tc : $ty extra_info__$tc = \{ compare = (fun a b -> let () = failwith \"TODO\" in Pervasives.compare a b) \};;"; }
+      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;;";