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

Merge branch 'feature/adt-generator-8-split-modules-and-add-output-module' into 'dev'

Browse Source 
ADT generator: split into separate modules and add output module "O"

Closes LIGO-656

See merge request ligolang/ligo!629
This commit is contained in:
Suzanne Dupéron 2020-05-25 23:23:37 +00:00
commit d44b5a7af0
24 changed files with 1481 additions and 1179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,7 +22,7 @@ module Ord =
struct struct
type t = AST.variable type t = AST.variable
let compare v1 v2 = let compare v1 v2 =
compare v1.value v2.value String.compare v1.value v2.value
end end
module VarSet = Set.Make (Ord) module VarSet = Set.Make (Ord)

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

@ -23,7 +23,7 @@ module Ord =
struct struct
type t = AST.variable type t = AST.variable
let compare v1 v2 = let compare v1 v2 =
compare v1.value v2.value String.compare v1.value v2.value
end end
module VarSet = Set.Make (Ord) module VarSet = Set.Make (Ord)

3
src/stages/4-ast_typed/.gitignore vendored
View File

@ -1,2 +1,3 @@
/generated_fold.ml /generated_fold.ml
/generated_map.ml
/generated_o.ml

215
src/stages/4-ast_typed/PP_generic.ml
View File

@ -1,116 +1,119 @@
open Types
open Fold open Fold
open Format open Format
open PP_helpers open PP_helpers
let needs_parens = { module M = struct
generic = (fun state info -> type no_state = NoState
match info.node_instance.instance_kind with let needs_parens = {
| RecordInstance _ -> false generic = (fun NoState info ->
| VariantInstance _ -> true match info.node_instance.instance_kind with
| PolyInstance { poly =_; arguments=_; poly_continue } -> | RecordInstance _ -> false
(poly_continue state) | VariantInstance _ -> true
); | PolyInstance { poly =_; arguments=_; poly_continue } ->
type_variable = (fun _ _ _ -> true) ; (poly_continue NoState)
bool = (fun _ _ _ -> false) ; );
int = (fun _ _ _ -> false) ; generic_empty_ctor = (fun _ -> false) ;
z = (fun _ _ _ -> false) ; type_variable = (fun _ _ _ -> true) ;
string = (fun _ _ _ -> false) ; bool = (fun _ _ _ -> false) ;
ligo_string = (fun _ _ _ -> false) ; int = (fun _ _ _ -> false) ;
bytes = (fun _ _ _ -> false) ; z = (fun _ _ _ -> false) ;
unit = (fun _ _ _ -> false) ; string = (fun _ _ _ -> false) ;
packed_internal_operation = (fun _ _ _ -> false) ; ligo_string = (fun _ _ _ -> false) ;
expression_variable = (fun _ _ _ -> false) ; bytes = (fun _ _ _ -> false) ;
constructor' = (fun _ _ _ -> false) ; unit = (fun _ _ _ -> false) ;
location = (fun _ _ _ -> false) ; packed_internal_operation = (fun _ _ _ -> false) ;
label = (fun _ _ _ -> false) ; expression_variable = (fun _ _ _ -> false) ;
ast_core_type_expression = (fun _ _ _ -> true) ; constructor' = (fun _ _ _ -> false) ;
constructor_map = (fun _ _ _ _ -> false) ; location = (fun _ _ _ -> false) ;
label_map = (fun _ _ _ _ -> false) ; label = (fun _ _ _ -> false) ;
list = (fun _ _ _ _ -> false) ; ast_core_type_expression = (fun _ _ _ -> true) ;
location_wrap = (fun _ _ _ _ -> false) ; constructor_map = (fun _ _ _ _ -> false) ;
option = (fun _visitor _continue _state o -> label_map = (fun _ _ _ _ -> false) ;
match o with None -> false | Some _ -> true) ; list = (fun _ _ _ _ -> false) ;
poly_unionfind = (fun _ _ _ _ -> false) ; location_wrap = (fun _ _ _ _ -> false) ;
poly_set = (fun _ _ _ _ -> false) ; option = (fun _visitor _continue _state o ->
typeVariableMap = (fun _ _ _ _ -> false) ; match o with None -> false | Some _ -> true) ;
} poly_unionfind = (fun _ _ _ _ -> false) ;
poly_set = (fun _ _ _ _ -> false) ;
typeVariableMap = (fun _ _ _ _ -> false) ;
}
let op ppf = { let op ppf : (no_state, unit) fold_config = {
generic = (fun () info -> generic = (fun NoState info ->
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | RecordInstance { fields } ->
let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) = let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in 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 fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
| VariantInstance { constructor ; _ } -> | VariantInstance { constructor ; _ } ->
if constructor.cf_new_fold needs_parens false if constructor.cf_new_fold needs_parens NoState
then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () 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 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) () fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState
| PolyInstance { poly=_; arguments=_; poly_continue } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue ()) (poly_continue NoState)
); );
int = (fun _visitor () i -> fprintf ppf "%i" i ); generic_empty_ctor = (fun NoState -> ()) ;
type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; int = (fun _visitor NoState i -> fprintf ppf "%i" i );
bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ; type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ; bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ;
string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ; z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ;
ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ; string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ;
bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ; ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ;
unit = (fun _visitor () () -> fprintf ppf "()") ; bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ;
packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ; unit = (fun _visitor NoState () -> fprintf ppf "()") ;
expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ; packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ;
constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ; expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ;
location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ; constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ; location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ;
ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ;
constructor_map = (fun _visitor continue () cmap -> ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in constructor_map = (fun _visitor continue NoState cmap ->
let aux ppf (Constructor k, v) = let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in let aux ppf (Constructor k, v) =
fprintf ppf "CMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
label_map = (fun _visitor continue () lmap -> fprintf ppf "CMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in label_map = (fun _visitor continue NoState lmap ->
let aux ppf (Label k, v) = let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in let aux ppf (Label k, v) =
fprintf ppf "LMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
list = (fun _visitor continue () lst -> fprintf ppf "LMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
let aux ppf elt = list = (fun _visitor continue NoState lst ->
fprintf ppf "%a" (fun _ppf -> continue ()) elt in let aux ppf elt =
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); fprintf ppf "%a" (fun _ppf -> continue NoState) elt in
location_wrap = (fun _visitor continue () lwrap -> fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
let ({ wrap_content; location } : _ Location.wrap) = lwrap in location_wrap = (fun _visitor continue NoState lwrap ->
fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location); let ({ wrap_content; location } : _ Location.wrap) = lwrap in
(* list_ne = (fun _visitor continue () (first, lst) -> fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location);
let aux ppf elt = option = (fun _visitor continue NoState o ->
fprintf ppf "%a" (fun _ppf -> continue ()) elt in match o with
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *) | None -> fprintf ppf "None"
option = (fun _visitor continue () o -> | Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ;
match o with poly_unionfind = (fun _visitor continue NoState p ->
| None -> fprintf ppf "None" let lst = (UnionFind.Poly2.partitions p) in
| Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ; let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]"
poly_unionfind = (fun _visitor continue () p -> (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p)
let lst = (UnionFind.Poly2.partitions p) in (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in
let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]" let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
(fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p) fprintf ppf "UnionFind [@,@[<hv 2> %a @]@,]" aux2 lst);
(list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in poly_set = (fun _visitor continue NoState set ->
let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in let lst = (RedBlackTrees.PolySet.elements set) in
fprintf ppf "UnionFind [@,@[<hv 2> %a @]@,]" aux2 lst); fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst);
poly_set = (fun _visitor continue () set -> typeVariableMap = (fun _visitor continue NoState tvmap ->
let lst = (RedBlackTrees.PolySet.elements set) in let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst); let aux ppf (k, v) =
typeVariableMap = (fun _visitor continue () tvmap -> fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in
let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in fprintf ppf "typeVariableMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
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 print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
fold (op ppf) () v fold (op ppf) NoState v
end
include Fold.Folds(struct include Fold.Folds(struct
type state = unit ;; type in_state = M.no_state ;;
type out_state = unit ;;
type 'a t = formatter -> 'a -> unit ;; type 'a t = formatter -> 'a -> unit ;;
let f = print ;; let f = M.print ;;
end) end)

622
src/stages/4-ast_typed/ast.ml Normal file
View 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
View File

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

196
src/stages/4-ast_typed/compare_generic.ml Normal file
View 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

7
src/stages/4-ast_typed/dune
View File

@ -1,7 +1,7 @@
(rule (rule
(target generated_fold.ml) (targets generated_fold.ml generated_map.ml generated_o.ml)
(deps ../adt_generator/generator.raku types.ml) (deps ../adt_generator/generator.raku ast.ml)
(action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.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 *))) (mode (promote (until-clean) (only *)))
) )
@ -19,5 +19,6 @@
(preprocess (preprocess
(pps ppx_let bisect_ppx --conditional) (pps ppx_let bisect_ppx --conditional)
) )
;; (modules_without_implementation generated_fold_x)
(flags (:standard -open Simple_utils)) (flags (:standard -open Simple_utils))
) )

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

@ -1 +1,3 @@
include Generated_fold include Generated_fold
include Generated_map
include Generated_o

618
src/stages/4-ast_typed/types.ml
View File

@ -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 include Types_utils
include Ast
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 ;
}

17
src/stages/4-ast_typed/types_utils.ml
View File

@ -32,6 +32,10 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe
type location = Location.t type location = Location.t
type inline = bool 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 = 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 -> fun f state m ->
let aux k v acc = 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 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 = 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 f state l -> fun extra_info f state l ->
ignore (f, state, l) ; failwith "TODO ignore (extra_info, f, state, l) ; failwith "TODO
let aux acc element = let aux acc element =
let%bind state , l = acc in let%bind state , l = acc in
let%bind (state , new_element) = f state element in ok (state , new_element :: l) 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 = 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 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 = 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 f state s -> fun extra_info 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 new_compare : (new_a -> new_a -> int) = extra_info.compare in
let aux elt ~acc = let aux elt ~acc =
let%bind (state , s) = acc in let%bind (state , s) = acc in
let%bind (state , new_elt) = f state elt in let%bind (state , new_elt) = f state elt in
ok (state , PolySet.add new_elt s) 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 let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in
ok (state , m) ok (state , m)

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

@ -8,17 +8,27 @@ use worries;
# TODO: shorthand for `foo list` etc. in field and constructor types # TODO: shorthand for `foo list` etc. in field and constructor types
# TODO: error when reserved names are used ("state", … please list them here) # 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 $variant = "_ _variant";
my $record = "_ _ record"; my $record = "_ _ record";
sub poly { $^type_name } sub poly { $^type_name }
my $l = @*ARGS[0].IO.lines; my $l = $inputADTfile.IO.lines;
$l = $l.map(*.subst: /(^\s+|\s+$)/, ""); $l = $l.map(*.subst: /(^\s+|\s+$)/, "");
$l = $l.list.cache; $l = $l.list.cache;
my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/; my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/;
my $statements = $l.grep($statement_re); my $statements = $l.grep($statement_re);
$l = $l.grep(none $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+\*\)$/, '')); $statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, ''));
$l = $l.cache.map(*.subst: /^type\s+/, "\nand "); $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. # 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 , "kind" => $kind ,
"ctorsOrFields" => $ctorsOrFields "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) { my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
{ {
"name" => $name , "name" => $name ,
"newName" => "{$name}__'" , "oNewName" => "O.{$name}", # ($kind ne $record && $kind ne $variant) ?? "$name" !! "O.{$name}",
"newName" => $name ,
"kind" => $kind , "kind" => $kind ,
"ctorsOrFields" => @(map -> ($cf, $type) { "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 , name => $cf ,
newName => "{$cf}__'" , oNewName => "O.{$cf}" ,
newName => $cf ,
isBuiltin => $isBuiltin , isBuiltin => $isBuiltin ,
type => $type , type => $type ,
newType => $isBuiltin ?? "$type" !! "{$type}__'" oNewType => $isBuiltin ?? "$type" !! "O.{$type}" ,
newType => $type ,
} }
}, @ctorsOrFields), }, @ctorsOrFields),
} }
}, @$l.cache).list; }, @$l.cache).list;
# say $adts.perl;
# say $adts.perl ; # Auto-generated fold functions
$*OUT = open $folder_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 "(* 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
{ {
say "let no_op_node__$t<name> : type state . state -> $t<name> -> (state,_) _continue_fold_map__$moduleName -> (state * $t<newName>,_) monad ="; say "(* This is an auto-generated file. Do not edit. *)";
say " fun state v continue ->"; # (*_info*) say "";
say " match v with"; for $statements -> $statement { say "$statement" }
if ($t<kind> eq $variant) { say "open $moduleName;;";
for $t<ctorsOrFields>.list -> $c
{ given $c<type> { say "";
when '' { say " | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , $c<newName>)"; } say " include Adt_generator.Generic.BlahBluh";
default { say " | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , $c<newName> v)"; } } } say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
} elsif ($t<kind> eq $record) { say " generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;";
print ' { '; say " generic_empty_ctor : 'in_state -> 'out_state;";
for $t<ctorsOrFields>.list -> $f # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
{ print "$f<name>; "; } for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
say "} ->"; { say " $builtin : ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> 'in_state -> $builtin -> 'out_state;"; }
for $t<ctorsOrFields>.list -> $f # look for built-in polymorphic types
{ say " continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; } for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
print ' return (state , ({ '; { 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;"; }
for $t<ctorsOrFields>.list -> $f say ' };;';
{ print "$f<newName>; "; }
say "\} : $t<newName>))"; say "";
} else { say " module Adt_info = Adt_generator.Generic.Adt_info (struct";
print " v -> fold_map__$t<kind> ( "; 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;;";
print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", "); say " end);;";
say " ) state v;;"; 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 # auto-generated fold_map functions
{ say "let no_op__$t<name> : type state . (state,_) fold_map_config__$t<name> = \{"; $*OUT = open $mapper_filename, :w;
say " node__$t<name> = no_op_node__$t<name>;"; {
say " node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*) say "(* This is an auto-generated file. Do not edit. *)";
say " node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*) say "";
for $t<ctorsOrFields>.list -> $c for $statements -> $statement { say "$statement" }
{ print " $t<name>__$c<name> = (fun state v continue -> "; # (*_info*) say "open Adt_generator.Common;;";
if ($c<isBuiltin>) { say "open $moduleName;;";
print "ignore continue; return (state , v)";
} else { say "";
print "continue.$c<type>.node__$c<type> state v"; 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 {
for $adts.list -> $t if ($t<kind> eq $variant) {
{ say " $t<name> = no_op__$t<name>;" } for $t<ctorsOrFields>.list -> $c {
say '};;'; 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 ""; say "";
for $adts.list -> $t for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $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> \} \});;"; { my $ty = $t<ctorsOrFields>[0]<type>;
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 \} \});;"; my $typeclass = $typeclasses{$t<kind>};
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 \} \});;"; say " val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; }
for $t<ctorsOrFields>.list -> $c say "end";
{ 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 ""; say "";
say "module Folds (M : sig type state type 'a t val f : (state fold_config -> state -> 'a -> state) -> 'a t end) = struct"; 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";
for $adts.list -> $t say " module O : OSig = $oModuleName";
{ say "let $t<name> = M.f fold__$t<name>;;"; } say "";
say "end"; 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;;";
}

56
src/stages/adt_generator/generic.ml
View File

@ -1,44 +1,44 @@
module BlahBluh = struct module BlahBluh = struct
module StringMap = Map.Make(String);; module StringMap = Map.Make(String);;
(* generic folds for nodes *) (* generic folds for nodes *)
type 'state generic_continue_fold_node = { type 'state generic_continue_fold_node = {
continue : 'state -> 'state ; continue : 'state -> 'state ;
(* generic folds for each field *) (* generic folds for each field *)
continue_ctors_or_fields : ('state -> 'state) StringMap.t ; continue_ctors_or_fields : ('state -> 'state) StringMap.t ;
};; };;
(* map from node names to their generic folds *) (* map from node names to their generic folds *)
type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;; type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
end 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 = type kind =
| Record | Record
| Variant | Variant
| Poly of string | Poly of string
type 'state record_instance = { type ('in_state , 'out_state) record_instance = {
fields : 'state ctor_or_field_instance list; fields : ('in_state , 'out_state) ctor_or_field_instance list;
} }
and 'state constructor_instance = { and ('in_state , 'out_state) constructor_instance = {
constructor : 'state ctor_or_field_instance ; constructor : ('in_state , 'out_state) ctor_or_field_instance ;
variant : ctor_or_field list variant : ctor_or_field list
} }
and 'state poly_instance = { and ('in_state , 'out_state) poly_instance = {
poly : string; poly : string;
arguments : string list; arguments : string list;
poly_continue : 'state -> 'state poly_continue : 'in_state -> 'out_state
} }
and 'state kind_instance = and ('in_state , 'out_state) kind_instance =
| RecordInstance of 'state record_instance | RecordInstance of ('in_state , 'out_state) record_instance
| VariantInstance of 'state constructor_instance | VariantInstance of ('in_state , 'out_state) constructor_instance
| PolyInstance of 'state poly_instance | PolyInstance of ('in_state , 'out_state) poly_instance
and 'state instance = { and ('in_state , 'out_state) instance = {
instance_declaration_name : string; instance_declaration_name : string;
instance_kind : 'state kind_instance; instance_kind : ('in_state , 'out_state) kind_instance;
} }
and ctor_or_field = and ctor_or_field =
@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
type_ : string; type_ : string;
} }
and 'state ctor_or_field_instance = and ('in_state , 'out_state) ctor_or_field_instance =
{ {
cf : ctor_or_field; cf : ctor_or_field;
cf_continue : 'state -> 'state; cf_continue : 'in_state -> 'out_state;
cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> '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 = 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. *) (* TODO: rename things a bit in this file. *)
and adt = node list and adt = node list
and 'state node_instance_info = { and ('in_state , 'out_state) node_instance_info = {
adt : adt ; 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 end

2
src/test/adt_generator/.gitignore vendored
View File

@ -1 +1,3 @@
/generated_fold.ml /generated_fold.ml
/generated_map.ml
/generated_o.ml

1
src/test/adt_generator/amodule.ml
View File

@ -1,3 +1,4 @@
[@@@warning "-33"]
(* open Amodule_utils *) (* open Amodule_utils *)
type root = type root =

4
src/test/adt_generator/dune
View File

@ -1,7 +1,7 @@
(rule (rule
(target generated_fold.ml) (targets generated_fold.ml generated_map.ml generated_o.ml)
(deps ../../../src/stages/adt_generator/generator.raku amodule.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 *))) (mode (promote (until-clean) (only *)))
) )

1
src/test/adt_generator/fold.ml
View File

@ -1 +1,2 @@
include Generated_fold include Generated_fold
include Generated_map.Mapper

36
src/test/adt_generator/use_a_fold.ml
View File

@ -2,6 +2,8 @@ open Amodule
open Fold open Fold
open Simple_utils.Trace open Simple_utils.Trace
module O = Fold.O
let (|>) v f = f v let (|>) v f = f v
module Errors = struct module Errors = struct
@ -22,9 +24,9 @@ let () =
let op = let op =
no_op |> no_op |>
with__a (fun state the_a (*_info*) continue_fold -> 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, 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 let%bind state, a2 = continue_fold.ta2.node__ta2 state the_a.a2 in
ok (state + 1, { a1__' ; a2__' })) ok (state + 1, (O.make__a ~a1 ~a2 : O.a)))
in in
let state = 0 in let state = 0 in
let%bind (state , _) = fold_map__root op state some_root 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 _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
let _nob : (bool, [> 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 () =
let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in 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 op : ('i, 'o) Generated_fold.fold_config = {
let nostate = false, "" in generic = (fun NoState info ->
let op = {
generic = (fun state info ->
assert_nostate state;
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | 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=_ } -> | 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 ^ ")" | true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg) | false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate) (poly_continue NoState)
) ; ) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ; generic_empty_ctor = (fun NoState -> false, "") ;
unit = (fun _visitor state () -> assert_nostate state; false , "()") ; string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ; unit = (fun _visitor NoState () -> false , "()") ;
list = (fun _visitor continue state lst -> int = (fun _visitor NoState i -> false , string_of_int i) ;
assert_nostate state; list = (fun _visitor continue NoState lst ->
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ; false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ;
(* generic_ctor_or_field = (fun _info state -> (* generic_ctor_or_field = (fun _info state ->
* match _info () with * match _info () with
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
* ); *) * ); *)
} in } 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 let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
if String.equal state expected; then if String.equal state expected; then
() ()

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

@ -17,6 +17,12 @@ let pp = fun ppf t ->
| Virtual s -> Format.fprintf ppf "%s" s | Virtual s -> Format.fprintf ppf "%s" s
| File f -> Format.fprintf ppf "%s" (f#to_string `Point) | 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 = let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
(* TODO: give correct unicode offsets (the random number is here so (* TODO: give correct unicode offsets (the random number is here so
@ -35,6 +41,11 @@ type 'a wrap = {
location : t ; 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 wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc }
let get_location x = x.location let get_location x = x.location
let unwrap { wrap_content ; _ } = wrap_content let unwrap { wrap_content ; _ } = wrap_content

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

@ -136,6 +136,11 @@ let lt r1 r2 =
&& Pos.lt r1#start r2#start && Pos.lt r1#start r2#start
&& Pos.lt r1#stop r2#stop && 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 = let cover r1 r2 =
if r1#is_ghost if r1#is_ghost
then r2 then r2

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

@ -135,6 +135,11 @@ val equal : t -> t -> bool
[r2]. (See {! Pos.lt}.) *) [r2]. (See {! Pos.lt}.) *)
val lt : t -> t -> bool 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 (** 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 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 r1 r2) (cover r2 r1)]. (In a sense, it is the maximum region, but

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

@ -178,6 +178,17 @@ let rec assoc_opt ?compare:cmp x =
[] -> None [] -> None
| (a,b)::l -> if compare a x = 0 then Some b else assoc_opt ~compare x l | (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 module Ne = struct

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

@ -6,6 +6,12 @@ let pp ppf = function
Standard s -> Format.fprintf ppf "%S" s Standard s -> Format.fprintf ppf "%S" s
| Verbatim v -> Format.fprintf ppf "{|%s|}" v | 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 let extract = function
Standard s -> s Standard s -> s
| Verbatim v -> v | Verbatim v -> v

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

@ -7,5 +7,6 @@ type t =
Standard of string Standard of string
| Verbatim of string | Verbatim of string
val compare : ?compare:(string->string->int) -> t -> t -> int
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
val extract : t -> string val extract : t -> string