From 92069077dffcd5d7abef15719aaab60086a4620a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 22 May 2020 02:22:35 +0100 Subject: [PATCH] Auto-generated comparator for AST_typed --- src/passes/1-parser/cameligo/Scoping.ml | 2 +- src/passes/1-parser/pascaligo/Scoping.ml | 2 +- src/stages/4-ast_typed/compare_generic.ml | 173 +++++++++++++++++++ vendors/ligo-utils/simple-utils/location.ml | 11 ++ vendors/ligo-utils/simple-utils/region.ml | 5 + vendors/ligo-utils/simple-utils/region.mli | 5 + vendors/ligo-utils/simple-utils/x_list.ml | 11 ++ vendors/ligo-utils/simple-utils/x_string.ml | 6 + vendors/ligo-utils/simple-utils/x_string.mli | 1 + 9 files changed, 214 insertions(+), 2 deletions(-) create mode 100644 src/stages/4-ast_typed/compare_generic.ml diff --git a/src/passes/1-parser/cameligo/Scoping.ml b/src/passes/1-parser/cameligo/Scoping.ml index 651306022..e1332b96d 100644 --- a/src/passes/1-parser/cameligo/Scoping.ml +++ b/src/passes/1-parser/cameligo/Scoping.ml @@ -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) diff --git a/src/passes/1-parser/pascaligo/Scoping.ml b/src/passes/1-parser/pascaligo/Scoping.ml index 64a8eea52..3fc439efb 100644 --- a/src/passes/1-parser/pascaligo/Scoping.ml +++ b/src/passes/1-parser/pascaligo/Scoping.ml @@ -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) diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml new file mode 100644 index 000000000..d69704a1f --- /dev/null +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -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) diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 7087fe899..32411d072 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -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 diff --git a/vendors/ligo-utils/simple-utils/region.ml b/vendors/ligo-utils/simple-utils/region.ml index a90c51604..dac76ec93 100644 --- a/vendors/ligo-utils/simple-utils/region.ml +++ b/vendors/ligo-utils/simple-utils/region.ml @@ -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 diff --git a/vendors/ligo-utils/simple-utils/region.mli b/vendors/ligo-utils/simple-utils/region.mli index 378830350..415dc770d 100644 --- a/vendors/ligo-utils/simple-utils/region.mli +++ b/vendors/ligo-utils/simple-utils/region.mli @@ -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 diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 4b74c0261..38e48ff21 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -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 diff --git a/vendors/ligo-utils/simple-utils/x_string.ml b/vendors/ligo-utils/simple-utils/x_string.ml index f7155375c..0f316ac26 100644 --- a/vendors/ligo-utils/simple-utils/x_string.ml +++ b/vendors/ligo-utils/simple-utils/x_string.ml @@ -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 diff --git a/vendors/ligo-utils/simple-utils/x_string.mli b/vendors/ligo-utils/simple-utils/x_string.mli index 5ded5f73f..14b8159f8 100644 --- a/vendors/ligo-utils/simple-utils/x_string.mli +++ b/vendors/ligo-utils/simple-utils/x_string.mli @@ -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