balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-05-22 18:25:44 +01:00
parent 008f228ed7
commit ee5e484bf4
5 changed files with 36 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/stages/4-ast_typed/ast.ml
View File

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

1
src/stages/4-ast_typed/comparable.ml Normal file
View File

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

18
src/stages/4-ast_typed/compare_generic.ml
View File

@ -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

4
src/stages/4-ast_typed/fold.ml
View File

@ -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

19
src/stages/adt_generator/generator.raku
View File

@ -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>};
say " val extra_info__{$ty}__$tc : $ty extra_info__$tc;;"; }
my $typeclass = $typeclasses{$t<kind>};
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>};
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<kind>};
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;;";