Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht@pprint
This commit is contained in:
Christian Rinderknecht
commit
d4801d942a
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
3
src/stages/4-ast_typed/.gitignore
vendored
3
src/stages/4-ast_typed/.gitignore
vendored
@ -1,2 +1,3 @@
|
||||
/generated_fold.ml
|
||||
|
||||
/generated_map.ml
|
||||
/generated_o.ml
|
||||
|
||||
@ -1,116 +1,119 @@
|
||||
open Types
|
||||
open Fold
|
||||
open Format
|
||||
open PP_helpers
|
||||
|
||||
let needs_parens = {
|
||||
generic = (fun state info ->
|
||||
match info.node_instance.instance_kind with
|
||||
| RecordInstance _ -> false
|
||||
| VariantInstance _ -> true
|
||||
| PolyInstance { poly =_; arguments=_; poly_continue } ->
|
||||
(poly_continue state)
|
||||
);
|
||||
type_variable = (fun _ _ _ -> true) ;
|
||||
bool = (fun _ _ _ -> false) ;
|
||||
int = (fun _ _ _ -> false) ;
|
||||
z = (fun _ _ _ -> false) ;
|
||||
string = (fun _ _ _ -> false) ;
|
||||
ligo_string = (fun _ _ _ -> false) ;
|
||||
bytes = (fun _ _ _ -> false) ;
|
||||
unit = (fun _ _ _ -> false) ;
|
||||
packed_internal_operation = (fun _ _ _ -> false) ;
|
||||
expression_variable = (fun _ _ _ -> false) ;
|
||||
constructor' = (fun _ _ _ -> false) ;
|
||||
location = (fun _ _ _ -> false) ;
|
||||
label = (fun _ _ _ -> false) ;
|
||||
ast_core_type_expression = (fun _ _ _ -> true) ;
|
||||
constructor_map = (fun _ _ _ _ -> false) ;
|
||||
label_map = (fun _ _ _ _ -> false) ;
|
||||
list = (fun _ _ _ _ -> false) ;
|
||||
location_wrap = (fun _ _ _ _ -> false) ;
|
||||
option = (fun _visitor _continue _state o ->
|
||||
match o with None -> false | Some _ -> true) ;
|
||||
poly_unionfind = (fun _ _ _ _ -> false) ;
|
||||
poly_set = (fun _ _ _ _ -> false) ;
|
||||
typeVariableMap = (fun _ _ _ _ -> false) ;
|
||||
}
|
||||
module M = struct
|
||||
type no_state = NoState
|
||||
let needs_parens = {
|
||||
generic = (fun NoState info ->
|
||||
match info.node_instance.instance_kind with
|
||||
| RecordInstance _ -> false
|
||||
| VariantInstance _ -> true
|
||||
| PolyInstance { poly =_; arguments=_; poly_continue } ->
|
||||
(poly_continue NoState)
|
||||
);
|
||||
generic_empty_ctor = (fun _ -> false) ;
|
||||
type_variable = (fun _ _ _ -> true) ;
|
||||
bool = (fun _ _ _ -> false) ;
|
||||
int = (fun _ _ _ -> false) ;
|
||||
z = (fun _ _ _ -> false) ;
|
||||
string = (fun _ _ _ -> false) ;
|
||||
ligo_string = (fun _ _ _ -> false) ;
|
||||
bytes = (fun _ _ _ -> false) ;
|
||||
unit = (fun _ _ _ -> false) ;
|
||||
packed_internal_operation = (fun _ _ _ -> false) ;
|
||||
expression_variable = (fun _ _ _ -> false) ;
|
||||
constructor' = (fun _ _ _ -> false) ;
|
||||
location = (fun _ _ _ -> false) ;
|
||||
label = (fun _ _ _ -> false) ;
|
||||
ast_core_type_expression = (fun _ _ _ -> true) ;
|
||||
constructor_map = (fun _ _ _ _ -> false) ;
|
||||
label_map = (fun _ _ _ _ -> false) ;
|
||||
list = (fun _ _ _ _ -> false) ;
|
||||
location_wrap = (fun _ _ _ _ -> false) ;
|
||||
option = (fun _visitor _continue _state o ->
|
||||
match o with None -> false | Some _ -> true) ;
|
||||
poly_unionfind = (fun _ _ _ _ -> false) ;
|
||||
poly_set = (fun _ _ _ _ -> false) ;
|
||||
typeVariableMap = (fun _ _ _ _ -> false) ;
|
||||
}
|
||||
|
||||
let op ppf = {
|
||||
generic = (fun () info ->
|
||||
match info.node_instance.instance_kind with
|
||||
| RecordInstance { fields } ->
|
||||
let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) =
|
||||
fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in
|
||||
fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
|
||||
| VariantInstance { constructor ; _ } ->
|
||||
if constructor.cf_new_fold needs_parens false
|
||||
then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) ()
|
||||
else let spc = if String.equal constructor.cf.type_ "" then "" else " " in
|
||||
fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) ()
|
||||
| PolyInstance { poly=_; arguments=_; poly_continue } ->
|
||||
(poly_continue ())
|
||||
);
|
||||
int = (fun _visitor () i -> fprintf ppf "%i" i );
|
||||
type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
|
||||
bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ;
|
||||
z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ;
|
||||
string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ;
|
||||
ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ;
|
||||
bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ;
|
||||
unit = (fun _visitor () () -> fprintf ppf "()") ;
|
||||
packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ;
|
||||
expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ;
|
||||
constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ;
|
||||
location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ;
|
||||
label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ;
|
||||
ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
|
||||
constructor_map = (fun _visitor continue () cmap ->
|
||||
let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
|
||||
let aux ppf (Constructor k, v) =
|
||||
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
|
||||
fprintf ppf "CMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
|
||||
label_map = (fun _visitor continue () lmap ->
|
||||
let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
|
||||
let aux ppf (Label k, v) =
|
||||
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
|
||||
fprintf ppf "LMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
|
||||
list = (fun _visitor continue () lst ->
|
||||
let aux ppf elt =
|
||||
fprintf ppf "%a" (fun _ppf -> continue ()) elt in
|
||||
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
|
||||
location_wrap = (fun _visitor continue () lwrap ->
|
||||
let ({ wrap_content; location } : _ Location.wrap) = lwrap in
|
||||
fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location);
|
||||
(* list_ne = (fun _visitor continue () (first, lst) ->
|
||||
let aux ppf elt =
|
||||
fprintf ppf "%a" (fun _ppf -> continue ()) elt in
|
||||
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *)
|
||||
option = (fun _visitor continue () o ->
|
||||
match o with
|
||||
| None -> fprintf ppf "None"
|
||||
| Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ;
|
||||
poly_unionfind = (fun _visitor continue () p ->
|
||||
let lst = (UnionFind.Poly2.partitions p) in
|
||||
let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]"
|
||||
(fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p)
|
||||
(list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in
|
||||
let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
|
||||
fprintf ppf "UnionFind [@,@[<hv 2> %a @]@,]" aux2 lst);
|
||||
poly_set = (fun _visitor continue () set ->
|
||||
let lst = (RedBlackTrees.PolySet.elements set) in
|
||||
fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst);
|
||||
typeVariableMap = (fun _visitor continue () tvmap ->
|
||||
let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
|
||||
let aux ppf (k, v) =
|
||||
fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in
|
||||
fprintf ppf "typeVariableMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
|
||||
}
|
||||
let op ppf : (no_state, unit) fold_config = {
|
||||
generic = (fun NoState info ->
|
||||
match info.node_instance.instance_kind with
|
||||
| RecordInstance { fields } ->
|
||||
let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
|
||||
fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in
|
||||
fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
|
||||
| VariantInstance { constructor ; _ } ->
|
||||
if constructor.cf_new_fold needs_parens NoState
|
||||
then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState
|
||||
else let spc = if String.equal constructor.cf.type_ "" then "" else " " in
|
||||
fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState
|
||||
| PolyInstance { poly=_; arguments=_; poly_continue } ->
|
||||
(poly_continue NoState)
|
||||
);
|
||||
generic_empty_ctor = (fun NoState -> ()) ;
|
||||
int = (fun _visitor NoState i -> fprintf ppf "%i" i );
|
||||
type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
|
||||
bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ;
|
||||
z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ;
|
||||
string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ;
|
||||
ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ;
|
||||
bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ;
|
||||
unit = (fun _visitor NoState () -> fprintf ppf "()") ;
|
||||
packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ;
|
||||
expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ;
|
||||
constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
|
||||
location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ;
|
||||
label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ;
|
||||
ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
|
||||
constructor_map = (fun _visitor continue NoState cmap ->
|
||||
let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
|
||||
let aux ppf (Constructor k, v) =
|
||||
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
|
||||
fprintf ppf "CMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
|
||||
label_map = (fun _visitor continue NoState lmap ->
|
||||
let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
|
||||
let aux ppf (Label k, v) =
|
||||
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
|
||||
fprintf ppf "LMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
|
||||
list = (fun _visitor continue NoState lst ->
|
||||
let aux ppf elt =
|
||||
fprintf ppf "%a" (fun _ppf -> continue NoState) elt in
|
||||
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
|
||||
location_wrap = (fun _visitor continue NoState lwrap ->
|
||||
let ({ wrap_content; location } : _ Location.wrap) = lwrap in
|
||||
fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location);
|
||||
option = (fun _visitor continue NoState o ->
|
||||
match o with
|
||||
| None -> fprintf ppf "None"
|
||||
| Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ;
|
||||
poly_unionfind = (fun _visitor continue NoState p ->
|
||||
let lst = (UnionFind.Poly2.partitions p) in
|
||||
let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]"
|
||||
(fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p)
|
||||
(list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in
|
||||
let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
|
||||
fprintf ppf "UnionFind [@,@[<hv 2> %a @]@,]" aux2 lst);
|
||||
poly_set = (fun _visitor continue NoState set ->
|
||||
let lst = (RedBlackTrees.PolySet.elements set) in
|
||||
fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst);
|
||||
typeVariableMap = (fun _visitor continue NoState tvmap ->
|
||||
let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
|
||||
let aux ppf (k, v) =
|
||||
fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in
|
||||
fprintf ppf "typeVariableMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
|
||||
}
|
||||
|
||||
let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
|
||||
fold (op ppf) () v
|
||||
let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
|
||||
fold (op ppf) NoState v
|
||||
end
|
||||
|
||||
include Fold.Folds(struct
|
||||
type state = unit ;;
|
||||
type in_state = M.no_state ;;
|
||||
type out_state = unit ;;
|
||||
type 'a t = formatter -> 'a -> unit ;;
|
||||
let f = print ;;
|
||||
let f = M.print ;;
|
||||
end)
|
||||
|
||||
622
src/stages/4-ast_typed/ast.ml
Normal file
622
src/stages/4-ast_typed/ast.ml
Normal file
@ -0,0 +1,622 @@
|
||||
[@@@warning "-30"]
|
||||
|
||||
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. The implementation is
|
||||
provided by the Comparable module *)
|
||||
(*@ typeclass poly_unionfind comparable *)
|
||||
(*@ typeclass poly_set comparable *)
|
||||
|
||||
type type_constant =
|
||||
| TC_unit
|
||||
| TC_string
|
||||
| TC_bytes
|
||||
| TC_nat
|
||||
| TC_int
|
||||
| TC_mutez
|
||||
| TC_operation
|
||||
| TC_address
|
||||
| TC_key
|
||||
| TC_key_hash
|
||||
| TC_chain_id
|
||||
| TC_signature
|
||||
| TC_timestamp
|
||||
| TC_void
|
||||
|
||||
type te_cmap = ctor_content constructor_map
|
||||
and te_lmap = field_content label_map
|
||||
and type_meta = ast_core_type_expression option
|
||||
|
||||
and type_content =
|
||||
| T_sum of te_cmap
|
||||
| T_record of te_lmap
|
||||
| T_arrow of arrow
|
||||
| T_variable of type_variable
|
||||
| T_constant of type_constant
|
||||
| T_operator of type_operator
|
||||
|
||||
and arrow = {
|
||||
type1: type_expression;
|
||||
type2: type_expression;
|
||||
}
|
||||
|
||||
and annot_option = string option
|
||||
|
||||
and ctor_content = {
|
||||
ctor_type : type_expression;
|
||||
michelson_annotation : annot_option;
|
||||
ctor_decl_pos : int;
|
||||
}
|
||||
|
||||
and field_content = {
|
||||
field_type : type_expression;
|
||||
michelson_annotation : annot_option;
|
||||
field_decl_pos : int;
|
||||
}
|
||||
|
||||
and type_map_args = {
|
||||
k : type_expression;
|
||||
v : type_expression;
|
||||
}
|
||||
|
||||
and michelson_or_args = {
|
||||
l : type_expression;
|
||||
r : type_expression;
|
||||
}
|
||||
|
||||
and type_operator =
|
||||
| TC_contract of type_expression
|
||||
| TC_option of type_expression
|
||||
| TC_list of type_expression
|
||||
| TC_set of type_expression
|
||||
| TC_map of type_map_args
|
||||
| TC_big_map of type_map_args
|
||||
| TC_map_or_big_map of type_map_args
|
||||
|
||||
and type_expression = {
|
||||
type_content: type_content;
|
||||
type_meta: type_meta;
|
||||
location: location;
|
||||
}
|
||||
|
||||
type literal =
|
||||
| Literal_unit
|
||||
| Literal_int of z
|
||||
| Literal_nat of z
|
||||
| Literal_timestamp of z
|
||||
| Literal_mutez of z
|
||||
| Literal_string of ligo_string
|
||||
| Literal_bytes of bytes
|
||||
| Literal_address of string
|
||||
| Literal_signature of string
|
||||
| Literal_key of string
|
||||
| Literal_key_hash of string
|
||||
| Literal_chain_id of string
|
||||
| Literal_void
|
||||
| Literal_operation of packed_internal_operation
|
||||
|
||||
|
||||
and matching_content_cons = {
|
||||
hd : expression_variable;
|
||||
tl : expression_variable;
|
||||
body : expression;
|
||||
tv : type_expression;
|
||||
}
|
||||
|
||||
and matching_content_list = {
|
||||
match_nil : expression ;
|
||||
match_cons : matching_content_cons;
|
||||
}
|
||||
|
||||
and matching_content_some = {
|
||||
opt : expression_variable ;
|
||||
body : expression ;
|
||||
tv : type_expression ;
|
||||
}
|
||||
|
||||
and matching_content_option = {
|
||||
match_none : expression ;
|
||||
match_some : matching_content_some ;
|
||||
}
|
||||
|
||||
and expression_variable_list = expression_variable list
|
||||
and type_expression_list = type_expression list
|
||||
|
||||
and matching_content_tuple = {
|
||||
vars : expression_variable_list ;
|
||||
body : expression ;
|
||||
tvs : type_expression_list ;
|
||||
}
|
||||
|
||||
and matching_content_case = {
|
||||
constructor : constructor' ;
|
||||
pattern : expression_variable ;
|
||||
body : expression ;
|
||||
}
|
||||
|
||||
and matching_content_case_list = matching_content_case list
|
||||
|
||||
and matching_content_variant = {
|
||||
cases: matching_content_case_list;
|
||||
tv: type_expression;
|
||||
}
|
||||
|
||||
and matching_expr =
|
||||
| Match_list of matching_content_list
|
||||
| Match_option of matching_content_option
|
||||
| Match_tuple of matching_content_tuple
|
||||
| Match_variant of matching_content_variant
|
||||
|
||||
and constant' =
|
||||
| C_INT
|
||||
| C_UNIT
|
||||
| C_NIL
|
||||
| C_NOW
|
||||
| C_IS_NAT
|
||||
| C_SOME
|
||||
| C_NONE
|
||||
| C_ASSERTION
|
||||
| C_ASSERT_INFERRED
|
||||
| C_FAILWITH
|
||||
| C_UPDATE
|
||||
(* Loops *)
|
||||
| C_ITER
|
||||
| C_FOLD_WHILE
|
||||
| C_FOLD_CONTINUE
|
||||
| C_FOLD_STOP
|
||||
| C_LOOP_LEFT
|
||||
| C_LOOP_CONTINUE
|
||||
| C_LOOP_STOP
|
||||
| C_FOLD
|
||||
(* MATH *)
|
||||
| C_NEG
|
||||
| C_ABS
|
||||
| C_ADD
|
||||
| C_SUB
|
||||
| C_MUL
|
||||
| C_EDIV
|
||||
| C_DIV
|
||||
| C_MOD
|
||||
(* LOGIC *)
|
||||
| C_NOT
|
||||
| C_AND
|
||||
| C_OR
|
||||
| C_XOR
|
||||
| C_LSL
|
||||
| C_LSR
|
||||
(* COMPARATOR *)
|
||||
| C_EQ
|
||||
| C_NEQ
|
||||
| C_LT
|
||||
| C_GT
|
||||
| C_LE
|
||||
| C_GE
|
||||
(* Bytes/ String *)
|
||||
| C_SIZE
|
||||
| C_CONCAT
|
||||
| C_SLICE
|
||||
| C_BYTES_PACK
|
||||
| C_BYTES_UNPACK
|
||||
| C_CONS
|
||||
(* Pair *)
|
||||
| C_PAIR
|
||||
| C_CAR
|
||||
| C_CDR
|
||||
| C_LEFT
|
||||
| C_RIGHT
|
||||
(* Set *)
|
||||
| C_SET_EMPTY
|
||||
| C_SET_LITERAL
|
||||
| C_SET_ADD
|
||||
| C_SET_REMOVE
|
||||
| C_SET_ITER
|
||||
| C_SET_FOLD
|
||||
| C_SET_MEM
|
||||
(* List *)
|
||||
| C_LIST_EMPTY
|
||||
| C_LIST_LITERAL
|
||||
| C_LIST_ITER
|
||||
| C_LIST_MAP
|
||||
| C_LIST_FOLD
|
||||
(* Maps *)
|
||||
| C_MAP
|
||||
| C_MAP_EMPTY
|
||||
| C_MAP_LITERAL
|
||||
| C_MAP_GET
|
||||
| C_MAP_GET_FORCE
|
||||
| C_MAP_ADD
|
||||
| C_MAP_REMOVE
|
||||
| C_MAP_UPDATE
|
||||
| C_MAP_ITER
|
||||
| C_MAP_MAP
|
||||
| C_MAP_FOLD
|
||||
| C_MAP_MEM
|
||||
| C_MAP_FIND
|
||||
| C_MAP_FIND_OPT
|
||||
(* Big Maps *)
|
||||
| C_BIG_MAP
|
||||
| C_BIG_MAP_EMPTY
|
||||
| C_BIG_MAP_LITERAL
|
||||
(* Crypto *)
|
||||
| C_SHA256
|
||||
| C_SHA512
|
||||
| C_BLAKE2b
|
||||
| C_HASH
|
||||
| C_HASH_KEY
|
||||
| C_CHECK_SIGNATURE
|
||||
| C_CHAIN_ID
|
||||
(* Blockchain *)
|
||||
| C_CALL
|
||||
| C_CONTRACT
|
||||
| C_CONTRACT_OPT
|
||||
| C_CONTRACT_ENTRYPOINT
|
||||
| C_CONTRACT_ENTRYPOINT_OPT
|
||||
| C_AMOUNT
|
||||
| C_BALANCE
|
||||
| C_SOURCE
|
||||
| C_SENDER
|
||||
| C_ADDRESS
|
||||
| C_SELF
|
||||
| C_SELF_ADDRESS
|
||||
| C_IMPLICIT_ACCOUNT
|
||||
| C_SET_DELEGATE
|
||||
| C_CREATE_CONTRACT
|
||||
| C_CONVERT_TO_LEFT_COMB
|
||||
| C_CONVERT_TO_RIGHT_COMB
|
||||
| C_CONVERT_FROM_LEFT_COMB
|
||||
| C_CONVERT_FROM_RIGHT_COMB
|
||||
|
||||
and declaration_loc = declaration location_wrap
|
||||
|
||||
and program = declaration_loc list
|
||||
|
||||
and declaration_constant = {
|
||||
binder : expression_variable ;
|
||||
expr : expression ;
|
||||
inline : bool ;
|
||||
post_env : environment ;
|
||||
}
|
||||
|
||||
and declaration =
|
||||
(* A Declaration_constant is described by
|
||||
* a name + a type-annotated expression
|
||||
* a boolean indicating whether it should be inlined
|
||||
* the environment before the declaration (the original environment)
|
||||
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
|
||||
| Declaration_constant of declaration_constant
|
||||
(*
|
||||
| Declaration_type of (type_variable * type_expression)
|
||||
| Declaration_constant of (named_expression * (environment * environment))
|
||||
*)
|
||||
(* | Macro_declaration of macro_declaration *)
|
||||
|
||||
and expression = {
|
||||
expression_content: expression_content ;
|
||||
location: location ;
|
||||
type_expression: type_expression ;
|
||||
environment: environment ;
|
||||
}
|
||||
|
||||
and map_kv = {
|
||||
k : expression ;
|
||||
v : expression ;
|
||||
}
|
||||
|
||||
and look_up = {
|
||||
ds : expression;
|
||||
ind : expression;
|
||||
}
|
||||
|
||||
and expression_label_map = expression label_map
|
||||
and map_kv_list = map_kv list
|
||||
and expression_list = expression list
|
||||
|
||||
and expression_content =
|
||||
(* Base *)
|
||||
| E_literal of literal
|
||||
| E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
|
||||
| E_variable of expression_variable
|
||||
| E_application of application
|
||||
| E_lambda of lambda
|
||||
| E_recursive of recursive
|
||||
| E_let_in of let_in
|
||||
(* Variant *)
|
||||
| E_constructor of constructor (* For user defined constructors *)
|
||||
| E_matching of matching
|
||||
(* Record *)
|
||||
| E_record of expression_label_map
|
||||
| E_record_accessor of record_accessor
|
||||
| E_record_update of record_update
|
||||
|
||||
and constant = {
|
||||
cons_name: constant' ;
|
||||
arguments: expression_list ;
|
||||
}
|
||||
|
||||
and application = {
|
||||
lamb: expression ;
|
||||
args: expression ;
|
||||
}
|
||||
|
||||
and lambda = {
|
||||
binder: expression_variable ;
|
||||
(* input_type: type_expression option ; *)
|
||||
(* output_type: type_expression option ; *)
|
||||
result: expression ;
|
||||
}
|
||||
|
||||
and let_in = {
|
||||
let_binder: expression_variable ;
|
||||
rhs: expression ;
|
||||
let_result: expression ;
|
||||
inline : bool ;
|
||||
}
|
||||
|
||||
and recursive = {
|
||||
fun_name : expression_variable;
|
||||
fun_type : type_expression;
|
||||
lambda : lambda;
|
||||
}
|
||||
|
||||
and constructor = {
|
||||
constructor: constructor';
|
||||
element: expression ;
|
||||
}
|
||||
|
||||
and record_accessor = {
|
||||
record: expression ;
|
||||
path: label ;
|
||||
}
|
||||
|
||||
and record_update = {
|
||||
record: expression ;
|
||||
path: label ;
|
||||
update: expression ;
|
||||
}
|
||||
|
||||
and matching = {
|
||||
matchee: expression ;
|
||||
cases: matching_expr ;
|
||||
}
|
||||
|
||||
and ascription = {
|
||||
anno_expr: expression ;
|
||||
type_annotation: type_expression ;
|
||||
}
|
||||
|
||||
and environment_element_definition =
|
||||
| ED_binder
|
||||
| ED_declaration of environment_element_definition_declaration
|
||||
|
||||
and environment_element_definition_declaration = {
|
||||
expr: expression ;
|
||||
free_variables: free_variables ;
|
||||
}
|
||||
|
||||
and free_variables = expression_variable list
|
||||
|
||||
and environment_element = {
|
||||
type_value: type_expression ;
|
||||
source_environment: environment ;
|
||||
definition: environment_element_definition ;
|
||||
}
|
||||
|
||||
and expression_environment = environment_binding list
|
||||
|
||||
and environment_binding = {
|
||||
expr_var: expression_variable ;
|
||||
env_elt: environment_element ;
|
||||
}
|
||||
|
||||
and type_environment = type_environment_binding list
|
||||
|
||||
and type_environment_binding = {
|
||||
type_variable: type_variable ;
|
||||
type_: type_expression ;
|
||||
}
|
||||
|
||||
and environment = {
|
||||
expression_environment: expression_environment ;
|
||||
type_environment: type_environment ;
|
||||
}
|
||||
|
||||
and named_type_content = {
|
||||
type_name : type_variable;
|
||||
type_value : type_expression;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(* Solver types *)
|
||||
|
||||
(* typevariable: to_string = (fun s -> Format.asprintf "%a" Var.pp s) *)
|
||||
type unionfind = type_variable poly_unionfind
|
||||
|
||||
(* core *)
|
||||
|
||||
(* add information on the type or the kind for operator *)
|
||||
type constant_tag =
|
||||
| C_arrow (* * -> * -> * isn't this wrong? *)
|
||||
| C_option (* * -> * *)
|
||||
| C_record (* ( label , * ) … -> * *)
|
||||
| C_variant (* ( label , * ) … -> * *)
|
||||
| C_map (* * -> * -> * *)
|
||||
| C_big_map (* * -> * -> * *)
|
||||
| C_list (* * -> * *)
|
||||
| C_set (* * -> * *)
|
||||
| C_unit (* * *)
|
||||
| C_string (* * *)
|
||||
| C_nat (* * *)
|
||||
| C_mutez (* * *)
|
||||
| C_timestamp (* * *)
|
||||
| C_int (* * *)
|
||||
| C_address (* * *)
|
||||
| C_bytes (* * *)
|
||||
| C_key_hash (* * *)
|
||||
| C_key (* * *)
|
||||
| C_signature (* * *)
|
||||
| C_operation (* * *)
|
||||
| C_contract (* * -> * *)
|
||||
| C_chain_id (* * *)
|
||||
|
||||
(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *)
|
||||
type type_value =
|
||||
| P_forall of p_forall
|
||||
| P_variable of type_variable
|
||||
| P_constant of p_constant
|
||||
| P_apply of p_apply
|
||||
|
||||
and p_apply = {
|
||||
tf : type_value ;
|
||||
targ : type_value ;
|
||||
}
|
||||
and p_ctor_args = type_value list
|
||||
and p_constant = {
|
||||
p_ctor_tag : constant_tag ;
|
||||
p_ctor_args : p_ctor_args ;
|
||||
}
|
||||
and p_constraints = type_constraint list
|
||||
and p_forall = {
|
||||
binder : type_variable ;
|
||||
constraints : p_constraints ;
|
||||
body : type_value ;
|
||||
}
|
||||
|
||||
(* Different type of constraint *)
|
||||
and ctor_args = type_variable list (* non-empty list *)
|
||||
and simple_c_constructor = {
|
||||
ctor_tag : constant_tag ;
|
||||
ctor_args : ctor_args ;
|
||||
}
|
||||
and simple_c_constant = {
|
||||
constant_tag: constant_tag ; (* for type constructors that do not take arguments *)
|
||||
}
|
||||
and c_const = {
|
||||
c_const_tvar : type_variable ;
|
||||
c_const_tval : type_value ;
|
||||
}
|
||||
and c_equation = {
|
||||
aval : type_value ;
|
||||
bval : type_value ;
|
||||
}
|
||||
and tc_args = type_value list
|
||||
and c_typeclass = {
|
||||
tc_args : tc_args ;
|
||||
typeclass : typeclass ;
|
||||
}
|
||||
and c_access_label = {
|
||||
c_access_label_tval : type_value ;
|
||||
accessor : label ;
|
||||
c_access_label_tvar : type_variable ;
|
||||
}
|
||||
|
||||
and type_constraint = {
|
||||
reason : string ;
|
||||
c : type_constraint_ ;
|
||||
}
|
||||
and type_constraint_ =
|
||||
(* | C_assignment of (type_variable * type_pattern) *)
|
||||
| C_equation of c_equation (* TVA = TVB *)
|
||||
| C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *)
|
||||
| C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *)
|
||||
(* | … *)
|
||||
|
||||
(* is the first list in case on of the type of the type class as a kind *->*->* ? *)
|
||||
and tc_allowed = type_value list
|
||||
and typeclass = tc_allowed list
|
||||
|
||||
(* end core *)
|
||||
|
||||
type c_constructor_simpl_typeVariableMap = c_constructor_simpl typeVariableMap
|
||||
and constraints_typeVariableMap = constraints typeVariableMap
|
||||
and type_constraint_simpl_list = type_constraint_simpl list
|
||||
and structured_dbs = {
|
||||
all_constraints : type_constraint_simpl_list ;
|
||||
aliases : unionfind ;
|
||||
(* assignments (passive data structure). *)
|
||||
(* Now : just a map from unification vars to types (pb: what about partial types?) *)
|
||||
(* maybe just local assignments (allow only vars as children of pair(α,β)) *)
|
||||
(* TODO : the rhs of the map should not repeat the variable name. *)
|
||||
assignments : c_constructor_simpl_typeVariableMap ;
|
||||
grouped_by_variable : constraints_typeVariableMap ; (* map from (unionfind) variables to constraints containing them *)
|
||||
cycle_detection_toposort : unit ; (* example of structured db that we'll add later *)
|
||||
}
|
||||
|
||||
and c_constructor_simpl_list = c_constructor_simpl list
|
||||
and c_poly_simpl_list = c_poly_simpl list
|
||||
and c_typeclass_simpl_list = c_typeclass_simpl list
|
||||
and constraints = {
|
||||
(* If implemented in a language with decent sets, these should be sets not lists. *)
|
||||
constructor : c_constructor_simpl_list ; (* List of ('a = constructor(args…)) constraints *)
|
||||
poly : c_poly_simpl_list ; (* List of ('a = forall 'b, some_type) constraints *)
|
||||
tc : c_typeclass_simpl_list ; (* List of (typeclass(args…)) constraints *)
|
||||
}
|
||||
and type_variable_list = type_variable list
|
||||
and c_constructor_simpl = {
|
||||
tv : type_variable;
|
||||
c_tag : constant_tag;
|
||||
tv_list : type_variable_list;
|
||||
}
|
||||
and c_const_e = {
|
||||
c_const_e_tv : type_variable ;
|
||||
c_const_e_te : type_expression ;
|
||||
}
|
||||
and c_equation_e = {
|
||||
aex : type_expression ;
|
||||
bex : type_expression ;
|
||||
}
|
||||
and c_typeclass_simpl = {
|
||||
tc : typeclass ;
|
||||
args : type_variable_list ;
|
||||
}
|
||||
and c_poly_simpl = {
|
||||
tv : type_variable ;
|
||||
forall : p_forall ;
|
||||
}
|
||||
and type_constraint_simpl = {
|
||||
reason_simpl : string ;
|
||||
c_simpl : type_constraint_simpl_ ;
|
||||
}
|
||||
and type_constraint_simpl_ =
|
||||
| SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *)
|
||||
| SC_Alias of c_alias (* α = β *)
|
||||
| SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *)
|
||||
| SC_Typeclass of c_typeclass_simpl (* TC(α, …) *)
|
||||
|
||||
and c_alias = {
|
||||
a : type_variable ;
|
||||
b : type_variable ;
|
||||
}
|
||||
|
||||
|
||||
(* sub-sub component: lazy selector (don't re-try all selectors every time) *)
|
||||
(* For now: just re-try everytime *)
|
||||
|
||||
(* selector / propagation rule for breaking down composite types *)
|
||||
(* For now: break pair(a, b) = pair(c, d) into a = c, b = d *)
|
||||
type output_break_ctor = {
|
||||
a_k_var : c_constructor_simpl ;
|
||||
a_k'_var' : c_constructor_simpl ;
|
||||
}
|
||||
|
||||
type output_specialize1 = {
|
||||
poly : c_poly_simpl ;
|
||||
a_k_var : c_constructor_simpl ;
|
||||
}
|
||||
|
||||
type m_break_ctor__already_selected = output_break_ctor poly_set
|
||||
type m_specialize1__already_selected = output_specialize1 poly_set
|
||||
|
||||
type already_selected = {
|
||||
break_ctor : m_break_ctor__already_selected ;
|
||||
specialize1 : m_specialize1__already_selected ;
|
||||
}
|
||||
|
||||
type typer_state = {
|
||||
structured_dbs : structured_dbs ;
|
||||
already_selected : already_selected ;
|
||||
}
|
||||
1
src/stages/4-ast_typed/comparable.ml
Normal file
1
src/stages/4-ast_typed/comparable.ml
Normal file
@ -0,0 +1 @@
|
||||
include Compare_generic.Comparable
|
||||
196
src/stages/4-ast_typed/compare_generic.ml
Normal file
196
src/stages/4-ast_typed/compare_generic.ml
Normal file
@ -0,0 +1,196 @@
|
||||
open Types
|
||||
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 =
|
||||
| EmptyCtor
|
||||
| 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
|
||||
|
||||
type no_state = NoState
|
||||
|
||||
(* TODO: make these functions return a lazy stucture *)
|
||||
let op : (no_state, t) fold_config = {
|
||||
generic = (fun NoState info ->
|
||||
match info.node_instance.instance_kind with
|
||||
| RecordInstance { fields } ->
|
||||
let aux (fld : ('xi, 'xo) 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
|
||||
);
|
||||
generic_empty_ctor = (fun NoState -> EmptyCtor) ;
|
||||
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 () -> EmptyCtor)
|
||||
| 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 : ((no_state, t) fold_config -> no_state -> 'a -> t) -> 'a -> t = fun fold v ->
|
||||
fold op NoState v
|
||||
|
||||
(* What follows should be roughly the same for all ASTs, so it
|
||||
should be easy to share a single copy of that and of the t type
|
||||
definition above. *)
|
||||
|
||||
(* Generate a unique tag for each case handled below. We can then
|
||||
compare data by their tag and contents. *)
|
||||
let tag = function
|
||||
| EmptyCtor -> 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
|
||||
| (EmptyCtor, EmptyCtor) -> 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
|
||||
|
||||
| ((EmptyCtor | 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),
|
||||
((EmptyCtor | 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 : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a -> 'a -> int = fun fold a b ->
|
||||
compare_t (serialize fold a) (serialize fold b)
|
||||
|
||||
let mk_comparable : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a extra_info__comparable = fun fold ->
|
||||
{ compare = mk_compare fold }
|
||||
end
|
||||
|
||||
(* Generate a comparison function for each type, named like the type itself. *)
|
||||
include Folds(struct
|
||||
type in_state = M.no_state ;;
|
||||
type out_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 in_state = M.no_state ;;
|
||||
type out_state = M.t ;;
|
||||
type 'a t = 'a extra_info__comparable ;;
|
||||
let f = M.mk_comparable ;;
|
||||
end)
|
||||
end
|
||||
@ -1,7 +1,7 @@
|
||||
(rule
|
||||
(target generated_fold.ml)
|
||||
(deps ../adt_generator/generator.raku types.ml)
|
||||
(action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml)))
|
||||
(targets generated_fold.ml generated_map.ml generated_o.ml)
|
||||
(deps ../adt_generator/generator.raku ast.ml)
|
||||
(action (run perl6 ../adt_generator/generator.raku ast.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml))
|
||||
(mode (promote (until-clean) (only *)))
|
||||
)
|
||||
|
||||
@ -19,5 +19,6 @@
|
||||
(preprocess
|
||||
(pps ppx_let bisect_ppx --conditional)
|
||||
)
|
||||
;; (modules_without_implementation generated_fold_x)
|
||||
(flags (:standard -open Simple_utils))
|
||||
)
|
||||
|
||||
@ -1 +1,3 @@
|
||||
include Generated_fold
|
||||
include Generated_map
|
||||
include Generated_o
|
||||
|
||||
@ -1,615 +1,5 @@
|
||||
[@@@warning "-30"]
|
||||
|
||||
(* The content of types.ml has been split into Ast which contains only
|
||||
type declarations, and Types_utils which contains some alias
|
||||
declarations and other definitions used by the fold generator. *)
|
||||
include Types_utils
|
||||
|
||||
type type_constant =
|
||||
| TC_unit
|
||||
| TC_string
|
||||
| TC_bytes
|
||||
| TC_nat
|
||||
| TC_int
|
||||
| TC_mutez
|
||||
| TC_operation
|
||||
| TC_address
|
||||
| TC_key
|
||||
| TC_key_hash
|
||||
| TC_chain_id
|
||||
| TC_signature
|
||||
| TC_timestamp
|
||||
| TC_void
|
||||
|
||||
type te_cmap = ctor_content constructor_map
|
||||
and te_lmap = field_content label_map
|
||||
and type_meta = ast_core_type_expression option
|
||||
|
||||
and type_content =
|
||||
| T_sum of te_cmap
|
||||
| T_record of te_lmap
|
||||
| T_arrow of arrow
|
||||
| T_variable of type_variable
|
||||
| T_constant of type_constant
|
||||
| T_operator of type_operator
|
||||
|
||||
and arrow = {
|
||||
type1: type_expression;
|
||||
type2: type_expression;
|
||||
}
|
||||
|
||||
and annot_option = string option
|
||||
|
||||
and ctor_content = {
|
||||
ctor_type : type_expression;
|
||||
michelson_annotation : annot_option;
|
||||
ctor_decl_pos : int;
|
||||
}
|
||||
|
||||
and field_content = {
|
||||
field_type : type_expression;
|
||||
michelson_annotation : annot_option;
|
||||
field_decl_pos : int;
|
||||
}
|
||||
|
||||
and type_map_args = {
|
||||
k : type_expression;
|
||||
v : type_expression;
|
||||
}
|
||||
|
||||
and michelson_or_args = {
|
||||
l : type_expression;
|
||||
r : type_expression;
|
||||
}
|
||||
|
||||
and type_operator =
|
||||
| TC_contract of type_expression
|
||||
| TC_option of type_expression
|
||||
| TC_list of type_expression
|
||||
| TC_set of type_expression
|
||||
| TC_map of type_map_args
|
||||
| TC_big_map of type_map_args
|
||||
| TC_map_or_big_map of type_map_args
|
||||
|
||||
and type_expression = {
|
||||
type_content: type_content;
|
||||
type_meta: type_meta;
|
||||
location: location;
|
||||
}
|
||||
|
||||
type literal =
|
||||
| Literal_unit
|
||||
| Literal_int of z
|
||||
| Literal_nat of z
|
||||
| Literal_timestamp of z
|
||||
| Literal_mutez of z
|
||||
| Literal_string of ligo_string
|
||||
| Literal_bytes of bytes
|
||||
| Literal_address of string
|
||||
| Literal_signature of string
|
||||
| Literal_key of string
|
||||
| Literal_key_hash of string
|
||||
| Literal_chain_id of string
|
||||
| Literal_void
|
||||
| Literal_operation of packed_internal_operation
|
||||
|
||||
|
||||
and matching_content_cons = {
|
||||
hd : expression_variable;
|
||||
tl : expression_variable;
|
||||
body : expression;
|
||||
tv : type_expression;
|
||||
}
|
||||
|
||||
and matching_content_list = {
|
||||
match_nil : expression ;
|
||||
match_cons : matching_content_cons;
|
||||
}
|
||||
|
||||
and matching_content_some = {
|
||||
opt : expression_variable ;
|
||||
body : expression ;
|
||||
tv : type_expression ;
|
||||
}
|
||||
|
||||
and matching_content_option = {
|
||||
match_none : expression ;
|
||||
match_some : matching_content_some ;
|
||||
}
|
||||
|
||||
and expression_variable_list = expression_variable list
|
||||
and type_expression_list = type_expression list
|
||||
|
||||
and matching_content_tuple = {
|
||||
vars : expression_variable_list ;
|
||||
body : expression ;
|
||||
tvs : type_expression_list ;
|
||||
}
|
||||
|
||||
and matching_content_case = {
|
||||
constructor : constructor' ;
|
||||
pattern : expression_variable ;
|
||||
body : expression ;
|
||||
}
|
||||
|
||||
and matching_content_case_list = matching_content_case list
|
||||
|
||||
and matching_content_variant = {
|
||||
cases: matching_content_case_list;
|
||||
tv: type_expression;
|
||||
}
|
||||
|
||||
and matching_expr =
|
||||
| Match_list of matching_content_list
|
||||
| Match_option of matching_content_option
|
||||
| Match_tuple of matching_content_tuple
|
||||
| Match_variant of matching_content_variant
|
||||
|
||||
and constant' =
|
||||
| C_INT
|
||||
| C_UNIT
|
||||
| C_NIL
|
||||
| C_NOW
|
||||
| C_IS_NAT
|
||||
| C_SOME
|
||||
| C_NONE
|
||||
| C_ASSERTION
|
||||
| C_ASSERT_INFERRED
|
||||
| C_FAILWITH
|
||||
| C_UPDATE
|
||||
(* Loops *)
|
||||
| C_ITER
|
||||
| C_FOLD_WHILE
|
||||
| C_FOLD_CONTINUE
|
||||
| C_FOLD_STOP
|
||||
| C_LOOP_LEFT
|
||||
| C_LOOP_CONTINUE
|
||||
| C_LOOP_STOP
|
||||
| C_FOLD
|
||||
(* MATH *)
|
||||
| C_NEG
|
||||
| C_ABS
|
||||
| C_ADD
|
||||
| C_SUB
|
||||
| C_MUL
|
||||
| C_EDIV
|
||||
| C_DIV
|
||||
| C_MOD
|
||||
(* LOGIC *)
|
||||
| C_NOT
|
||||
| C_AND
|
||||
| C_OR
|
||||
| C_XOR
|
||||
| C_LSL
|
||||
| C_LSR
|
||||
(* COMPARATOR *)
|
||||
| C_EQ
|
||||
| C_NEQ
|
||||
| C_LT
|
||||
| C_GT
|
||||
| C_LE
|
||||
| C_GE
|
||||
(* Bytes/ String *)
|
||||
| C_SIZE
|
||||
| C_CONCAT
|
||||
| C_SLICE
|
||||
| C_BYTES_PACK
|
||||
| C_BYTES_UNPACK
|
||||
| C_CONS
|
||||
(* Pair *)
|
||||
| C_PAIR
|
||||
| C_CAR
|
||||
| C_CDR
|
||||
| C_LEFT
|
||||
| C_RIGHT
|
||||
(* Set *)
|
||||
| C_SET_EMPTY
|
||||
| C_SET_LITERAL
|
||||
| C_SET_ADD
|
||||
| C_SET_REMOVE
|
||||
| C_SET_ITER
|
||||
| C_SET_FOLD
|
||||
| C_SET_MEM
|
||||
(* List *)
|
||||
| C_LIST_EMPTY
|
||||
| C_LIST_LITERAL
|
||||
| C_LIST_ITER
|
||||
| C_LIST_MAP
|
||||
| C_LIST_FOLD
|
||||
(* Maps *)
|
||||
| C_MAP
|
||||
| C_MAP_EMPTY
|
||||
| C_MAP_LITERAL
|
||||
| C_MAP_GET
|
||||
| C_MAP_GET_FORCE
|
||||
| C_MAP_ADD
|
||||
| C_MAP_REMOVE
|
||||
| C_MAP_UPDATE
|
||||
| C_MAP_ITER
|
||||
| C_MAP_MAP
|
||||
| C_MAP_FOLD
|
||||
| C_MAP_MEM
|
||||
| C_MAP_FIND
|
||||
| C_MAP_FIND_OPT
|
||||
(* Big Maps *)
|
||||
| C_BIG_MAP
|
||||
| C_BIG_MAP_EMPTY
|
||||
| C_BIG_MAP_LITERAL
|
||||
(* Crypto *)
|
||||
| C_SHA256
|
||||
| C_SHA512
|
||||
| C_BLAKE2b
|
||||
| C_HASH
|
||||
| C_HASH_KEY
|
||||
| C_CHECK_SIGNATURE
|
||||
| C_CHAIN_ID
|
||||
(* Blockchain *)
|
||||
| C_CALL
|
||||
| C_CONTRACT
|
||||
| C_CONTRACT_OPT
|
||||
| C_CONTRACT_ENTRYPOINT
|
||||
| C_CONTRACT_ENTRYPOINT_OPT
|
||||
| C_AMOUNT
|
||||
| C_BALANCE
|
||||
| C_SOURCE
|
||||
| C_SENDER
|
||||
| C_ADDRESS
|
||||
| C_SELF
|
||||
| C_SELF_ADDRESS
|
||||
| C_IMPLICIT_ACCOUNT
|
||||
| C_SET_DELEGATE
|
||||
| C_CREATE_CONTRACT
|
||||
| C_CONVERT_TO_LEFT_COMB
|
||||
| C_CONVERT_TO_RIGHT_COMB
|
||||
| C_CONVERT_FROM_LEFT_COMB
|
||||
| C_CONVERT_FROM_RIGHT_COMB
|
||||
|
||||
and declaration_loc = declaration location_wrap
|
||||
|
||||
and program = declaration_loc list
|
||||
|
||||
and declaration_constant = {
|
||||
binder : expression_variable ;
|
||||
expr : expression ;
|
||||
inline : bool ;
|
||||
post_env : environment ;
|
||||
}
|
||||
|
||||
and declaration =
|
||||
(* A Declaration_constant is described by
|
||||
* a name + a type-annotated expression
|
||||
* a boolean indicating whether it should be inlined
|
||||
* the environment before the declaration (the original environment)
|
||||
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
|
||||
| Declaration_constant of declaration_constant
|
||||
(*
|
||||
| Declaration_type of (type_variable * type_expression)
|
||||
| Declaration_constant of (named_expression * (environment * environment))
|
||||
*)
|
||||
(* | Macro_declaration of macro_declaration *)
|
||||
|
||||
and expression = {
|
||||
expression_content: expression_content ;
|
||||
location: location ;
|
||||
type_expression: type_expression ;
|
||||
environment: environment ;
|
||||
}
|
||||
|
||||
and map_kv = {
|
||||
k : expression ;
|
||||
v : expression ;
|
||||
}
|
||||
|
||||
and look_up = {
|
||||
ds : expression;
|
||||
ind : expression;
|
||||
}
|
||||
|
||||
and expression_label_map = expression label_map
|
||||
and map_kv_list = map_kv list
|
||||
and expression_list = expression list
|
||||
|
||||
and expression_content =
|
||||
(* Base *)
|
||||
| E_literal of literal
|
||||
| E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
|
||||
| E_variable of expression_variable
|
||||
| E_application of application
|
||||
| E_lambda of lambda
|
||||
| E_recursive of recursive
|
||||
| E_let_in of let_in
|
||||
(* Variant *)
|
||||
| E_constructor of constructor (* For user defined constructors *)
|
||||
| E_matching of matching
|
||||
(* Record *)
|
||||
| E_record of expression_label_map
|
||||
| E_record_accessor of record_accessor
|
||||
| E_record_update of record_update
|
||||
|
||||
and constant = {
|
||||
cons_name: constant' ;
|
||||
arguments: expression_list ;
|
||||
}
|
||||
|
||||
and application = {
|
||||
lamb: expression ;
|
||||
args: expression ;
|
||||
}
|
||||
|
||||
and lambda = {
|
||||
binder: expression_variable ;
|
||||
(* input_type: type_expression option ; *)
|
||||
(* output_type: type_expression option ; *)
|
||||
result: expression ;
|
||||
}
|
||||
|
||||
and let_in = {
|
||||
let_binder: expression_variable ;
|
||||
rhs: expression ;
|
||||
let_result: expression ;
|
||||
inline : bool ;
|
||||
}
|
||||
|
||||
and recursive = {
|
||||
fun_name : expression_variable;
|
||||
fun_type : type_expression;
|
||||
lambda : lambda;
|
||||
}
|
||||
|
||||
and constructor = {
|
||||
constructor: constructor';
|
||||
element: expression ;
|
||||
}
|
||||
|
||||
and record_accessor = {
|
||||
record: expression ;
|
||||
path: label ;
|
||||
}
|
||||
|
||||
and record_update = {
|
||||
record: expression ;
|
||||
path: label ;
|
||||
update: expression ;
|
||||
}
|
||||
|
||||
and matching = {
|
||||
matchee: expression ;
|
||||
cases: matching_expr ;
|
||||
}
|
||||
|
||||
and ascription = {
|
||||
anno_expr: expression ;
|
||||
type_annotation: type_expression ;
|
||||
}
|
||||
|
||||
and environment_element_definition =
|
||||
| ED_binder
|
||||
| ED_declaration of environment_element_definition_declaration
|
||||
|
||||
and environment_element_definition_declaration = {
|
||||
expr: expression ;
|
||||
free_variables: free_variables ;
|
||||
}
|
||||
|
||||
and free_variables = expression_variable list
|
||||
|
||||
and environment_element = {
|
||||
type_value: type_expression ;
|
||||
source_environment: environment ;
|
||||
definition: environment_element_definition ;
|
||||
}
|
||||
|
||||
and expression_environment = environment_binding list
|
||||
|
||||
and environment_binding = {
|
||||
expr_var: expression_variable ;
|
||||
env_elt: environment_element ;
|
||||
}
|
||||
|
||||
and type_environment = type_environment_binding list
|
||||
|
||||
and type_environment_binding = {
|
||||
type_variable: type_variable ;
|
||||
type_: type_expression ;
|
||||
}
|
||||
|
||||
and environment = {
|
||||
expression_environment: expression_environment ;
|
||||
type_environment: type_environment ;
|
||||
}
|
||||
|
||||
and named_type_content = {
|
||||
type_name : type_variable;
|
||||
type_value : type_expression;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(* Solver types *)
|
||||
|
||||
(* typevariable: to_string = (fun s -> Format.asprintf "%a" Var.pp s) *)
|
||||
type unionfind = type_variable poly_unionfind
|
||||
|
||||
(* core *)
|
||||
|
||||
(* add information on the type or the kind for operator *)
|
||||
type constant_tag =
|
||||
| C_arrow (* * -> * -> * isn't this wrong? *)
|
||||
| C_option (* * -> * *)
|
||||
| C_record (* ( label , * ) … -> * *)
|
||||
| C_variant (* ( label , * ) … -> * *)
|
||||
| C_map (* * -> * -> * *)
|
||||
| C_big_map (* * -> * -> * *)
|
||||
| C_list (* * -> * *)
|
||||
| C_set (* * -> * *)
|
||||
| C_unit (* * *)
|
||||
| C_string (* * *)
|
||||
| C_nat (* * *)
|
||||
| C_mutez (* * *)
|
||||
| C_timestamp (* * *)
|
||||
| C_int (* * *)
|
||||
| C_address (* * *)
|
||||
| C_bytes (* * *)
|
||||
| C_key_hash (* * *)
|
||||
| C_key (* * *)
|
||||
| C_signature (* * *)
|
||||
| C_operation (* * *)
|
||||
| C_contract (* * -> * *)
|
||||
| C_chain_id (* * *)
|
||||
|
||||
(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *)
|
||||
type type_value =
|
||||
| P_forall of p_forall
|
||||
| P_variable of type_variable
|
||||
| P_constant of p_constant
|
||||
| P_apply of p_apply
|
||||
|
||||
and p_apply = {
|
||||
tf : type_value ;
|
||||
targ : type_value ;
|
||||
}
|
||||
and p_ctor_args = type_value list
|
||||
and p_constant = {
|
||||
p_ctor_tag : constant_tag ;
|
||||
p_ctor_args : p_ctor_args ;
|
||||
}
|
||||
and p_constraints = type_constraint list
|
||||
and p_forall = {
|
||||
binder : type_variable ;
|
||||
constraints : p_constraints ;
|
||||
body : type_value ;
|
||||
}
|
||||
|
||||
(* Different type of constraint *)
|
||||
and ctor_args = type_variable list (* non-empty list *)
|
||||
and simple_c_constructor = {
|
||||
ctor_tag : constant_tag ;
|
||||
ctor_args : ctor_args ;
|
||||
}
|
||||
and simple_c_constant = {
|
||||
constant_tag: constant_tag ; (* for type constructors that do not take arguments *)
|
||||
}
|
||||
and c_const = {
|
||||
c_const_tvar : type_variable ;
|
||||
c_const_tval : type_value ;
|
||||
}
|
||||
and c_equation = {
|
||||
aval : type_value ;
|
||||
bval : type_value ;
|
||||
}
|
||||
and tc_args = type_value list
|
||||
and c_typeclass = {
|
||||
tc_args : tc_args ;
|
||||
typeclass : typeclass ;
|
||||
}
|
||||
and c_access_label = {
|
||||
c_access_label_tval : type_value ;
|
||||
accessor : label ;
|
||||
c_access_label_tvar : type_variable ;
|
||||
}
|
||||
|
||||
and type_constraint = {
|
||||
reason : string ;
|
||||
c : type_constraint_ ;
|
||||
}
|
||||
and type_constraint_ =
|
||||
(* | C_assignment of (type_variable * type_pattern) *)
|
||||
| C_equation of c_equation (* TVA = TVB *)
|
||||
| C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *)
|
||||
| C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *)
|
||||
(* | … *)
|
||||
|
||||
(* is the first list in case on of the type of the type class as a kind *->*->* ? *)
|
||||
and tc_allowed = type_value list
|
||||
and typeclass = tc_allowed list
|
||||
|
||||
(* end core *)
|
||||
|
||||
type c_constructor_simpl_typeVariableMap = c_constructor_simpl typeVariableMap
|
||||
and constraints_typeVariableMap = constraints typeVariableMap
|
||||
and type_constraint_simpl_list = type_constraint_simpl list
|
||||
and structured_dbs = {
|
||||
all_constraints : type_constraint_simpl_list ;
|
||||
aliases : unionfind ;
|
||||
(* assignments (passive data structure). *)
|
||||
(* Now : just a map from unification vars to types (pb: what about partial types?) *)
|
||||
(* maybe just local assignments (allow only vars as children of pair(α,β)) *)
|
||||
(* TODO : the rhs of the map should not repeat the variable name. *)
|
||||
assignments : c_constructor_simpl_typeVariableMap ;
|
||||
grouped_by_variable : constraints_typeVariableMap ; (* map from (unionfind) variables to constraints containing them *)
|
||||
cycle_detection_toposort : unit ; (* example of structured db that we'll add later *)
|
||||
}
|
||||
|
||||
and c_constructor_simpl_list = c_constructor_simpl list
|
||||
and c_poly_simpl_list = c_poly_simpl list
|
||||
and c_typeclass_simpl_list = c_typeclass_simpl list
|
||||
and constraints = {
|
||||
(* If implemented in a language with decent sets, these should be sets not lists. *)
|
||||
constructor : c_constructor_simpl_list ; (* List of ('a = constructor(args…)) constraints *)
|
||||
poly : c_poly_simpl_list ; (* List of ('a = forall 'b, some_type) constraints *)
|
||||
tc : c_typeclass_simpl_list ; (* List of (typeclass(args…)) constraints *)
|
||||
}
|
||||
and type_variable_list = type_variable list
|
||||
and c_constructor_simpl = {
|
||||
tv : type_variable;
|
||||
c_tag : constant_tag;
|
||||
tv_list : type_variable_list;
|
||||
}
|
||||
and c_const_e = {
|
||||
c_const_e_tv : type_variable ;
|
||||
c_const_e_te : type_expression ;
|
||||
}
|
||||
and c_equation_e = {
|
||||
aex : type_expression ;
|
||||
bex : type_expression ;
|
||||
}
|
||||
and c_typeclass_simpl = {
|
||||
tc : typeclass ;
|
||||
args : type_variable_list ;
|
||||
}
|
||||
and c_poly_simpl = {
|
||||
tv : type_variable ;
|
||||
forall : p_forall ;
|
||||
}
|
||||
and type_constraint_simpl = {
|
||||
reason_simpl : string ;
|
||||
c_simpl : type_constraint_simpl_ ;
|
||||
}
|
||||
and type_constraint_simpl_ =
|
||||
| SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *)
|
||||
| SC_Alias of c_alias (* α = β *)
|
||||
| SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *)
|
||||
| SC_Typeclass of c_typeclass_simpl (* TC(α, …) *)
|
||||
|
||||
and c_alias = {
|
||||
a : type_variable ;
|
||||
b : type_variable ;
|
||||
}
|
||||
|
||||
|
||||
(* sub-sub component: lazy selector (don't re-try all selectors every time) *)
|
||||
(* For now: just re-try everytime *)
|
||||
|
||||
(* selector / propagation rule for breaking down composite types *)
|
||||
(* For now: break pair(a, b) = pair(c, d) into a = c, b = d *)
|
||||
type output_break_ctor = {
|
||||
a_k_var : c_constructor_simpl ;
|
||||
a_k'_var' : c_constructor_simpl ;
|
||||
}
|
||||
|
||||
type output_specialize1 = {
|
||||
poly : c_poly_simpl ;
|
||||
a_k_var : c_constructor_simpl ;
|
||||
}
|
||||
|
||||
type m_break_ctor__already_selected = output_break_ctor poly_set
|
||||
type m_specialize1__already_selected = output_specialize1 poly_set
|
||||
|
||||
type already_selected = {
|
||||
break_ctor : m_break_ctor__already_selected ;
|
||||
specialize1 : m_specialize1__already_selected ;
|
||||
}
|
||||
|
||||
type typer_state = {
|
||||
structured_dbs : structured_dbs ;
|
||||
already_selected : already_selected ;
|
||||
}
|
||||
include Ast
|
||||
|
||||
@ -32,6 +32,10 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe
|
||||
type location = Location.t
|
||||
type inline = bool
|
||||
|
||||
type 'a extra_info__comparable = {
|
||||
compare : 'a -> 'a -> int ;
|
||||
}
|
||||
|
||||
let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result =
|
||||
fun f state m ->
|
||||
let aux k v acc =
|
||||
@ -93,9 +97,9 @@ type 'v typeVariableMap = (type_variable, 'v) RedBlackTrees.PolyMap.t
|
||||
|
||||
type 'a poly_set = 'a RedBlackTrees.PolySet.t
|
||||
|
||||
let fold_map__poly_unionfind : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result =
|
||||
fun f state l ->
|
||||
ignore (f, state, l) ; failwith "TODO
|
||||
let fold_map__poly_unionfind : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result =
|
||||
fun extra_info f state l ->
|
||||
ignore (extra_info, f, state, l) ; failwith "TODO
|
||||
let aux acc element =
|
||||
let%bind state , l = acc in
|
||||
let%bind (state , new_element) = f state element in ok (state , new_element :: l) in
|
||||
@ -114,12 +118,13 @@ let fold_map__PolyMap : type k v state new_v . (state -> v -> (state * new_v) re
|
||||
let fold_map__typeVariableMap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a typeVariableMap -> (state * new_a typeVariableMap) result =
|
||||
fold_map__PolyMap
|
||||
|
||||
let fold_map__poly_set : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result =
|
||||
fun f state s ->
|
||||
let new_compare : (new_a -> new_a -> int) = failwith "TODO: thread enough information about the target AST so that we may compare things here." in
|
||||
let fold_map__poly_set : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result =
|
||||
fun extra_info f state s ->
|
||||
let new_compare : (new_a -> new_a -> int) = extra_info.compare in
|
||||
let aux elt ~acc =
|
||||
let%bind (state , s) = acc in
|
||||
let%bind (state , new_elt) = f state elt in
|
||||
ok (state , PolySet.add new_elt s) in
|
||||
let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in
|
||||
ok (state , m)
|
||||
|
||||
|
||||
@ -8,17 +8,27 @@ use worries;
|
||||
# TODO: shorthand for `foo list` etc. in field and constructor types
|
||||
# TODO: error when reserved names are used ("state", … please list them here)
|
||||
|
||||
my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_");
|
||||
my $inputADTfile = @*ARGS[0];
|
||||
my $oModuleName = @*ARGS[1];
|
||||
my $combinators_filename = @*ARGS[2];
|
||||
my $folder_filename = @*ARGS[3];
|
||||
my $mapper_filename = @*ARGS[4];
|
||||
|
||||
my $moduleName = $inputADTfile.subst(/\.ml$/, '').samecase("A_");
|
||||
my $variant = "_ _variant";
|
||||
my $record = "_ _ record";
|
||||
sub poly { $^type_name }
|
||||
|
||||
my $l = @*ARGS[0].IO.lines;
|
||||
my $l = $inputADTfile.IO.lines;
|
||||
$l = $l.map(*.subst: /(^\s+|\s+$)/, "");
|
||||
$l = $l.list.cache;
|
||||
my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/;
|
||||
my $statements = $l.grep($statement_re);
|
||||
$l = $l.grep(none $statement_re);
|
||||
$l = $l.list.cache;
|
||||
my $typeclass_re = /^\(\*\@ \s* typeclass \s+ (\w+) \s+ (\w+) \s* \*\)/;
|
||||
my $typeclasses = %($l.grep($typeclass_re).map({ do given $_ { when $typeclass_re { %{ "$/[0]" => "$/[1]" } } } }).flat);
|
||||
$l = $l.grep(none $typeclass_re);
|
||||
$statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, ''));
|
||||
$l = $l.cache.map(*.subst: /^type\s+/, "\nand ");
|
||||
# TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose.
|
||||
@ -50,424 +60,452 @@ $l = $l.map: {
|
||||
"kind" => $kind ,
|
||||
"ctorsOrFields" => $ctorsOrFields
|
||||
}
|
||||
# $_[0].subst: , '' }
|
||||
};
|
||||
# $l.perl.say;
|
||||
# exit;
|
||||
|
||||
# ($cf, $isBuiltin, $type)
|
||||
# {
|
||||
# name => $cf ,
|
||||
# newName => "$cf'" ,
|
||||
# isBuiltin => $isBuiltin ,
|
||||
# type => $type ,
|
||||
# newType => $isBuiltin ?? $type !! "$type'"
|
||||
# }
|
||||
|
||||
|
||||
|
||||
# my @adts_raw = [
|
||||
# # typename, kind, fields_or_ctors
|
||||
# ["root", $variant, [
|
||||
# # ctor, builtin?, type
|
||||
# ["A", False, "rootA"],
|
||||
# ["B", False, "rootB"],
|
||||
# ["C", True, "string"],
|
||||
# ]],
|
||||
# ["a", $record, [
|
||||
# # field, builtin?, type
|
||||
# ["a1", False, "ta1"],
|
||||
# ["a2", False, "ta2"],
|
||||
# ]],
|
||||
# ["ta1", $variant, [
|
||||
# ["X", False, "root"],
|
||||
# ["Y", False, "ta2"],
|
||||
# ]],
|
||||
# ["ta2", $variant, [
|
||||
# ["Z", False, "ta2"],
|
||||
# ["W", True, "unit"],
|
||||
# ]],
|
||||
# # polymorphic type
|
||||
# ["rootA", poly("list"),
|
||||
# [
|
||||
# # Position (0..n-1), builtin?, type argument
|
||||
# [0, False, "a"],
|
||||
# ],
|
||||
# ],
|
||||
# ["rootB", poly("list"),
|
||||
# [
|
||||
# # Position (0..n-1), builtin?, type argument
|
||||
# [0, True, "int"],
|
||||
# ],
|
||||
# ],
|
||||
# ];
|
||||
|
||||
# # say $adts_raw.perl;
|
||||
# my $adts = (map -> ($name , $kind, @ctorsOrFields) {
|
||||
# {
|
||||
# "name" => $name ,
|
||||
# "newName" => "$name'" ,
|
||||
# "kind" => $kind ,
|
||||
# "ctorsOrFields" => @(map -> ($cf, $isBuiltin, $type) {
|
||||
# {
|
||||
# name => $cf ,
|
||||
# newName => "$cf'" ,
|
||||
# isBuiltin => $isBuiltin ,
|
||||
# type => $type ,
|
||||
# newType => $isBuiltin ?? $type !! "$type'"
|
||||
# }
|
||||
# }, @ctorsOrFields),
|
||||
# }
|
||||
# }, @adts_raw).list;
|
||||
|
||||
my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
|
||||
{
|
||||
"name" => $name ,
|
||||
"newName" => "{$name}__'" ,
|
||||
"oNewName" => "O.{$name}", # ($kind ne $record && $kind ne $variant) ?? "$name" !! "O.{$name}",
|
||||
"newName" => $name ,
|
||||
"kind" => $kind ,
|
||||
"ctorsOrFields" => @(map -> ($cf, $type) {
|
||||
my $isBuiltin = (! $type) || (! $l.cache.first({ $_<name> eq $type }));
|
||||
my $resolvedType = $type && $l.cache.first({ $_<name> eq $type });
|
||||
my $isBuiltin = (! $type) || (! $resolvedType);
|
||||
# my $isPoly = $resolvedType && $resolvedType<kind> ne $record && $resolvedType<kind> ne $variant;
|
||||
{
|
||||
name => $cf ,
|
||||
newName => "{$cf}__'" ,
|
||||
oNewName => "O.{$cf}" ,
|
||||
newName => $cf ,
|
||||
isBuiltin => $isBuiltin ,
|
||||
type => $type ,
|
||||
newType => $isBuiltin ?? "$type" !! "{$type}__'"
|
||||
oNewType => $isBuiltin ?? "$type" !! "O.{$type}" ,
|
||||
newType => $type ,
|
||||
}
|
||||
}, @ctorsOrFields),
|
||||
}
|
||||
}, @$l.cache).list;
|
||||
|
||||
# say $adts.perl;
|
||||
|
||||
# say $adts.perl ;
|
||||
|
||||
say "(* This is an auto-generated file. Do not edit. *)";
|
||||
|
||||
say "";
|
||||
for $statements -> $statement {
|
||||
say "$statement"
|
||||
}
|
||||
say "open Adt_generator.Common;;";
|
||||
say "open $moduleName;;";
|
||||
|
||||
say "";
|
||||
say "(* must be provided by one of the open or include statements: *)";
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
|
||||
{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a, _) monad) -> state -> a $poly -> (state * new_a $poly , _) monad = fold_map__$poly;;"; }
|
||||
|
||||
say "";
|
||||
for $adts.kv -> $index, $t {
|
||||
my $typeOrAnd = $index == 0 ?? "type" !! "and";
|
||||
say "$typeOrAnd $t<newName> =";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c {
|
||||
given $c<type> {
|
||||
when '' { say " | $c<newName>" }
|
||||
default { say " | $c<newName> of $c<newType>" }
|
||||
}
|
||||
}
|
||||
say "";
|
||||
} elsif ($t<kind> eq $record) {
|
||||
say ' {';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " $f<newName> : $f<newType> ;"; }
|
||||
say ' }';
|
||||
} else {
|
||||
print " ";
|
||||
for $t<ctorsOrFields>.list -> $a
|
||||
{ print "$a<newType> "; }
|
||||
print "$t<kind>";
|
||||
say "";
|
||||
}
|
||||
}
|
||||
say ";;";
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t {
|
||||
say "type ('state, 'err) _continue_fold_map__$t<name> = \{";
|
||||
say " node__$t<name> : 'state -> $t<name> -> ('state * $t<newName> , 'err) monad ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'} , 'err) monad ;" }
|
||||
say ' };;';
|
||||
}
|
||||
|
||||
say "type ('state , 'err) _continue_fold_map__$moduleName = \{";
|
||||
for $adts.list -> $t {
|
||||
say " $t<name> : ('state , 'err) _continue_fold_map__$t<name> ;";
|
||||
}
|
||||
say ' };;';
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "type ('state, 'err) fold_map_config__$t<name> = \{";
|
||||
say " node__$t<name> : 'state -> $t<name> -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t<newName> , 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
|
||||
say " node__$t<name>__pre_state : 'state -> $t<name> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
|
||||
say " node__$t<name>__post_state : 'state -> $t<name> -> $t<newName> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c<newType> || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
|
||||
}
|
||||
say '};;' }
|
||||
|
||||
say "type ('state, 'err) fold_map_config__$moduleName =";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> : ('state, 'err) fold_map_config__$t<name>;" }
|
||||
say ' };;';
|
||||
|
||||
say "include Adt_generator.Generic.BlahBluh";
|
||||
say "type ('state , 'adt_info_node_instance_info) _fold_config =";
|
||||
say ' {';
|
||||
say " generic : 'state -> 'adt_info_node_instance_info -> 'state;";
|
||||
# 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 " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; }
|
||||
# look for built-in polymorphic types
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
|
||||
{ say " $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
|
||||
say ' };;';
|
||||
say "module Arg = struct";
|
||||
say " type nonrec ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;";
|
||||
say "end;;";
|
||||
say "module Adt_info = Adt_generator.Generic.Adt_info (Arg);;";
|
||||
say "include Adt_info;;";
|
||||
say "type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;";
|
||||
|
||||
say "";
|
||||
say 'type blahblah = {';
|
||||
for $adts.list -> $t
|
||||
{ say " fold__$t<name> : 'state . blahblah -> 'state fold_config -> 'state -> $t<name> -> 'state;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " fold__$t<name>__$c<name> : 'state . blahblah -> 'state fold_config -> 'state -> { $c<type> || 'unit' } -> 'state;"; } }
|
||||
say '};;';
|
||||
|
||||
# generic programming info about the nodes and fields
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ for $t<ctorsOrFields>.list -> $c
|
||||
{ say "(* info for field or ctor $t<name>.$c<name> *)";
|
||||
say "let info__$t<name>__$c<name> : Adt_info.ctor_or_field = \{";
|
||||
say " name = \"$c<name>\";";
|
||||
say " is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
|
||||
say " type_ = \"$c<type>\";";
|
||||
say '}';
|
||||
say "";
|
||||
say "let continue_info__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
|
||||
say " cf = info__$t<name>__$c<name>;";
|
||||
say " cf_continue = (fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x);";
|
||||
say " cf_new_fold = (fun visitor state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x);";
|
||||
say '};;';
|
||||
say ""; }
|
||||
say "(* info for node $t<name> *)";
|
||||
say "let info__$t<name> : Adt_info.node = \{";
|
||||
my $kind = do given $t<kind> {
|
||||
when $record { "Record" }
|
||||
when $variant { "Variant" }
|
||||
default { "Poly \"$_\"" }
|
||||
};
|
||||
say " kind = $kind;";
|
||||
say " declaration_name = \"$t<name>\";";
|
||||
print " ctors_or_fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
|
||||
say "];";
|
||||
say '};;';
|
||||
say "";
|
||||
# TODO: factor out some of the common bits here.
|
||||
say "let continue_info__$t<name> : type qstate . blahblah -> qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun blahblah visitor x ->";
|
||||
say '{';
|
||||
say " instance_declaration_name = \"$t<name>\";";
|
||||
do given $t<kind> {
|
||||
when $record {
|
||||
say ' instance_kind = RecordInstance {';
|
||||
print " fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> blahblah visitor x.$c<name> ; "; }
|
||||
say " ];";
|
||||
say '};';
|
||||
}
|
||||
when $variant {
|
||||
say ' instance_kind = VariantInstance {';
|
||||
say " constructor = (match x with";
|
||||
for $t<ctorsOrFields>.list -> $c { say " | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> blahblah visitor { $c<type> ?? 'v' !! '()' }"; }
|
||||
say " );";
|
||||
print " variant = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
|
||||
say "];";
|
||||
say '};';
|
||||
}
|
||||
default {
|
||||
say ' instance_kind = PolyInstance {';
|
||||
say " poly = \"$_\";";
|
||||
print " arguments = [";
|
||||
# TODO: sort by c<name> (currently we only have one-argument
|
||||
# polymorphic types so it happens to work but should be fixed.
|
||||
for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
|
||||
say "];";
|
||||
print " poly_continue = (fun state -> visitor.$_ visitor (";
|
||||
print $t<ctorsOrFields>
|
||||
.map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> blahblah visitor x).cf_continue state)" })
|
||||
.join(", ");
|
||||
say ") state x);";
|
||||
say '};';
|
||||
}
|
||||
};
|
||||
say '};;';
|
||||
say ""; }
|
||||
|
||||
say "";
|
||||
say "(* info for adt $moduleName *)";
|
||||
print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
|
||||
for $adts.list -> $t
|
||||
{ print "info__$t<name> ; "; }
|
||||
say "];;";
|
||||
|
||||
# fold functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "let fold__$t<name> : type qstate . blahblah -> qstate fold_config -> qstate -> $t<name> -> qstate = fun blahblah visitor state x ->";
|
||||
# TODO: add a non-generic continue_fold.
|
||||
say ' let node_instance_info : qstate Adt_info.node_instance_info = {';
|
||||
say " adt = whole_adt_info () ;";
|
||||
say " node_instance = continue_info__$t<name> blahblah visitor x";
|
||||
say ' } in';
|
||||
# say " let (state, new_x) = visitor.$t<name>.node__$t<name> x (fun () -> whole_adt_info, info__$t<name>) state continue_fold in";
|
||||
say " visitor.generic state node_instance_info;;";
|
||||
say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "let fold__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun blahblah { $c<type> ?? 'visitor' !! '_visitor' } state { $c<type> ?? 'x' !! '()' } ->";
|
||||
# say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
|
||||
if ($c<type> eq '') {
|
||||
# nothing to do, this constructor has no arguments.
|
||||
say " ignore blahblah; state;;";
|
||||
} elsif ($c<isBuiltin>) {
|
||||
say " ignore blahblah; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
|
||||
} else {
|
||||
say " blahblah.fold__$c<type> blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
|
||||
}
|
||||
# say " visitor.$t<name>.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
|
||||
say ""; }
|
||||
}
|
||||
|
||||
say "";
|
||||
say 'let blahblah : blahblah = {';
|
||||
for $adts.list -> $t
|
||||
{ say " fold__$t<name>;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " fold__$t<name>__$c<name>;" } }
|
||||
say '};;';
|
||||
|
||||
# Tying the knot
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> blahblah 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> blahblah visitor state x;;" } }
|
||||
|
||||
|
||||
say "";
|
||||
say "type ('state, 'err) mk_continue_fold_map = \{";
|
||||
say " fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName";
|
||||
say '};;';
|
||||
|
||||
|
||||
# fold_map functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "let _fold_map__$t<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<newName>, err) monad = fun mk_continue_fold_map visitor state x ->";
|
||||
say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
|
||||
say " visitor.$t<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
|
||||
say " visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
|
||||
say " visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
|
||||
say " return (state, new_x);;";
|
||||
say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "let _fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->";
|
||||
say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
|
||||
say " visitor.$t<name>.$t<name>__$c<name> state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
|
||||
say ""; } }
|
||||
|
||||
# make the "continue" object
|
||||
say "";
|
||||
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
|
||||
say "let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{ fn = fun self visitor ->";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = \{";
|
||||
say " node__$t<name> = (fun state x -> _fold_map__$t<name> self visitor state x) ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> self visitor state x) ;"; }
|
||||
say ' };' }
|
||||
say ' }';
|
||||
say '};;';
|
||||
say "";
|
||||
|
||||
# fold_map functions : tying the knot
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "let fold_map__$t<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<newName>,err) monad =";
|
||||
say " fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x;;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "let fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' },err) monad =";
|
||||
say " fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x;;"; } }
|
||||
|
||||
|
||||
for $adts.list -> $t
|
||||
# Auto-generated fold functions
|
||||
$*OUT = open $folder_filename, :w;
|
||||
{
|
||||
say "let no_op_node__$t<name> : type state . state -> $t<name> -> (state,_) _continue_fold_map__$moduleName -> (state * $t<newName>,_) monad =";
|
||||
say " fun state v continue ->"; # (*_info*)
|
||||
say " match v with";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ given $c<type> {
|
||||
when '' { say " | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , $c<newName>)"; }
|
||||
default { say " | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , $c<newName> v)"; } } }
|
||||
} elsif ($t<kind> eq $record) {
|
||||
print ' { ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<name>; "; }
|
||||
say "} ->";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
|
||||
print ' return (state , ({ ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<newName>; "; }
|
||||
say "\} : $t<newName>))";
|
||||
} else {
|
||||
print " v -> fold_map__$t<kind> ( ";
|
||||
print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", ");
|
||||
say " ) state v;;";
|
||||
}
|
||||
say "(* This is an auto-generated file. Do not edit. *)";
|
||||
say "";
|
||||
for $statements -> $statement { say "$statement" }
|
||||
say "open $moduleName;;";
|
||||
|
||||
say "";
|
||||
say " include Adt_generator.Generic.BlahBluh";
|
||||
say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
|
||||
say " generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;";
|
||||
say " generic_empty_ctor : 'in_state -> 'out_state;";
|
||||
# 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 " $builtin : ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> 'in_state -> $builtin -> 'out_state;"; }
|
||||
# look for built-in polymorphic types
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
|
||||
{ say " $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_state;"; }
|
||||
say ' };;';
|
||||
|
||||
say "";
|
||||
say " module Adt_info = Adt_generator.Generic.Adt_info (struct";
|
||||
say " type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config;;";
|
||||
say " end);;";
|
||||
say " include Adt_info;;";
|
||||
say " type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_state) Adt_info.node_instance_info) _fold_config;;";
|
||||
|
||||
say "";
|
||||
say ' type the_folds = {';
|
||||
for $adts.list -> $t
|
||||
{ say " fold__$t<name> : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> $t<name> -> 'out_state;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " fold__$t<name>__$c<name> : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> { $c<type> || 'unit' } -> 'out_state;"; } }
|
||||
say ' };;';
|
||||
|
||||
# generic programming info about the nodes and fields
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ for $t<ctorsOrFields>.list -> $c
|
||||
{ say " (* info for field or ctor $t<name>.$c<name> *)";
|
||||
say " let info__$t<name>__$c<name> : Adt_info.ctor_or_field = \{";
|
||||
say " name = \"$c<name>\";";
|
||||
say " is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
|
||||
say " type_ = \"$c<type>\";";
|
||||
say ' };;';
|
||||
# say "";
|
||||
say " let continue_info__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c<type> || 'unit'} -> (in_qstate, out_qstate) Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{";
|
||||
say " cf = info__$t<name>__$c<name>;";
|
||||
say " cf_continue = (fun state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
|
||||
say " cf_new_fold = (fun visitor state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
|
||||
say ' };;';
|
||||
# say "";
|
||||
}
|
||||
say " (* info for node $t<name> *)";
|
||||
say " let info__$t<name> : Adt_info.node = \{";
|
||||
my $kind = do given $t<kind> {
|
||||
when $record { "Record" }
|
||||
when $variant { "Variant" }
|
||||
default { "Poly \"$_\"" }
|
||||
};
|
||||
say " kind = $kind;";
|
||||
say " declaration_name = \"$t<name>\";";
|
||||
print " ctors_or_fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
|
||||
say "];";
|
||||
say ' };;';
|
||||
# say "";
|
||||
# TODO: factor out some of the common bits here.
|
||||
say " let continue_info__$t<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> $t<name> -> (in_qstate , out_qstate) Adt_info.instance = fun the_folds visitor x ->";
|
||||
say ' {';
|
||||
say " instance_declaration_name = \"$t<name>\";";
|
||||
do given $t<kind> {
|
||||
when $record {
|
||||
say ' instance_kind = RecordInstance {';
|
||||
print " fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> the_folds visitor x.$c<name> ; "; }
|
||||
say " ];";
|
||||
say ' };';
|
||||
}
|
||||
when $variant {
|
||||
say " instance_kind =";
|
||||
say ' VariantInstance {';
|
||||
say " constructor =";
|
||||
say " (match x with";
|
||||
for $t<ctorsOrFields>.list -> $c { say " | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> the_folds visitor { $c<type> ?? 'v' !! '()' }"; }
|
||||
say " );";
|
||||
print " variant = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
|
||||
say "];";
|
||||
say ' };';
|
||||
}
|
||||
default {
|
||||
say " instance_kind =";
|
||||
say ' PolyInstance {';
|
||||
say " poly = \"$_\";";
|
||||
print " arguments = [";
|
||||
# TODO: sort by c<name> (currently we only have one-argument
|
||||
# polymorphic types so it happens to work but should be fixed.
|
||||
for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
|
||||
say "];";
|
||||
print " poly_continue = (fun state -> visitor.$_ visitor (";
|
||||
print $t<ctorsOrFields>
|
||||
.map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> the_folds visitor x).cf_continue state)" })
|
||||
.join(", ");
|
||||
say ") state x);";
|
||||
say ' };';
|
||||
}
|
||||
};
|
||||
say ' };;';
|
||||
# say "";
|
||||
}
|
||||
|
||||
say "";
|
||||
say " (* info for adt $moduleName *)";
|
||||
print " let whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
|
||||
for $adts.list -> $t
|
||||
{ print "info__$t<name> ; "; }
|
||||
say "];;";
|
||||
|
||||
# fold functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say " let fold__$t<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $t<name> -> out_qstate = fun the_folds visitor state x ->";
|
||||
# TODO: add a non-generic continue_fold.
|
||||
say ' let node_instance_info : (in_qstate , out_qstate) Adt_info.node_instance_info = {';
|
||||
say " adt = whole_adt_info () ;";
|
||||
say " node_instance = continue_info__$t<name> the_folds visitor x";
|
||||
say ' } in';
|
||||
# say " let (state, new_x) = visitor.$t<name>.node__$t<name> x (fun () -> whole_adt_info, info__$t<name>) state continue_fold in";
|
||||
say " visitor.generic state node_instance_info;;";
|
||||
# say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " let fold__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> { $c<type> || 'unit' } -> out_qstate = fun the_folds visitor state { $c<type> ?? 'x' !! '()' } ->";
|
||||
# say " let ctor_or_field_instance_info : (in_qstate , out_qstate) Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
|
||||
if ($c<type> eq '') {
|
||||
# nothing to do, this constructor has no arguments.
|
||||
say " ignore the_folds; visitor.generic_empty_ctor state;;";
|
||||
} elsif ($c<isBuiltin>) {
|
||||
say " ignore the_folds; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
|
||||
} else {
|
||||
say " the_folds.fold__$c<type> the_folds visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
|
||||
}
|
||||
# say " visitor.$t<name>.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
|
||||
# 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 in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_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 = {';
|
||||
for $adts.list -> $t
|
||||
{ say " fold__$t<name>;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " fold__$t<name>__$c<name>;" } }
|
||||
say ' };;';
|
||||
|
||||
# Tying the knot
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say " let fold__$t<name> : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $t<name> -> out_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 in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> { $c<type> || 'unit' } -> out_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 in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; }
|
||||
|
||||
say "";
|
||||
say " module Folds (M : sig type in_state type out_state type 'a t val f : ((in_state , out_state) fold_config -> in_state -> 'a -> out_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";
|
||||
}
|
||||
|
||||
for $adts.list -> $t
|
||||
{ say "let no_op__$t<name> : type state . (state,_) fold_map_config__$t<name> = \{";
|
||||
say " node__$t<name> = no_op_node__$t<name>;";
|
||||
say " node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
|
||||
say " node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ print " $t<name>__$c<name> = (fun state v continue -> "; # (*_info*)
|
||||
if ($c<isBuiltin>) {
|
||||
print "ignore continue; return (state , v)";
|
||||
} else {
|
||||
print "continue.$c<type>.node__$c<type> state v";
|
||||
# auto-generated fold_map functions
|
||||
$*OUT = open $mapper_filename, :w;
|
||||
{
|
||||
say "(* This is an auto-generated file. Do not edit. *)";
|
||||
say "";
|
||||
for $statements -> $statement { say "$statement" }
|
||||
say "open Adt_generator.Common;;";
|
||||
say "open $moduleName;;";
|
||||
|
||||
say "";
|
||||
say "module type OSig = sig";
|
||||
for $adts.list -> $t {
|
||||
say " type $t<newName>;;";
|
||||
}
|
||||
say ") ;"; }
|
||||
say ' }' }
|
||||
|
||||
say "let no_op : type state . (state,_) fold_map_config__$moduleName = \{";
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = no_op__$t<name>;" }
|
||||
say '};;';
|
||||
for $adts.list -> $t {
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c {
|
||||
say " val make__$t<newName>__$c<newName> : {$c<type> ne '' ?? "$c<newType> " !! 'unit'} -> $t<newName>;;";
|
||||
}
|
||||
} elsif ($t<kind> eq $record) {
|
||||
print " val make__$t<newName>";
|
||||
say ' :';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " {$f<newName>}:{$f<newType>} ->"; }
|
||||
say " $t<newName>;;";
|
||||
} else {
|
||||
print " val make__$t<newName> : (";
|
||||
print $t<ctorsOrFields>.map({$_<newType>}).join(" , ");
|
||||
say ") $t<kind> -> $t<newName>;;";
|
||||
}
|
||||
}
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "let with__$t<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
|
||||
say "let with__$t<name>__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
|
||||
say "let with__$t<name>__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "let with__$t<name>__$c<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }
|
||||
say "";
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
|
||||
{ my $ty = $t<ctorsOrFields>[0]<type>;
|
||||
my $typeclass = $typeclasses{$t<kind>};
|
||||
say " val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; }
|
||||
say "end";
|
||||
|
||||
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>;;"; }
|
||||
say "end";
|
||||
say "";
|
||||
say "module Mapper (* O : OSig Functors are too slow and consume a lot of memory when compiling large files with OCaml. We're hardcoding the O module below for now. *) = struct";
|
||||
say " module O : OSig = $oModuleName";
|
||||
say "";
|
||||
say " (* must be provided by one of the open or include statements: *)";
|
||||
say " module CheckInputSignature = struct";
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
|
||||
{ say " let fold_map__$poly : type a new_a state err .{ $typeclasses{$poly} ?? " new_a extra_info__{$typeclasses{$poly}} ->" !! "" } (state -> a -> (state * new_a, err) monad) -> state -> a $poly -> (state * new_a $poly , err) monad = fold_map__$poly;;"; }
|
||||
say " end";
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t {
|
||||
say " type ('state, 'err) _continue_fold_map__$t<name> = \{";
|
||||
say " node__$t<name> : 'state -> $t<name> -> ('state * $t<oNewName> , 'err) monad ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<oNewType> || 'unit'} , 'err) monad ;" }
|
||||
say ' };;';
|
||||
}
|
||||
|
||||
say " type ('state , 'err) _continue_fold_map__$moduleName = \{";
|
||||
for $adts.list -> $t {
|
||||
say " $t<name> : ('state , 'err) _continue_fold_map__$t<name> ;";
|
||||
}
|
||||
say ' };;';
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say " type ('state, 'err) fold_map_config__$t<name> = \{";
|
||||
say " node__$t<name> : 'state -> $t<name> -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t<oNewName> , 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
|
||||
say " node__$t<name>__pre_state : 'state -> $t<name> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
|
||||
say " node__$t<name>__post_state : 'state -> $t<name> -> $t<oNewName> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c<oNewType> || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
|
||||
}
|
||||
say ' };;' }
|
||||
|
||||
say " type ('state, 'err) fold_map_config__$moduleName = \{";
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> : ('state, 'err) fold_map_config__$t<name>;" }
|
||||
say ' };;';
|
||||
|
||||
say "";
|
||||
say " type ('state, 'err) mk_continue_fold_map = \{";
|
||||
say " fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName";
|
||||
say ' };;';
|
||||
|
||||
|
||||
# fold_map functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say " let _fold_map__$t<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<oNewName>, err) monad = fun mk_continue_fold_map visitor state x ->";
|
||||
say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
|
||||
say " visitor.$t<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
|
||||
say " visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
|
||||
say " visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
|
||||
say " return (state, new_x);;";
|
||||
# say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " let _fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<oNewType> || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->";
|
||||
say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
|
||||
say " visitor.$t<name>.$t<name>__$c<name> state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
|
||||
# say "";
|
||||
}
|
||||
}
|
||||
|
||||
# make the "continue" object
|
||||
say "";
|
||||
say ' (* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
|
||||
say " let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{";
|
||||
say " fn =";
|
||||
say " fun self visitor ->";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = \{";
|
||||
say " node__$t<name> = (fun state x -> _fold_map__$t<name> self visitor state x) ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> self visitor state x) ;"; }
|
||||
say ' };' }
|
||||
say ' }';
|
||||
say ' };;';
|
||||
say "";
|
||||
|
||||
# fold_map functions : tying the knot
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say " let fold_map__$t<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<oNewName>,err) monad =";
|
||||
say " fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x;;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " let fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<oNewType> || 'unit' },err) monad =";
|
||||
say " fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x;;"; } }
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{
|
||||
say " let no_op_node__$t<name> : type state . state -> $t<name> -> (state,_) _continue_fold_map__$moduleName -> (state * $t<oNewName>,_) monad =";
|
||||
say " fun state v continue ->"; # (*_info*)
|
||||
say " match v with";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ given $c<type> {
|
||||
when '' { say " | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , O.make__$t<newName>__$c<newName> ())"; }
|
||||
default { say " | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , O.make__$t<newName>__$c<newName> v)"; } } }
|
||||
} elsif ($t<kind> eq $record) {
|
||||
print ' { ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<name>; "; }
|
||||
say "} ->";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
|
||||
print " return (state , (O.make__$t<newName>";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print " ~$f<newName>"; }
|
||||
say " : $t<oNewName>))";
|
||||
} else {
|
||||
print " v -> (fold_map__$t<kind>";
|
||||
if ($t<kind> ne $record && $t<kind> ne $variant && $typeclasses{$t<kind>}) {
|
||||
for $t<ctorsOrFields>.list -> $a
|
||||
{ print " O.extra_info__$a<type>__{$typeclasses{$t<kind>}}"; }
|
||||
}
|
||||
print " ( ";
|
||||
print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", ");
|
||||
say " ) state v)";
|
||||
say " >>? fun (state, x) -> return (state, O.make__$t<name> x);;";
|
||||
}
|
||||
}
|
||||
|
||||
for $adts.list -> $t
|
||||
{ say " let no_op__$t<name> : type state . (state,_) fold_map_config__$t<name> = \{";
|
||||
say " node__$t<name> = no_op_node__$t<name>;";
|
||||
say " node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
|
||||
say " node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ print " $t<name>__$c<name> = (fun state v continue -> "; # (*_info*)
|
||||
if ($c<isBuiltin>) {
|
||||
print "ignore continue; return (state , v)";
|
||||
} else {
|
||||
print "continue.$c<type>.node__$c<type> state v";
|
||||
}
|
||||
say ") ;"; }
|
||||
say ' }' }
|
||||
|
||||
say " let no_op : type state . (state,_) fold_map_config__$moduleName = \{";
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = no_op__$t<name>;" }
|
||||
say ' };;';
|
||||
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say " let with__$t<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
|
||||
say " let with__$t<name>__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
|
||||
say " let with__$t<name>__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " let with__$t<name>__$c<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }
|
||||
say "end";
|
||||
}
|
||||
|
||||
$*OUT = open $combinators_filename, :w;
|
||||
{
|
||||
say "(* This is an auto-generated file. Do not edit. *)";
|
||||
say "";
|
||||
for $statements -> $statement { say "$statement" }
|
||||
say "open $moduleName;;";
|
||||
say "";
|
||||
for $adts.list -> $t {
|
||||
say "type nonrec $t<name> = $t<name>;;";
|
||||
}
|
||||
|
||||
for $adts.list -> $t {
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c {
|
||||
say "let make__$t<name>__$c<name> : {$c<type> ne '' ?? "$c<newType> " !! 'unit'} -> $t<name> = fun {$c<type> ne '' ?? 'v' !! '()'} -> $c<name> {$c<type> ne '' ?? 'v ' !! ''};;";
|
||||
}
|
||||
} elsif ($t<kind> eq $record) {
|
||||
print "let make__$t<name>";
|
||||
print ' :';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print " {$f<newName>}:{$f<newType>} ->"; }
|
||||
print " $t<newName> = fun";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print " ~{$f<newName>}"; }
|
||||
print " -> \{";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print " {$f<newName>} ;"; }
|
||||
say " \};;";
|
||||
} else {
|
||||
print "let make__$t<newName> : (";
|
||||
print $t<ctorsOrFields>.map({$_<newType>}).join(" , ");
|
||||
print ") $t<kind> -> $t<newName> = ";
|
||||
print "fun x -> x";
|
||||
say ";;";
|
||||
}
|
||||
}
|
||||
|
||||
say "";
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
|
||||
{ my $ty = $t<ctorsOrFields>[0]<type>;
|
||||
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;;";
|
||||
}
|
||||
|
||||
@ -1,44 +1,44 @@
|
||||
module BlahBluh = struct
|
||||
module StringMap = Map.Make(String);;
|
||||
(* generic folds for nodes *)
|
||||
type 'state generic_continue_fold_node = {
|
||||
continue : 'state -> 'state ;
|
||||
(* generic folds for each field *)
|
||||
continue_ctors_or_fields : ('state -> 'state) StringMap.t ;
|
||||
};;
|
||||
(* map from node names to their generic folds *)
|
||||
type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
|
||||
module StringMap = Map.Make(String);;
|
||||
(* generic folds for nodes *)
|
||||
type 'state generic_continue_fold_node = {
|
||||
continue : 'state -> 'state ;
|
||||
(* generic folds for each field *)
|
||||
continue_ctors_or_fields : ('state -> 'state) StringMap.t ;
|
||||
};;
|
||||
(* map from node names to their generic folds *)
|
||||
type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
|
||||
end
|
||||
|
||||
module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_config end) = struct
|
||||
module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct
|
||||
type kind =
|
||||
| Record
|
||||
| Variant
|
||||
| Poly of string
|
||||
|
||||
type 'state record_instance = {
|
||||
fields : 'state ctor_or_field_instance list;
|
||||
type ('in_state , 'out_state) record_instance = {
|
||||
fields : ('in_state , 'out_state) ctor_or_field_instance list;
|
||||
}
|
||||
|
||||
and 'state constructor_instance = {
|
||||
constructor : 'state ctor_or_field_instance ;
|
||||
and ('in_state , 'out_state) constructor_instance = {
|
||||
constructor : ('in_state , 'out_state) ctor_or_field_instance ;
|
||||
variant : ctor_or_field list
|
||||
}
|
||||
|
||||
and 'state poly_instance = {
|
||||
and ('in_state , 'out_state) poly_instance = {
|
||||
poly : string;
|
||||
arguments : string list;
|
||||
poly_continue : 'state -> 'state
|
||||
poly_continue : 'in_state -> 'out_state
|
||||
}
|
||||
|
||||
and 'state kind_instance =
|
||||
| RecordInstance of 'state record_instance
|
||||
| VariantInstance of 'state constructor_instance
|
||||
| PolyInstance of 'state poly_instance
|
||||
and ('in_state , 'out_state) kind_instance =
|
||||
| RecordInstance of ('in_state , 'out_state) record_instance
|
||||
| VariantInstance of ('in_state , 'out_state) constructor_instance
|
||||
| PolyInstance of ('in_state , 'out_state) poly_instance
|
||||
|
||||
and 'state instance = {
|
||||
and ('in_state , 'out_state) instance = {
|
||||
instance_declaration_name : string;
|
||||
instance_kind : 'state kind_instance;
|
||||
instance_kind : ('in_state , 'out_state) kind_instance;
|
||||
}
|
||||
|
||||
and ctor_or_field =
|
||||
@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
|
||||
type_ : string;
|
||||
}
|
||||
|
||||
and 'state ctor_or_field_instance =
|
||||
and ('in_state , 'out_state) ctor_or_field_instance =
|
||||
{
|
||||
cf : ctor_or_field;
|
||||
cf_continue : 'state -> 'state;
|
||||
cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> 'state;
|
||||
cf_continue : 'in_state -> 'out_state;
|
||||
cf_new_fold : 'in_state 'out_state . ('in_state , 'out_state , (('in_state , 'out_state) node_instance_info)) M.fold_config -> 'in_state -> 'out_state;
|
||||
}
|
||||
|
||||
and node =
|
||||
@ -64,9 +64,9 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
|
||||
|
||||
(* TODO: rename things a bit in this file. *)
|
||||
and adt = node list
|
||||
and 'state node_instance_info = {
|
||||
and ('in_state , 'out_state) node_instance_info = {
|
||||
adt : adt ;
|
||||
node_instance : 'state instance ;
|
||||
node_instance : ('in_state , 'out_state) instance ;
|
||||
}
|
||||
and 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
|
||||
and ('in_state , 'out_state) ctor_or_field_instance_info = adt * node * ('in_state , 'out_state) ctor_or_field_instance
|
||||
end
|
||||
|
||||
2
src/test/adt_generator/.gitignore
vendored
2
src/test/adt_generator/.gitignore
vendored
@ -1 +1,3 @@
|
||||
/generated_fold.ml
|
||||
/generated_map.ml
|
||||
/generated_o.ml
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
[@@@warning "-33"]
|
||||
(* open Amodule_utils *)
|
||||
|
||||
type root =
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
(rule
|
||||
(target generated_fold.ml)
|
||||
(targets generated_fold.ml generated_map.ml generated_o.ml)
|
||||
(deps ../../../src/stages/adt_generator/generator.raku amodule.ml)
|
||||
(action (with-stdout-to generated_fold.ml (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml)))
|
||||
(action (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml))
|
||||
(mode (promote (until-clean) (only *)))
|
||||
)
|
||||
|
||||
|
||||
@ -1 +1,2 @@
|
||||
include Generated_fold
|
||||
include Generated_map.Mapper
|
||||
|
||||
@ -2,6 +2,8 @@ open Amodule
|
||||
open Fold
|
||||
open Simple_utils.Trace
|
||||
|
||||
module O = Fold.O
|
||||
|
||||
let (|>) v f = f v
|
||||
|
||||
module Errors = struct
|
||||
@ -22,9 +24,9 @@ let () =
|
||||
let op =
|
||||
no_op |>
|
||||
with__a (fun state the_a (*_info*) continue_fold ->
|
||||
let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in
|
||||
let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in
|
||||
ok (state + 1, { a1__' ; a2__' }))
|
||||
let%bind state, a1 = continue_fold.ta1.node__ta1 state the_a.a1 in
|
||||
let%bind state, a2 = continue_fold.ta2.node__ta2 state the_a.a2 in
|
||||
ok (state + 1, (O.make__a ~a1 ~a2 : O.a)))
|
||||
in
|
||||
let state = 0 in
|
||||
let%bind (state , _) = fold_map__root op state some_root in
|
||||
@ -61,35 +63,33 @@ let () =
|
||||
let _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
|
||||
let _nob : (bool, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
|
||||
|
||||
type no_state = NoState
|
||||
let () =
|
||||
let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in
|
||||
let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in
|
||||
let nostate = false, "" in
|
||||
let op = {
|
||||
generic = (fun state info ->
|
||||
assert_nostate state;
|
||||
let op : ('i, 'o) Generated_fold.fold_config = {
|
||||
generic = (fun NoState info ->
|
||||
match info.node_instance.instance_kind with
|
||||
| RecordInstance { fields } ->
|
||||
false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
|
||||
false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }"
|
||||
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } ->
|
||||
(match cf_continue nostate with
|
||||
(match cf_continue NoState with
|
||||
| true, arg -> true, name ^ " (" ^ arg ^ ")"
|
||||
| false, arg -> true, name ^ " " ^ arg)
|
||||
| PolyInstance { poly=_; arguments=_; poly_continue } ->
|
||||
(poly_continue nostate)
|
||||
(poly_continue NoState)
|
||||
) ;
|
||||
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
|
||||
unit = (fun _visitor state () -> assert_nostate state; false , "()") ;
|
||||
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
|
||||
list = (fun _visitor continue state lst ->
|
||||
assert_nostate state;
|
||||
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
|
||||
generic_empty_ctor = (fun NoState -> false, "") ;
|
||||
string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ;
|
||||
unit = (fun _visitor NoState () -> false , "()") ;
|
||||
int = (fun _visitor NoState i -> false , string_of_int i) ;
|
||||
list = (fun _visitor continue NoState lst ->
|
||||
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ;
|
||||
(* generic_ctor_or_field = (fun _info state ->
|
||||
* match _info () with
|
||||
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
|
||||
* ); *)
|
||||
} in
|
||||
let (_ , state) = fold__root op nostate some_root in
|
||||
let (_ , state) = Generated_fold.fold__root op NoState some_root in
|
||||
let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
|
||||
if String.equal state expected; then
|
||||
()
|
||||
|
||||
@ -15,6 +15,9 @@
|
||||
evaluateFunction:
|
||||
entrypoint: add
|
||||
parameters: 5, 6
|
||||
generateDeployScript:
|
||||
entrypoint: main
|
||||
storage: 0
|
||||
*_*)
|
||||
type storage = int
|
||||
|
||||
|
||||
@ -15,6 +15,9 @@
|
||||
evaluateFunction:
|
||||
entrypoint: add
|
||||
parameters: (5, 6)
|
||||
generateDeployScript:
|
||||
entrypoint: main
|
||||
storage: 0
|
||||
*_*)
|
||||
// variant defining pseudo multi-entrypoint actions
|
||||
type action is
|
||||
|
||||
@ -15,6 +15,9 @@
|
||||
evaluateFunction:
|
||||
entrypoint: add
|
||||
parameters: (5, 6)
|
||||
generateDeployScript:
|
||||
entrypoint: main
|
||||
storage: 0
|
||||
*_*)
|
||||
type storage = int;
|
||||
|
||||
|
||||
5
tools/webide/packages/client/package-lock.json
generated
5
tools/webide/packages/client/package-lock.json
generated
@ -16168,6 +16168,11 @@
|
||||
}
|
||||
}
|
||||
},
|
||||
"slugify": {
|
||||
"version": "1.4.0",
|
||||
"resolved": "https://registry.npmjs.org/slugify/-/slugify-1.4.0.tgz",
|
||||
"integrity": "sha512-FtLNsMGBSRB/0JOE2A0fxlqjI6fJsgHGS13iTuVT28kViI4JjUiNqp/vyis0ZXYcMnpR3fzGNkv+6vRlI2GwdQ=="
|
||||
},
|
||||
"snapdragon": {
|
||||
"version": "0.8.2",
|
||||
"resolved": "https://registry.npmjs.org/snapdragon/-/snapdragon-0.8.2.tgz",
|
||||
|
||||
@ -7,7 +7,7 @@ import { DeployAction } from '../../redux/actions/deploy';
|
||||
import { DryRunAction } from '../../redux/actions/dry-run';
|
||||
import { EvaluateFunctionAction } from '../../redux/actions/evaluate-function';
|
||||
import { EvaluateValueAction } from '../../redux/actions/evaluate-value';
|
||||
import { GenerateCommandAction } from '../../redux/actions/generate-command';
|
||||
import { GenerateDeployScriptAction } from '../../redux/actions/generate-deploy-script';
|
||||
import { AppState } from '../../redux/app';
|
||||
import { ChangeDispatchedAction, ChangeSelectedAction, CommandState } from '../../redux/command';
|
||||
import { Command } from '../../redux/types';
|
||||
@ -17,7 +17,7 @@ import { DeployPaneComponent } from './deploy-pane';
|
||||
import { DryRunPaneComponent } from './dry-run-pane';
|
||||
import { EvaluateFunctionPaneComponent } from './evaluate-function-pane';
|
||||
import { EvaluateValuePaneComponent } from './evaluate-value-pane';
|
||||
import { GenerateCommandPaneComponent } from './generate-command-pane';
|
||||
import { GenerateDeployScriptPane } from './generate-deploy-script-pane';
|
||||
|
||||
const Container = styled.div<{ visible?: boolean }>`
|
||||
position: absolute;
|
||||
@ -76,8 +76,8 @@ function createAction(command: Command) {
|
||||
return new EvaluateValueAction();
|
||||
case Command.EvaluateFunction:
|
||||
return new EvaluateFunctionAction();
|
||||
case Command.GenerateCommand:
|
||||
return new GenerateCommandAction();
|
||||
case Command.GenerateDeployScript:
|
||||
return new GenerateDeployScriptAction();
|
||||
default:
|
||||
throw new Error('Unsupported command');
|
||||
}
|
||||
@ -113,7 +113,7 @@ export const ConfigureTabComponent = (props: {
|
||||
<Option value={Command.DryRun}>Dry Run</Option>
|
||||
<Option value={Command.EvaluateFunction}>Evaluate Function</Option>
|
||||
<Option value={Command.EvaluateValue}>Evaluate Value</Option>
|
||||
<Option value={Command.GenerateCommand}>Generate Command</Option>
|
||||
<Option value={Command.GenerateDeployScript}>Generate Deploy Script</Option>
|
||||
</SelectCommand>
|
||||
<RunButton
|
||||
id="run"
|
||||
@ -147,8 +147,8 @@ export const ConfigureTabComponent = (props: {
|
||||
(command === Command.EvaluateValue && (
|
||||
<EvaluateValuePaneComponent></EvaluateValuePaneComponent>
|
||||
)) ||
|
||||
(command === Command.GenerateCommand && (
|
||||
<GenerateCommandPaneComponent></GenerateCommandPaneComponent>
|
||||
(command === Command.GenerateDeployScript && (
|
||||
<GenerateDeployScriptPane></GenerateDeployScriptPane>
|
||||
))}
|
||||
</Container>
|
||||
);
|
||||
|
||||
@ -8,8 +8,8 @@ import {
|
||||
ChangeEntrypointAction,
|
||||
ChangeStorageAction,
|
||||
ChangeToolAction,
|
||||
GenerateCommandState,
|
||||
} from '../../redux/generate-command';
|
||||
GenerateDeployScriptState,
|
||||
} from '../../redux/generate-deploy-script';
|
||||
import { Tool, ToolCommand } from '../../redux/types';
|
||||
import { AccessFunctionLabel, Group, Input, Label, Textarea } from '../form/inputs';
|
||||
import { Option, Select } from '../form/select';
|
||||
@ -18,23 +18,23 @@ const Container = styled.div`
|
||||
overflow: auto;
|
||||
`;
|
||||
|
||||
export const GenerateCommandPaneComponent = () => {
|
||||
export const GenerateDeployScriptPane = () => {
|
||||
const dispatch = useDispatch();
|
||||
|
||||
const tool = useSelector<AppState, GenerateCommandState['tool']>(
|
||||
state => state.generateCommand.tool
|
||||
const tool = useSelector<AppState, GenerateDeployScriptState['tool']>(
|
||||
state => state.generateDeployScript.tool
|
||||
);
|
||||
|
||||
const command = useSelector<AppState, GenerateCommandState['command']>(
|
||||
state => state.generateCommand.command
|
||||
const command = useSelector<AppState, GenerateDeployScriptState['command']>(
|
||||
state => state.generateDeployScript.command
|
||||
);
|
||||
|
||||
const entrypoint = useSelector<AppState, GenerateCommandState['entrypoint']>(
|
||||
state => state.generateCommand.entrypoint
|
||||
const entrypoint = useSelector<AppState, GenerateDeployScriptState['entrypoint']>(
|
||||
state => state.generateDeployScript.entrypoint
|
||||
);
|
||||
|
||||
const storage = useSelector<AppState, GenerateCommandState['storage']>(
|
||||
state => state.generateCommand.storage
|
||||
const storage = useSelector<AppState, GenerateDeployScriptState['storage']>(
|
||||
state => state.generateDeployScript.storage
|
||||
);
|
||||
|
||||
return (
|
||||
@ -24,7 +24,7 @@ const Pre = styled.pre`
|
||||
margin: 0;
|
||||
`;
|
||||
|
||||
export const GenerateCommandOutputPane = () => {
|
||||
export const GenerateDeployScriptOutputPane = () => {
|
||||
const output = useSelector<AppState, ResultState['output']>(
|
||||
state => state.result.output
|
||||
);
|
||||
@ -8,7 +8,7 @@ import { ResultState } from '../../redux/result';
|
||||
import { Command } from '../../redux/types';
|
||||
import { CompileOutputPane } from './compile-output-pane';
|
||||
import { DeployOutputPane } from './deploy-output-pane';
|
||||
import { GenerateCommandOutputPane } from './generate-command-output-pane';
|
||||
import { GenerateDeployScriptOutputPane } from './generate-deploy-script-output-pane';
|
||||
import { Loading } from './loading';
|
||||
import { OutputPane } from './output-pane';
|
||||
|
||||
@ -55,8 +55,8 @@ export const OutputTab = (props: {
|
||||
return <CompileOutputPane></CompileOutputPane>;
|
||||
} else if (command === Command.Deploy) {
|
||||
return <DeployOutputPane></DeployOutputPane>;
|
||||
} else if (command === Command.GenerateCommand) {
|
||||
return <GenerateCommandOutputPane></GenerateCommandOutputPane>;
|
||||
} else if (command === Command.GenerateDeployScript) {
|
||||
return <GenerateDeployScriptOutputPane></GenerateDeployScriptOutputPane>;
|
||||
}
|
||||
|
||||
return <OutputPane></OutputPane>;
|
||||
|
||||
@ -22,25 +22,25 @@ export async function fetchRandomPrivateKey(): Promise<string> {
|
||||
return response.text();
|
||||
}
|
||||
|
||||
export class GenerateCommandAction extends CancellableAction {
|
||||
export class GenerateDeployScriptAction extends CancellableAction {
|
||||
getAction() {
|
||||
return async (dispatch: Dispatch, getState: () => AppState) => {
|
||||
dispatch({ ...new UpdateLoadingAction('Compiling contract...') });
|
||||
|
||||
try {
|
||||
const { editor, generateCommand } = getState();
|
||||
const { editor, generateDeployScript } = getState();
|
||||
|
||||
const michelsonCodeJson = await compileContract(
|
||||
editor.language,
|
||||
editor.code,
|
||||
generateCommand.entrypoint,
|
||||
generateDeployScript.entrypoint,
|
||||
MichelsonFormat.Json
|
||||
);
|
||||
|
||||
const michelsonCode = await compileContract(
|
||||
editor.language,
|
||||
editor.code,
|
||||
generateCommand.entrypoint
|
||||
generateDeployScript.entrypoint
|
||||
);
|
||||
|
||||
if (this.isCancelled()) {
|
||||
@ -51,16 +51,16 @@ export class GenerateCommandAction extends CancellableAction {
|
||||
const michelsonStorageJson = await compileStorage(
|
||||
editor.language,
|
||||
editor.code,
|
||||
generateCommand.entrypoint,
|
||||
generateCommand.storage,
|
||||
generateDeployScript.entrypoint,
|
||||
generateDeployScript.storage,
|
||||
MichelsonFormat.Json
|
||||
);
|
||||
|
||||
const michelsonStorage = await compileStorage(
|
||||
editor.language,
|
||||
editor.code,
|
||||
generateCommand.entrypoint,
|
||||
generateCommand.storage
|
||||
generateDeployScript.entrypoint,
|
||||
generateDeployScript.storage
|
||||
);
|
||||
|
||||
if (this.isCancelled()) {
|
||||
@ -82,7 +82,7 @@ export class GenerateCommandAction extends CancellableAction {
|
||||
|
||||
const title = slugify(editor.title).toLowerCase() || 'untitled';
|
||||
const output = `tezos-client \\
|
||||
${generateCommand.command} \\
|
||||
${generateDeployScript.command} \\
|
||||
contract \\
|
||||
${title} \\
|
||||
transferring 0 \\
|
||||
@ -92,7 +92,7 @@ export class GenerateCommandAction extends CancellableAction {
|
||||
--burn-cap ${estimate.burnFeeMutez / 1000000}`;
|
||||
|
||||
dispatch({
|
||||
...new ChangeOutputAction(output, Command.GenerateCommand)
|
||||
...new ChangeOutputAction(output, Command.GenerateDeployScript)
|
||||
});
|
||||
} catch (ex) {
|
||||
if (this.isCancelled()) {
|
||||
@ -101,7 +101,7 @@ export class GenerateCommandAction extends CancellableAction {
|
||||
dispatch({
|
||||
...new ChangeOutputAction(
|
||||
`Error: ${getErrorMessage(ex)}`,
|
||||
Command.GenerateCommand
|
||||
Command.GenerateDeployScript
|
||||
)
|
||||
});
|
||||
}
|
||||
@ -8,7 +8,7 @@ import editor, { EditorState } from './editor';
|
||||
import evaluateFunction, { EvaluateFunctionState } from './evaluate-function';
|
||||
import evaluateValue, { EvaluateValueState } from './evaluate-value';
|
||||
import examples, { ExamplesState } from './examples';
|
||||
import generateCommand, { GenerateCommandState } from './generate-command';
|
||||
import generateDeployScript, { GenerateDeployScriptState } from './generate-deploy-script';
|
||||
import loading, { LoadingState } from './loading';
|
||||
import result, { ResultState } from './result';
|
||||
import share, { ShareState } from './share';
|
||||
@ -23,7 +23,7 @@ export interface AppState {
|
||||
deploy: DeployState;
|
||||
evaluateFunction: EvaluateFunctionState;
|
||||
evaluateValue: EvaluateValueState;
|
||||
generateCommand: GenerateCommandState;
|
||||
generateDeployScript: GenerateDeployScriptState;
|
||||
result: ResultState;
|
||||
command: CommandState;
|
||||
examples: ExamplesState;
|
||||
@ -38,7 +38,7 @@ export default combineReducers({
|
||||
deploy,
|
||||
evaluateFunction,
|
||||
evaluateValue,
|
||||
generateCommand,
|
||||
generateDeployScript,
|
||||
result,
|
||||
command,
|
||||
examples,
|
||||
|
||||
@ -4,6 +4,8 @@ import { DryRunState } from './dry-run';
|
||||
import { EditorState } from './editor';
|
||||
import { EvaluateFunctionState } from './evaluate-function';
|
||||
import { EvaluateValueState } from './evaluate-value';
|
||||
import { GenerateDeployScriptState } from './generate-deploy-script';
|
||||
|
||||
|
||||
export interface ExampleState {
|
||||
id: string;
|
||||
@ -14,4 +16,5 @@ export interface ExampleState {
|
||||
deploy: DeployState;
|
||||
evaluateFunction: EvaluateFunctionState;
|
||||
evaluateValue: EvaluateValueState;
|
||||
generateDeployScript: GenerateDeployScriptState;
|
||||
}
|
||||
|
||||
@ -1,13 +1,14 @@
|
||||
import { ActionType as ExamplesActionType, ChangeSelectedAction as ChangeSelectedExampleAction } from './examples';
|
||||
import { Tool, ToolCommand } from './types';
|
||||
|
||||
export enum ActionType {
|
||||
ChangeTool = 'generate-command-change-tool',
|
||||
ChangeCommand = 'generate-command-change-command',
|
||||
ChangeEntrypoint = 'generate-command-change-entrypoint',
|
||||
ChangeStorage = 'generate-command-change-storage'
|
||||
ChangeTool = 'generate-deploy-script-change-tool',
|
||||
ChangeCommand = 'generate-deploy-script-change-command',
|
||||
ChangeEntrypoint = 'generate-deploy-script-change-entrypoint',
|
||||
ChangeStorage = 'generate-deploy-script-change-storage'
|
||||
}
|
||||
|
||||
export interface GenerateCommandState {
|
||||
export interface GenerateDeployScriptState {
|
||||
tool: Tool;
|
||||
command: ToolCommand;
|
||||
entrypoint: string;
|
||||
@ -18,31 +19,32 @@ export interface GenerateCommandState {
|
||||
|
||||
export class ChangeToolAction {
|
||||
public readonly type = ActionType.ChangeTool;
|
||||
constructor(public payload: GenerateCommandState['tool']) {}
|
||||
constructor(public payload: GenerateDeployScriptState['tool']) {}
|
||||
}
|
||||
|
||||
export class ChangeCommandAction {
|
||||
public readonly type = ActionType.ChangeCommand;
|
||||
constructor(public payload: GenerateCommandState['command']) {}
|
||||
constructor(public payload: GenerateDeployScriptState['command']) {}
|
||||
}
|
||||
|
||||
export class ChangeEntrypointAction {
|
||||
public readonly type = ActionType.ChangeEntrypoint;
|
||||
constructor(public payload: GenerateCommandState['entrypoint']) {}
|
||||
constructor(public payload: GenerateDeployScriptState['entrypoint']) {}
|
||||
}
|
||||
|
||||
export class ChangeStorageAction {
|
||||
public readonly type = ActionType.ChangeStorage;
|
||||
constructor(public payload: GenerateCommandState['storage']) {}
|
||||
constructor(public payload: GenerateDeployScriptState['storage']) {}
|
||||
}
|
||||
|
||||
type Action =
|
||||
| ChangeToolAction
|
||||
| ChangeCommandAction
|
||||
| ChangeEntrypointAction
|
||||
| ChangeStorageAction;
|
||||
| ChangeStorageAction
|
||||
| ChangeSelectedExampleAction;
|
||||
|
||||
const DEFAULT_STATE: GenerateCommandState = {
|
||||
const DEFAULT_STATE: GenerateDeployScriptState = {
|
||||
tool: Tool.TezosClient,
|
||||
command: ToolCommand.Originate,
|
||||
entrypoint: '',
|
||||
@ -54,8 +56,13 @@ const DEFAULT_STATE: GenerateCommandState = {
|
||||
export default (
|
||||
state = DEFAULT_STATE,
|
||||
action: Action
|
||||
): GenerateCommandState => {
|
||||
): GenerateDeployScriptState => {
|
||||
switch (action.type) {
|
||||
case ExamplesActionType.ChangeSelected:
|
||||
return {
|
||||
...state,
|
||||
...(!action.payload ? DEFAULT_STATE : action.payload.generateDeployScript)
|
||||
};
|
||||
case ActionType.ChangeTool:
|
||||
return {
|
||||
...state,
|
||||
@ -10,7 +10,7 @@ export enum Command {
|
||||
EvaluateValue = 'evaluate-value',
|
||||
EvaluateFunction = 'evaluate-function',
|
||||
Deploy = 'deploy',
|
||||
GenerateCommand = 'generate-command'
|
||||
GenerateDeployScript = 'generate-deploy-script'
|
||||
}
|
||||
|
||||
export enum Tool {
|
||||
|
||||
3
tools/webide/packages/server/package-lock.json
generated
3
tools/webide/packages/server/package-lock.json
generated
@ -3317,8 +3317,7 @@
|
||||
"gensync": {
|
||||
"version": "1.0.0-beta.1",
|
||||
"resolved": "https://registry.npmjs.org/gensync/-/gensync-1.0.0-beta.1.tgz",
|
||||
"integrity": "sha512-r8EC6NO1sngH/zdD9fiRDLdcgnbayXah+mLgManTaIZJqEC1MZstmnox8KpnI2/fxQwrp5OpCOYWLp4rBl4Jcg==",
|
||||
"dev": true
|
||||
"integrity": "sha512-r8EC6NO1sngH/zdD9fiRDLdcgnbayXah+mLgManTaIZJqEC1MZstmnox8KpnI2/fxQwrp5OpCOYWLp4rBl4Jcg=="
|
||||
},
|
||||
"get-caller-file": {
|
||||
"version": "2.0.5",
|
||||
|
||||
@ -11,16 +11,16 @@
|
||||
},
|
||||
"devDependencies": {
|
||||
"@ts-tools/node": "^1.0.0",
|
||||
"@types/cors": "^2.8.6",
|
||||
"@types/express": "^4.17.1",
|
||||
"@types/express-winston": "^3.0.4",
|
||||
"@types/hapi__joi": "^16.0.1",
|
||||
"@types/jest": "^24.0.23",
|
||||
"@types/joi": "^14.3.3",
|
||||
"@types/node": "10",
|
||||
"@types/node-fetch": "^2.5.4",
|
||||
"@types/tmp": "^0.1.0",
|
||||
"@types/winston": "^2.4.4",
|
||||
"@types/cors": "^2.8.6",
|
||||
"@types/node-fetch": "^2.5.4",
|
||||
"jest": "^24.9.0",
|
||||
"nodemon": "^1.19.3",
|
||||
"ts-jest": "^24.1.0",
|
||||
@ -40,6 +40,7 @@
|
||||
"express": "^4.17.1",
|
||||
"express-prometheus-middleware": "^0.8.5",
|
||||
"express-winston": "^4.0.1",
|
||||
"gensync": "^1.0.0-beta.1",
|
||||
"node-fetch": "^2.6.0",
|
||||
"sanitize-html": "^1.20.1",
|
||||
"tmp": "^0.1.0",
|
||||
|
||||
@ -11,7 +11,7 @@ interface CompileBody {
|
||||
format?: string;
|
||||
}
|
||||
|
||||
const validateRequest = (body: any): { value: CompileBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: CompileBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -10,7 +10,7 @@ interface CompileBody {
|
||||
format?: string;
|
||||
}
|
||||
|
||||
const validateRequest = (body: any): { value: CompileBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: CompileBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -12,7 +12,7 @@ interface CompileBody {
|
||||
format?: string;
|
||||
}
|
||||
|
||||
const validateRequest = (body: any): { value: CompileBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: CompileBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -15,7 +15,7 @@ interface DeployBody {
|
||||
|
||||
Tezos.setProvider({ rpc: 'https://api.tez.ie/rpc/carthagenet' });
|
||||
|
||||
const validateRequest = (body: any): { value: DeployBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: DeployBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -12,7 +12,7 @@ interface DryRunBody {
|
||||
storage: string;
|
||||
}
|
||||
|
||||
const validateRequest = (body: any): { value: DryRunBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: DryRunBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -12,7 +12,7 @@ interface EvaluateValueBody {
|
||||
|
||||
const validateRequest = (
|
||||
body: any
|
||||
): { value: EvaluateValueBody; error: any } => {
|
||||
): { value: EvaluateValueBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -11,7 +11,7 @@ interface RunFunctionBody {
|
||||
parameters: string;
|
||||
}
|
||||
|
||||
const validateRequest = (body: any): { value: RunFunctionBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: RunFunctionBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
syntax: joi.string().required(),
|
||||
|
||||
@ -35,7 +35,7 @@ interface ShareBody {
|
||||
};
|
||||
}
|
||||
|
||||
const validateRequest = (body: any): { value: ShareBody; error: any } => {
|
||||
const validateRequest = (body: any): { value: ShareBody; error?: any } => {
|
||||
return joi
|
||||
.object({
|
||||
editor: joi
|
||||
|
||||
@ -28,6 +28,7 @@ export async function loadDefaultState(appBundleDirectory: string) {
|
||||
deploy: {},
|
||||
evaluateValue: {},
|
||||
evaluateFunction: {},
|
||||
generateDeployScript: {},
|
||||
editor: {
|
||||
title: ''
|
||||
},
|
||||
@ -63,6 +64,10 @@ export async function loadDefaultState(appBundleDirectory: string) {
|
||||
...defaultState.evaluateFunction,
|
||||
...defaultExample.evaluateFunction
|
||||
};
|
||||
defaultState.generateDeployScript = {
|
||||
...defaultState.generateDeployScript,
|
||||
...defaultExample.generateDeployScript
|
||||
};
|
||||
defaultState.editor = {
|
||||
...defaultState.editor,
|
||||
...defaultExample.editor,
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
11
vendors/ligo-utils/simple-utils/location.ml
vendored
11
vendors/ligo-utils/simple-utils/location.ml
vendored
@ -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
5
vendors/ligo-utils/simple-utils/region.ml
vendored
@ -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
5
vendors/ligo-utils/simple-utils/region.mli
vendored
@ -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
11
vendors/ligo-utils/simple-utils/x_list.ml
vendored
@ -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
6
vendors/ligo-utils/simple-utils/x_string.ml
vendored
@ -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
1
vendors/ligo-utils/simple-utils/x_string.mli
vendored
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user