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

Auto-generated comparator for AST_typed

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-05-22 02:22:35 +01:00
parent 9a017e5f63
commit 92069077df
9 changed files with 214 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/passes/1-parser/cameligo/Scoping.ml
View File

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

2
src/passes/1-parser/pascaligo/Scoping.ml
View File

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

173
src/stages/4-ast_typed/compare_generic.ml Normal file
View File

@ -0,0 +1,173 @@
open Types
open Fold
module M = struct
type 'a lz = unit -> 'a (* Lazy values *)
type t =
| NoState
| 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
(* TODO: make these functions return a lazy stucture *)
let op : t fold_config = {
generic = (fun _state info ->
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
let aux (fld : 'x 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
);
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 () -> NoState)
| 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 : (t fold_config -> t -> 'a -> t) -> 'a -> t = fun fold v ->
fold op NoState v
(* Generate a unique tag for each case handled below. We can then
compare data by their tag and contents. *)
let tag = function
| NoState -> 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
| (NoState, NoState) -> 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
| ((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) ->
Int.compare (tag a) (tag b)
let mk_compare : (t fold_config -> t -> 'a -> t) -> 'a -> 'a -> int = fun fold a b ->
compare_t (serialize fold a) (serialize fold b)
end
include Fold.Folds(struct
type state = M.t ;;
type 'a t = 'a -> 'a -> int ;;
let f = M.mk_compare ;;
end)

11
vendors/ligo-utils/simple-utils/location.ml vendored
View File

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

5
vendors/ligo-utils/simple-utils/region.ml vendored
View File

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

5
vendors/ligo-utils/simple-utils/region.mli vendored
View File

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

11
vendors/ligo-utils/simple-utils/x_list.ml vendored
View File

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

6
vendors/ligo-utils/simple-utils/x_string.ml vendored
View File

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

1
vendors/ligo-utils/simple-utils/x_string.mli vendored
View File

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