diff --git a/engine/backends/coq/coq/coq_backend.ml b/engine/backends/coq/coq/coq_backend.ml index 34338363f..c2fd77fe9 100644 --- a/engine/backends/coq/coq/coq_backend.ml +++ b/engine/backends/coq/coq/coq_backend.ml @@ -215,16 +215,16 @@ struct C.AST.Ident var.name | POr { subpats } -> C.AST.DisjunctivePat (List.map ~f:ppat subpats) | PArray _ -> __TODO_pat__ p.span "Parray?" - | PConstruct { name = `TupleCons 0; args = []; _ } -> C.AST.UnitPat - | PConstruct { name = `TupleCons 1; args = [ _ ]; _ } -> + | PConstruct { constructor = `TupleCons 0; fields = []; _ } -> C.AST.UnitPat + | PConstruct { constructor = `TupleCons 1; fields = [ _ ]; _ } -> __TODO_pat__ p.span "tuple 1" - | PConstruct { name = `TupleCons _n; args; _ } -> - C.AST.TuplePat (List.map ~f:(fun { pat; _ } -> ppat pat) args) - | PConstruct { name; args; is_record = true; _ } -> - C.AST.RecordPat (pglobal_ident name, pfield_pats args) - | PConstruct { name; args; is_record = false; _ } -> + | PConstruct { constructor = `TupleCons _n; fields; _ } -> + C.AST.TuplePat (List.map ~f:(fun { pat; _ } -> ppat pat) fields) + | PConstruct { constructor; fields; is_record = true; _ } -> + C.AST.RecordPat (pglobal_ident constructor, pfield_pats fields) + | PConstruct { constructor; fields; is_record = false; _ } -> C.AST.ConstructorPat - (pglobal_ident name, List.map ~f:(fun p -> ppat p.pat) args) + (pglobal_ident constructor, List.map ~f:(fun p -> ppat p.pat) fields) | PConstant { lit } -> C.AST.Lit (pliteral p.span lit) | _ -> . @@ -582,7 +582,7 @@ struct | Impl { generics; self_ty; of_trait = name, gen_vals; items } -> [ C.AST.Instance - ( pglobal_ident name, + ( pconcrete_ident name, List.map ~f:(pgeneric_param_as_argument span) generics.params, pty span self_ty, args_ty span gen_vals, @@ -694,6 +694,7 @@ let translate _ (_bo : BackendOptions.t) ~(bundles : AST.item list list) path = mod_name ^ ".v"; contents = hardcoded_coq_headers ^ "\n" ^ string_of_items items ^ "\n"; + sourcemap = None; }) open Phase_utils diff --git a/engine/backends/coq/ssprove/ssprove_backend.ml b/engine/backends/coq/ssprove/ssprove_backend.ml index 6db7387c9..bdae541d6 100644 --- a/engine/backends/coq/ssprove/ssprove_backend.ml +++ b/engine/backends/coq/ssprove/ssprove_backend.ml @@ -792,25 +792,26 @@ struct SSP.AST.Ident (plocal_ident var) (* TODO Mutable binding ! *) | POr { subpats } -> SSP.AST.DisjunctivePat (List.map ~f:ppat subpats) | PArray _ -> __TODO_pat__ p.span "Parray?" - | PConstruct { name = `TupleCons 0; args = []; _ } -> + | PConstruct { constructor = `TupleCons 0; fields = []; _ } -> SSP.AST.WildPat (* UnitPat *) - | PConstruct { name = `TupleCons 1; args = [ _ ]; _ } -> + | PConstruct { constructor = `TupleCons 1; fields = [ _ ]; _ } -> __TODO_pat__ p.span "tuple 1" - | PConstruct { name = `TupleCons _n; args; _ } -> - SSP.AST.TuplePat (List.map ~f:(fun { pat; _ } -> ppat pat) args) + | PConstruct { constructor = `TupleCons _n; fields; _ } -> + SSP.AST.TuplePat (List.map ~f:(fun { pat; _ } -> ppat pat) fields) (* Record *) | PConstruct { is_record = true; _ } -> __TODO_pat__ p.span "record pattern" - (* (\* SSP.AST.Ident (pglobal_ident name) *\) *) - (* SSP.AST.RecordPat (pglobal_ident name, List.map ~f:(fun {field; pat} -> (pglobal_ident field, ppat pat)) args) *) - (* (\* SSP.AST.ConstructorPat (pglobal_ident name ^ "_case", [SSP.AST.Ident "temp"]) *\) *) - (* (\* List.map ~f:(fun {field; pat} -> (pat, SSP.AST.App (SSP.AST.Var (pglobal_ident field), [SSP.AST.Var "temp"]))) args *\) *) + (* (\* SSP.AST.Ident (pglobal_ident constructor) *\) *) + (* SSP.AST.RecordPat (pglobal_ident constructor, List.map ~f:(fun {field; pat} -> (pglobal_ident field, ppat pat)) fields) *) + (* (\* SSP.AST.ConstructorPat (pglobal_ident constructor ^ "_case", [SSP.AST.Ident "temp"]) *\) *) + (* (\* List.map ~f:(fun {field; pat} -> (pat, SSP.AST.App (SSP.AST.Var (pglobal_ident field), [SSP.AST.Var "temp"]))) fields *\) *) (* Enum *) - | PConstruct { name; args; is_record = false; _ } -> + | PConstruct { constructor; fields; is_record = false; _ } -> SSP.AST.ConstructorPat - ( pglobal_ident name, - match args with + ( pglobal_ident constructor, + match fields with | [] -> [] - | _ -> [ SSP.AST.TuplePat (List.map ~f:(fun p -> ppat p.pat) args) ] + | _ -> + [ SSP.AST.TuplePat (List.map ~f:(fun p -> ppat p.pat) fields) ] ) | PConstant { lit } -> SSP.AST.Lit (pliteral lit) | _ -> . @@ -959,7 +960,7 @@ struct p = PConstruct { - args = [ { pat; _ } ]; + fields = [ { pat; _ } ]; is_record = false; is_struct = true; _; @@ -990,16 +991,21 @@ struct ~f:(fun { arm = { arm_pat; body }; _ } -> match arm_pat.p with | PConstruct - { name; args; is_record = false; is_struct = false } -> ( + { + constructor; + fields; + is_record = false; + is_struct = false; + } -> ( let arg_tuple = SSP.AST.TuplePat - (List.map ~f:(fun p -> ppat p.pat) args) + (List.map ~f:(fun p -> ppat p.pat) fields) in ( SSP.AST.ConstructorPat - ( pglobal_ident name ^ "_case", - match args with [] -> [] | _ -> [ arg_tuple ] ), + ( pglobal_ident constructor ^ "_case", + match fields with [] -> [] | _ -> [ arg_tuple ] ), match - (args, SSPExtraDefinitions.pat_as_expr arg_tuple) + (fields, SSPExtraDefinitions.pat_as_expr arg_tuple) with | _ :: _, Some (redefine_pat, redefine_expr) -> SSPExtraDefinitions.letb @@ -1016,14 +1022,14 @@ struct (List.map ~f:(fun x -> pty arm_pat.span x.pat.typ) - args) ); + fields) ); ] ); body = (pexpr env true) body; value_typ = SSP.AST.Product (List.map ~f:(fun x -> pty arm_pat.span x.pat.typ) - args); + fields); monad_typ = None; } | _, _ -> (pexpr env true) body )) @@ -1103,8 +1109,8 @@ struct p = PConstruct { - name = `TupleCons 0; - args = []; + constructor = `TupleCons 0; + fields = []; is_record = false; is_struct = false; }; @@ -1299,9 +1305,9 @@ struct match pat.p with | PWild -> false | PAscription { pat; _ } -> is_mutable_pat pat - | PConstruct { name = `TupleCons _; args; _ } -> + | PConstruct { constructor = `TupleCons _; fields; _ } -> List.fold ~init:false ~f:( || ) - (List.map ~f:(fun p -> is_mutable_pat p.pat) args) + (List.map ~f:(fun p -> is_mutable_pat p.pat) fields) | PConstruct _ -> false | PArray _ -> (* List.fold ~init:false ~f:(||) (List.map ~f:(fun p -> is_mutable_pat p) args) *) @@ -1793,7 +1799,7 @@ struct items @ [ SSP.AST.ProgramInstance - ( pglobal_ident name, + ( pconcrete_ident name, pgeneric span generics, pty span self_ty, args_ty span gen_vals, @@ -1859,7 +1865,9 @@ struct ]) items) ); ] - @ [ SSP.AST.HintUnfold (pglobal_ident name, Some (pty span self_ty)) ] + @ [ + SSP.AST.HintUnfold (pconcrete_ident name, Some (pty span self_ty)); + ] in decls_from_item @@ -2422,7 +2430,8 @@ let translate _ (_bo : BackendOptions.t) ~(bundles : AST.item list list) ^ "\n" in - Types.{ path = mod_name ^ ".v"; contents = file_content }) + Types. + { path = mod_name ^ ".v"; contents = file_content; sourcemap = None }) let apply_phases (_bo : BackendOptions.t) (i : Ast.Rust.item list) : AST.item list = diff --git a/engine/backends/fstar/fstar_backend.ml b/engine/backends/fstar/fstar_backend.ml index 2ae37c6dd..0ee9c0e93 100644 --- a/engine/backends/fstar/fstar_backend.ml +++ b/engine/backends/fstar/fstar_backend.ml @@ -409,23 +409,26 @@ struct "Nested disjuntive patterns should have been eliminated by phase \ `HoistDisjunctions` (see PR #830)." | PArray { args } -> F.pat @@ F.AST.PatList (List.map ~f:ppat args) - | PConstruct { name = `TupleCons 0; args = [] } -> + | PConstruct { constructor = `TupleCons 0; fields = [] } -> F.pat @@ F.AST.PatConst F.Const.Const_unit - | PConstruct { name = `TupleCons 1; args = [ { pat } ] } -> ppat pat - | PConstruct { name = `TupleCons n; args } -> + | PConstruct { constructor = `TupleCons 1; fields = [ { pat } ] } -> + ppat pat + | PConstruct { constructor = `TupleCons n; fields } -> F.pat - @@ F.AST.PatTuple (List.map ~f:(fun { pat } -> ppat pat) args, false) - | PConstruct { name; args; is_record; is_struct } -> + @@ F.AST.PatTuple (List.map ~f:(fun { pat } -> ppat pat) fields, false) + | PConstruct { constructor; fields; is_record; is_struct } -> let pat_rec () = - F.pat @@ F.AST.PatRecord (List.map ~f:pfield_pat args) + F.pat @@ F.AST.PatRecord (List.map ~f:pfield_pat fields) in if is_struct && is_record then pat_rec () else - let pat_name = F.pat @@ F.AST.PatName (pglobal_ident p.span name) in + let pat_name = + F.pat @@ F.AST.PatName (pglobal_ident p.span constructor) + in F.pat_app pat_name @@ if is_record then [ pat_rec () ] - else List.map ~f:(fun { field; pat } -> ppat pat) args + else List.map ~f:(fun { field; pat } -> ppat pat) fields | PConstant { lit } -> F.pat @@ F.AST.PatConst (pliteral p.span lit) | _ -> . @@ -1416,7 +1419,7 @@ struct in let typ = F.mk_e_app - (F.term @@ F.AST.Name (pglobal_ident e.span trait)) + (F.term @@ F.AST.Name (pconcrete_ident trait)) (List.map ~f:(pgeneric_value e.span) generic_args) in let pat = F.pat @@ F.AST.PatAscribed (pat, (typ, None)) in @@ -1678,7 +1681,8 @@ let fstar_headers (bo : BackendOptions.t) = in [ opts; "open Core"; "open FStar.Mul" ] |> String.concat ~sep:"\n" -let translate m (bo : BackendOptions.t) ~(bundles : AST.item list list) +(** Translate as F* (the "legacy" printer) *) +let translate_as_fstar m (bo : BackendOptions.t) ~(bundles : AST.item list list) (items : AST.item list) : Types.file list = let show_view Concrete_ident.{ crate; path; definition } = crate :: (path @ [ definition ]) |> String.concat ~sep:"::" @@ -1710,11 +1714,19 @@ let translate m (bo : BackendOptions.t) ~(bundles : AST.item list list) contents = "module " ^ mod_name ^ "\n" ^ fstar_headers bo ^ "\n\n" ^ body ^ "\n"; + sourcemap = None; } in List.filter_map ~f:Fn.id [ make ~ext:"fst" impl; make ~ext:"fsti" intf ]) +let translate = + if + Sys.getenv "HAX_ENGINE_EXPERIMENTAL_RUST_PRINTER_INSTEAD_OF_FSTAR" + |> Option.is_some + then failwith "todo" + else translate_as_fstar + open Phase_utils module DepGraphR = Dependencies.Make (Features.Rust) diff --git a/engine/backends/proverif/proverif_backend.ml b/engine/backends/proverif/proverif_backend.ml index f66a1ea14..a69aee227 100644 --- a/engine/backends/proverif/proverif_backend.ml +++ b/engine/backends/proverif/proverif_backend.ml @@ -142,9 +142,9 @@ end module Make (Options : OPTS) : MAKE = struct module Print = struct module GenericPrint = - Generic_printer.Make (InputLanguage) (U.Concrete_ident_view) + Deprecated_generic_printer.Make (InputLanguage) (U.Concrete_ident_view) - open Generic_printer_base.Make (InputLanguage) + open Deprecated_generic_printer_base.Make (InputLanguage) open PPrint let iblock f = group >> jump 2 0 >> terminate (break 0) >> f >> group @@ -242,8 +242,8 @@ module Make (Options : OPTS) : MAKE = struct let body = print#expr_at Arm_body body in match arm_pat with | { p = PWild; _ } -> body - | { p = PConstruct { name; _ } } - when Global_ident.eq_name Core__result__Result__Err name -> + | { p = PConstruct { constructor; _ } } + when Global_ident.eq_name Core__result__Result__Err constructor -> print#pv_letfun_call (print#error_letfun_name body_typ) [] | _ -> let pat = @@ -264,7 +264,8 @@ module Make (Options : OPTS) : MAKE = struct method typed_wildcard = print#wildcard ^^ string ": bitstring" - method tuple_elem_pat' : Generic_printer_base.par_state -> pat' fn = + method tuple_elem_pat' + : Deprecated_generic_printer_base.par_state -> pat' fn = fun ctx -> let wrap_parens = group @@ -277,14 +278,15 @@ module Make (Options : OPTS) : MAKE = struct p ^^ colon ^^ space ^^ print#ty ctx typ | p -> print#pat' ctx p - method tuple_elem_pat : Generic_printer_base.par_state -> pat fn = + method tuple_elem_pat + : Deprecated_generic_printer_base.par_state -> pat fn = fun ctx { p; span; _ } -> print#with_span ~span (fun _ -> print#tuple_elem_pat' ctx p) method tuple_elem_pat_at = print#par_state >> print#tuple_elem_pat (* Overridden methods *) - method! pat' : Generic_printer_base.par_state -> pat' fn = + method! pat' : Deprecated_generic_printer_base.par_state -> pat' fn = fun ctx -> let wrap_parens = group @@ -294,16 +296,18 @@ module Make (Options : OPTS) : MAKE = struct fun pat -> match pat with | PConstant { lit } -> string "=" ^^ print#literal Pat lit - | PConstruct { name; args } - when Global_ident.eq_name Core__option__Option__None name -> + | PConstruct { constructor; fields } + when Global_ident.eq_name Core__option__Option__None constructor + -> string "None()" - | PConstruct { name; args } + | PConstruct { constructor; fields } (* The `Some` constructor in ProVerif expects a bitstring argument, so we use the appropriate `_to_bitstring` type converter on the inner expression. *) - when Global_ident.eq_name Core__option__Option__Some name -> - let inner_field = List.hd_exn args in + when Global_ident.eq_name Core__option__Option__Some constructor + -> + let inner_field = List.hd_exn fields in let inner_field_type_doc = print#ty AlreadyPar inner_field.pat.typ in @@ -320,21 +324,23 @@ module Make (Options : OPTS) : MAKE = struct ^^ iblock parens inner_field_doc) in string "Some" ^^ inner_block - | PConstruct { name; args } + | PConstruct { constructor; fields } (* We replace applications of the `Ok` constructor with their contents. *) - when Global_ident.eq_name Core__result__Result__Ok name -> - let inner_field = List.hd_exn args in + when Global_ident.eq_name Core__result__Result__Ok constructor + -> + let inner_field = List.hd_exn fields in let inner_field_type_doc = print#ty AlreadyPar inner_field.pat.typ in let inner_field_doc = print#pat ctx inner_field.pat in inner_field_doc - | PConstruct { name; args } -> ( + | PConstruct { constructor; fields } -> ( match - translate_known_name name ~dict:library_constructor_patterns + translate_known_name constructor + ~dict:library_constructor_patterns with - | Some (_, translation) -> translation args + | Some (_, translation) -> translation fields | None -> super#pat' ctx pat) | PWild -> print#typed_wildcard @@ -344,7 +350,8 @@ module Make (Options : OPTS) : MAKE = struct method! ty_bool = string "bool" method! ty_int _ = string "nat" - method! pat_at : Generic_printer_base.ast_position -> pat fn = + method! pat_at : Deprecated_generic_printer_base.ast_position -> pat fn + = fun pos pat -> match pat with | { p = PWild } -> ( @@ -374,7 +381,7 @@ module Make (Options : OPTS) : MAKE = struct in f ^^ iblock parens args - method! expr' : Generic_printer_base.par_state -> expr' fn = + method! expr' : Deprecated_generic_printer_base.par_state -> expr' fn = fun ctx e -> let wrap_parens = group @@ -720,7 +727,7 @@ module Make (Options : OPTS) : MAKE = struct | _ -> super#expr ctx e (*This cannot happen*)) | _ -> super#expr ctx e) - method! ty : Generic_printer_base.par_state -> ty fn = + method! ty : Deprecated_generic_printer_base.par_state -> ty fn = fun ctx ty -> match ty with | TBool -> print#ty_bool @@ -877,9 +884,12 @@ let translate m (bo : BackendOptions.t) ~(bundles : AST.item list list) ^ M.Processes.print items in let analysis_contents = M.Toplevel.print items in - let lib_file = Types.{ path = "lib.pvl"; contents = lib_contents } in + let lib_file = + Types.{ path = "lib.pvl"; contents = lib_contents; sourcemap = None } + in let analysis_file = - Types.{ path = "analysis.pv"; contents = analysis_contents } + Types. + { path = "analysis.pv"; contents = analysis_contents; sourcemap = None } in [ lib_file; analysis_file ] diff --git a/engine/lib/ast.ml b/engine/lib/ast.ml index 684001400..672080ebf 100644 --- a/engine/lib/ast.ml +++ b/engine/lib/ast.ml @@ -196,10 +196,10 @@ functor | PWild | PAscription of { typ : ty; typ_span : span; pat : pat } | PConstruct of { - name : global_ident; - args : field_pat list; + constructor : global_ident; is_record : bool; (* are fields named? *) is_struct : bool; (* a struct has one constructor *) + fields : field_pat list; } (* An or-pattern, e.g. `p | q`. Invariant: `List.length subpats >= 2`. *) @@ -273,7 +273,7 @@ functor coercion is applied on the (potential) error payload of `e`. Coercion should be made explicit within `e`. *) | Continue of { - e : (F.state_passing_loop * expr) option; + e : (expr * F.state_passing_loop) option; label : string option; witness : F.continue * F.loop; } @@ -421,7 +421,7 @@ functor | Impl of { generics : generics; self_ty : ty; - of_trait : global_ident * generic_value list; + of_trait : concrete_ident * generic_value list; items : impl_item list; parent_bounds : (impl_expr * impl_ident) list; safety : safety_kind; diff --git a/engine/lib/ast_utils.ml b/engine/lib/ast_utils.ml index d8e072ac6..db6163882 100644 --- a/engine/lib/ast_utils.ml +++ b/engine/lib/ast_utils.ml @@ -707,7 +707,7 @@ module Make (F : Features.T) = struct (* TODO: Those tuple1 things are wrong! Tuples of size one exists in Rust! e.g. `(123,)` *) let rec remove_tuple1_pat (p : pat) : pat = match p.p with - | PConstruct { name = `TupleType 1; args = [ { pat; _ } ]; _ } -> + | PConstruct { constructor = `TupleType 1; fields = [ { pat; _ } ]; _ } -> remove_tuple1_pat pat | _ -> p @@ -748,7 +748,7 @@ module Make (F : Features.T) = struct pat_is_expr p e | PBinding { subpat = None; var = pv; _ }, LocalVar ev -> [%eq: local_ident] pv ev - | ( PConstruct { name = pn; args = pargs; _ }, + | ( PConstruct { constructor = pn; fields = pargs; _ }, Construct { constructor = en; fields = eargs; base = None; _ } ) when [%eq: global_ident] pn en -> ( match List.zip pargs eargs with @@ -824,10 +824,10 @@ module Make (F : Features.T) = struct p = PConstruct { - name = `TupleCons len; - args = tuple; + constructor = `TupleCons len; is_record = false; is_struct = true; + fields = tuple; }; typ = make_tuple_typ @@ List.map ~f:(fun { pat; _ } -> pat.typ) tuple; span; diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index b926388d1..a4952b4eb 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -71,7 +71,7 @@ module Make (F : Features.T) = struct -> v#visit_generics () generics @ v#visit_ty () self_ty - @ v#visit_global_ident () (fst of_trait) + @ v#visit_concrete_ident () (fst of_trait) @ concat_map (v#visit_generic_value ()) (snd of_trait) @ concat_map (v#visit_impl_item ()) items @ concat_map diff --git a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml new file mode 100644 index 000000000..5cd219b4a --- /dev/null +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml @@ -0,0 +1,463 @@ +open! Prelude +open! Ast + +module Make (F : Features.T) (View : Concrete_ident.VIEW_API) = struct + open Deprecated_generic_printer_base + open Deprecated_generic_printer_base.Make (F) + + module Class = struct + module U = Ast_utils.Make (F) + open! AST + open PPrint + + let iblock f = group >> jump 2 0 >> terminate (break 0) >> f >> group + + class print = + object (print) + inherit print_base as super + method printer_name = "Generic" + + method par_state : ast_position -> par_state = + function + | Lhs_LhsArrayAccessor | Ty_Tuple | Ty_TSlice | Ty_TArray_length + | Expr_If_cond | Expr_If_then | Expr_If_else | Expr_Array + | Expr_Assign | Expr_Closure_param | Expr_Closure_body + | Expr_Ascription_e | Expr_Let_lhs | Expr_Let_rhs | Expr_Let_body + | Expr_App_arg | Expr_ConstructTuple | Pat_ConstructTuple | Pat_PArray + | Pat_Ascription_pat | Param_pat | Item_Fn_body | GenericParam_GPConst + -> + AlreadyPar + | _ -> NeedsPar + + method namespace_of_concrete_ident + : concrete_ident -> string * string list = + fun i -> View.to_namespace i + + method concrete_ident' ~(under_current_ns : bool) : concrete_ident fn = + fun id -> + let id = View.to_view id in + let chunks = + if under_current_ns then [ id.definition ] + else id.crate :: (id.path @ [ id.definition ]) + in + separate_map (colon ^^ colon) utf8string chunks + + method name_of_concrete_ident : concrete_ident fn = + View.to_definition_name >> utf8string + + method mutability : 'a. 'a mutability fn = fun _ -> empty + + method primitive_ident : primitive_ident fn = + function + | Deref -> string "deref" + | Cast -> string "cast" + | LogicalOp And -> string "and" + | LogicalOp Or -> string "or" + + method local_ident : local_ident fn = View.local_ident >> utf8string + + method literal : literal_ctx -> literal fn = + (* TODO : escape *) + fun _ctx -> function + | String s -> utf8string s |> dquotes + | Char c -> char c |> bquotes + | Int { value; negative; _ } -> + string value |> precede (if negative then minus else empty) + | Float { value; kind; negative } -> + string value + |> precede (if negative then minus else empty) + |> terminate (string (show_float_kind kind)) + | Bool b -> OCaml.bool b + + method generic_value : generic_value fn = + function + | GLifetime _ -> string "Lifetime" + | GType ty -> print#ty_at GenericValue_GType ty + | GConst expr -> print#expr_at GenericValue_GConst expr + + method lhs : lhs fn = + function + | LhsLocalVar { var; _ } -> print#local_ident var + | LhsArbitraryExpr { e; _ } -> print#expr_at Lhs_LhsArbitraryExpr e + | LhsFieldAccessor { e; field; _ } -> + print#lhs e |> parens + |> terminate (dot ^^ print#global_ident_projector field) + | LhsArrayAccessor { e; index; _ } -> + print#lhs e |> parens + |> terminate (print#expr_at Lhs_LhsArrayAccessor index |> brackets) + + method ty_bool : document = string "bool" + method ty_char : document = string "char" + method ty_str : document = string "str" + + method ty_int : int_kind fn = + fun { size; signedness } -> + let signedness = match signedness with Signed -> "i" | _ -> "u" in + let size = + match int_of_size size with + | Some n -> OCaml.int n + | None -> string "size" + in + string signedness ^^ size + + method ty_float : float_kind fn = show_float_kind >> string + + method generic_values : generic_value list fn = + function + | [] -> empty + | values -> separate_map comma print#generic_value values |> angles + + method ty_app : concrete_ident -> generic_value list fn = + fun f args -> print#concrete_ident f ^^ print#generic_values args + + method ty_tuple : int -> ty list fn = + fun _n -> + separate_map (comma ^^ break 1) (print#ty_at Ty_Tuple) + >> iblock parens + + method! ty : par_state -> ty fn = + fun ctx ty -> + match ty with + | TBool -> string "bool" + | TChar -> string "char" + | TInt kind -> print#ty_int kind + | TFloat kind -> print#ty_float kind + | TStr -> string "String" + | TArrow (inputs, output) -> + separate_map (string "->") (print#ty_at Ty_TArrow) + (inputs @ [ output ]) + |> parens + |> precede (string "arrow!") + | TRef { typ; mut; _ } -> + ampersand ^^ print#mutability mut ^^ print#ty_at Ty_TRef typ + | TParam i -> print#local_ident i + | TSlice { ty; _ } -> print#ty_at Ty_TSlice ty |> brackets + | TRawPointer _ -> string "raw_pointer!()" + | TArray { typ; length } -> + print#ty_at Ty_TArray_length typ + ^/^ semi + ^/^ print#expr_at Ty_TArray_length length + |> brackets + | TAssociatedType _ -> string "assoc_type!()" + | TOpaque _ -> string "opaque_type!()" + | TApp _ -> super#ty ctx ty + | TDyn _ -> empty (* TODO *) + + method! expr' : par_state -> expr' fn = + fun ctx e -> + let wrap_parens = + group + >> + match ctx with AlreadyPar -> Fn.id | NeedsPar -> iblock braces + in + match e with + | If { cond; then_; else_ } -> + let if_then = + (string "if" ^//^ nest 2 (print#expr_at Expr_If_cond cond)) + ^/^ string "then" + ^//^ (print#expr_at Expr_If_then then_ |> braces |> nest 1) + in + (match else_ with + | None -> if_then + | Some else_ -> + if_then ^^ break 1 ^^ string "else" ^^ space + ^^ (print#expr_at Expr_If_else else_ |> iblock braces)) + |> wrap_parens + | Match { scrutinee; arms } -> + let header = + string "match" ^^ space + ^^ (print#expr_at Expr_Match_scrutinee scrutinee + |> terminate space |> iblock Fn.id) + |> group + in + let arms = + separate_map hardline + (print#arm >> group >> nest 2 + >> precede (bar ^^ space) + >> group) + arms + in + header ^^ iblock braces arms + | Let { monadic; lhs; rhs; body } -> + (Option.map + ~f:(fun monad -> print#expr_monadic_let ~monad) + monadic + |> Option.value ~default:print#expr_let) + ~lhs ~rhs body + |> wrap_parens + | Literal l -> print#literal Expr l + | Block { e; safety_mode; _ } -> ( + let e = lbrace ^/^ nest 2 (print#expr ctx e) ^/^ rbrace in + match safety_mode with + | Safe -> e + | Unsafe _ -> !^"unsafe " ^^ e) + | Array l -> + separate_map comma (print#expr_at Expr_Array) l + |> group |> brackets + | LocalVar i -> print#local_ident i + | GlobalVar (`Concrete i) -> print#concrete_ident i + | GlobalVar (`Primitive p) -> print#primitive_ident p + | GlobalVar (`TupleCons 0) -> print#expr_construct_tuple [] + | GlobalVar + (`TupleType _ | `TupleField _ | `Projector _ | `TupleCons _) -> + print#assertion_failure "GlobalVar" + | Assign { lhs; e; _ } -> + group (print#lhs lhs) + ^^ space ^^ equals + ^/^ group (print#expr_at Expr_Assign e) + ^^ semi + | Loop _ -> string "todo loop;" + | Break _ -> string "todo break;" + | Return _ -> string "todo return;" + | Continue _ -> string "todo continue;" + | QuestionMark { e; _ } -> + print#expr_at Expr_QuestionMark e |> terminate qmark + | Borrow { kind; e; _ } -> + string (match kind with Mut _ -> "&mut " | _ -> "&") + ^^ print#expr_at Expr_Borrow e + | AddressOf _ -> string "todo address of;" + | Closure { params; body; _ } -> + separate_map comma (print#pat_at Expr_Closure_param) params + |> group |> enclose bar bar + |> terminate (print#expr_at Expr_Closure_body body |> group) + |> wrap_parens + | Ascription { e; typ } -> + print#expr_at Expr_Ascription_e e + ^^ string "as" + ^/^ print#ty_at Expr_Ascription_typ typ + |> wrap_parens + | MacroInvokation _ -> print#assertion_failure "MacroInvokation" + | EffectAction _ -> print#assertion_failure "EffectAction" + | Quote quote -> print#quote quote + | App _ | Construct _ -> super#expr' ctx e + + method quote { contents; _ } = + List.map + ~f:(function + | `Verbatim code -> string code + | `Expr e -> print#expr_at Expr_Quote e + | `Pat p -> print#pat_at Expr_Quote p + | `Typ p -> print#ty_at Expr_Quote p) + contents + |> concat + + method expr_monadic_let + : monad:supported_monads * F.monadic_binding -> + lhs:pat -> + rhs:expr -> + expr fn = + fun ~monad:_ ~lhs ~rhs body -> print#expr_let ~lhs ~rhs body + + method expr_let : lhs:pat -> rhs:expr -> expr fn = + fun ~lhs ~rhs body -> + string "let" + ^/^ iblock Fn.id (print#pat_at Expr_Let_lhs lhs) + ^/^ equals + ^/^ iblock Fn.id (print#expr_at Expr_Let_rhs rhs) + ^^ semi + ^/^ (print#expr_at Expr_Let_body body |> group) + + method tuple_projection : size:int -> nth:int -> expr fn = + fun ~size:_ ~nth e -> + print#expr_at Expr_TupleProjection e + |> terminate (dot ^^ OCaml.int nth) + + method field_projection : concrete_ident -> expr fn = + fun i e -> + print#expr_at Expr_FieldProjection e + |> terminate (dot ^^ print#name_of_concrete_ident i) + + method expr_app : expr -> expr list -> generic_value list fn = + fun f args _generic_args -> + let args = + separate_map + (comma ^^ break 1) + (print#expr_at Expr_App_arg >> group) + args + in + let f = print#expr_at Expr_App_f f |> group in + f ^^ iblock parens args + + method doc_construct_tuple : document list fn = + separate (comma ^^ break 1) >> iblock parens + + method expr_construct_tuple : expr list fn = + List.map ~f:(print#expr_at Expr_ConstructTuple) + >> print#doc_construct_tuple + + method pat_construct_tuple : pat list fn = + List.map ~f:(print#pat_at Pat_ConstructTuple) + >> print#doc_construct_tuple + + method global_ident_projector : global_ident fn = + function + | `Projector (`Concrete i) | `Concrete i -> print#concrete_ident i + | _ -> + print#assertion_failure "global_ident_projector: not a projector" + + method doc_construct_inductive + : is_record:bool -> + is_struct:bool -> + constructor:concrete_ident -> + base:document option -> + (global_ident * document) list fn = + fun ~is_record ~is_struct:_ ~constructor ~base:_ args -> + if is_record then + print#concrete_ident constructor + ^^ space + ^^ iblock parens + (separate_map (break 0) + (fun (field, body) -> + (print#global_ident_projector field + |> terminate comma |> group) + ^^ colon ^^ space ^^ iblock Fn.id body) + args) + else + print#concrete_ident constructor + ^^ space + ^^ iblock parens (separate_map (break 0) snd args) + + method expr_construct_inductive + : is_record:bool -> + is_struct:bool -> + constructor:concrete_ident -> + base:(expr * F.construct_base) option -> + (global_ident * expr) list fn = + fun ~is_record ~is_struct ~constructor ~base -> + let base = + Option.map + ~f:(fst >> print#expr_at Expr_ConcreteInductive_base) + base + in + List.map ~f:(print#expr_at Expr_ConcreteInductive_field |> map_snd) + >> print#doc_construct_inductive ~is_record ~is_struct ~constructor + ~base + + method attr : attr fn = fun _ -> empty + + method! pat' : par_state -> pat' fn = + fun ctx -> + let wrap_parens = + group + >> + match ctx with AlreadyPar -> Fn.id | NeedsPar -> iblock braces + in + function + | PWild -> underscore + | PAscription { typ; typ_span; pat } -> + print#pat_ascription ~typ ~typ_span pat |> wrap_parens + | PBinding { mut; mode; var; typ = _; subpat } -> ( + let p = + (match mode with ByRef _ -> string "&" | _ -> empty) + ^^ (match mut with Mutable _ -> string "mut " | _ -> empty) + ^^ print#local_ident var + in + match subpat with + | Some (subpat, _) -> + p ^^ space ^^ at ^^ space + ^^ print#pat_at Pat_PBinding_subpat subpat + |> wrap_parens + | None -> p) + | PArray { args } -> + separate_map (break 0) + (print#pat_at Pat_PArray >> terminate comma >> group) + args + |> iblock brackets + | PDeref { subpat; _ } -> + ampersand ^^ print#pat_at Pat_PDeref subpat + | (PConstruct _ | PConstant _) as pat -> super#pat' ctx pat + | POr { subpats } -> + separate_map (bar ^^ break 1) (print#pat_at Pat_Or) subpats + + method pat_ascription : typ:ty -> typ_span:span -> pat fn = + fun ~typ ~typ_span pat -> + print#pat_at Pat_Ascription_pat pat + ^^ colon + ^^ print#with_span ~span:typ_span (fun () -> + print#ty_at Pat_Ascription_typ typ) + + method expr_unwrapped : par_state -> expr fn = + fun ctx { e; _ } -> print#expr' ctx e + + method param : param fn = + fun { pat; typ; typ_span; attrs } -> + let typ = + match typ_span with + | Some span -> + print#with_span ~span (fun _ -> print#ty_at Param_typ typ) + | None -> print#ty_at Param_typ typ + in + print#attrs attrs ^^ print#pat_at Param_pat pat ^^ space ^^ colon + ^^ space ^^ typ + + method item' : item' fn = + function + | Fn { name; generics; body; params; safety } -> + let params = + iblock parens + (separate_map (comma ^^ break 1) print#param params) + in + let generics = print#generic_params generics.params in + let safety = + optional Base.Fn.id + (match safety with + | Safe -> None + | Unsafe _ -> Some !^"unsafe ") + in + safety ^^ !^"fn" ^^ space ^^ print#concrete_ident name ^^ generics + ^^ params + ^^ iblock braces (print#expr_at Item_Fn_body body) + | Quote quote -> print#quote quote + | _ -> string "item not implemented" + + method generic_param' : generic_param fn = + fun { ident; attrs; kind; _ } -> + let suffix = + match kind with + | GPLifetime _ -> space ^^ colon ^^ space ^^ string "'unk" + | GPType -> empty + | GPConst { typ } -> + space ^^ colon ^^ space + ^^ print#ty_at GenericParam_GPConst typ + in + let prefix = + match kind with + | GPConst _ -> string "const" ^^ space + | _ -> empty + in + let ident = + let name = + if String.(ident.name = "_") then "Anonymous" else ident.name + in + { ident with name } + in + prefix ^^ print#attrs attrs ^^ print#local_ident ident ^^ suffix + + method generic_params : generic_param list fn = + separate_map comma print#generic_param >> group >> angles + + (*Option.map ~f:(...) guard |> Option.value ~default:empty*) + method arm' : arm' fn = + fun { arm_pat; body; guard } -> + let pat = print#pat_at Arm_pat arm_pat |> group in + let body = print#expr_at Arm_body body in + let guard = + Option.map + ~f:(fun { guard = IfLet { lhs; rhs; _ }; _ } -> + string " if let " ^^ print#pat_at Arm_pat lhs ^^ string " = " + ^^ print#expr_at Arm_body rhs) + guard + |> Option.value ~default:empty + in + pat ^^ guard ^^ string " => " ^^ body ^^ comma + end + end + + include Class + + include Api (struct + type aux_info = unit + + let new_print () = (new Class.print :> print_object) + end) +end diff --git a/engine/lib/generic_printer/generic_printer.mli b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli similarity index 70% rename from engine/lib/generic_printer/generic_printer.mli rename to engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli index ccd471cc3..3eb3904f6 100644 --- a/engine/lib/generic_printer/generic_printer.mli +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli @@ -1,5 +1,5 @@ module Make (F : Features.T) (View : Concrete_ident.VIEW_API) : sig - open Generic_printer_base.Make(F) + open Deprecated_generic_printer_base.Make(F) include API class print : print_class diff --git a/engine/lib/generic_printer/generic_printer_base.ml b/engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml similarity index 98% rename from engine/lib/generic_printer/generic_printer_base.ml rename to engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml index 3e61a44fd..c887ecdf1 100644 --- a/engine/lib/generic_printer/generic_printer_base.ml +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml @@ -216,17 +216,17 @@ module Make (F : Features.T) = struct method pat' : par_state -> pat' fn = fun _ -> function | PConstant { lit } -> print#literal Pat lit - | PConstruct { name; args; is_record; is_struct } -> ( - match name with + | PConstruct { constructor; is_record; is_struct; fields } -> ( + match constructor with | `Concrete constructor -> print#doc_construct_inductive ~is_record ~is_struct ~constructor ~base:None (List.map ~f:(fun fp -> (fp.field, print#pat_at Pat_ConcreteInductive fp.pat)) - args) + fields) | `TupleCons _ -> - List.map ~f:(fun fp -> fp.pat) args + List.map ~f:(fun fp -> fp.pat) fields |> print#pat_construct_tuple | `Primitive _ | `TupleType _ | `TupleField _ | `Projector _ -> print#assertion_failure "todo err") diff --git a/engine/lib/dune b/engine/lib/dune index 0134495ea..17a3db14d 100644 --- a/engine/lib/dune +++ b/engine/lib/dune @@ -12,6 +12,7 @@ core logs re + sourcemaps ocamlgraph) (preprocessor_deps ; `ppx_inline` is used on the `Subtype` module, thus we need it at PPX time @@ -57,6 +58,17 @@ %{ast} (run generate_from_ast visitors))))) +(rule + (target generated_generic_printer_base.ml) + (deps + (:ast ast.ml)) + (action + (with-stdout-to + generated_generic_printer_base.ml + (with-stdin-from + %{ast} + (run generate_from_ast printer))))) + (rule (target ast_destruct_generated.ml) (deps diff --git a/engine/lib/generic_printer/generic_printer.ml b/engine/lib/generic_printer/generic_printer.ml index c18ef0a6a..838a32596 100644 --- a/engine/lib/generic_printer/generic_printer.ml +++ b/engine/lib/generic_printer/generic_printer.ml @@ -1,463 +1,639 @@ open! Prelude open! Ast +open! PPrint +module LazyDoc = Generated_generic_printer_base.LazyDoc +open LazyDoc + +module Annotation = struct + type loc = { line : int; col : int } [@@deriving show, yojson, eq] + type t = loc * span [@@deriving show, yojson, eq] + + let compare ((a, _) : t) ((b, _) : t) : int = + let line = Int.compare a.line b.line in + if Int.equal line 0 then Int.compare a.col b.col else line + + (** Converts a list of annotation and a string to a list of annotated string *) + let split_with_string (s : string) (annots : t list) = + let lines_position = + String.to_list s + |> List.filter_mapi ~f:(fun i ch -> + match ch with '\n' -> Some i | _ -> None) + |> List.to_array |> Array.get + in + let annots = List.sort ~compare annots in + let init = ({ line = 0; col = 0 }, None) in + let slices = + List.folding_map + ~f:(fun (start, start_span) (end_, end_span) -> + let span = Option.value ~default:end_span start_span in + ((end_, Some end_span), (span, start, end_))) + ~init annots + in + List.map slices ~f:(fun (span, start, end_) -> + let pos = lines_position start.line + start.col in + let len = lines_position end_.line + end_.col - pos in + (span, String.sub s ~pos ~len)) + + let to_mapping ((loc, span) : t) : Sourcemaps.Source_maps.mapping option = + let real_path (x : Types.file_name) = + match x with + | Real (LocalPath p) | Real (Remapped { local_path = Some p; _ }) -> + Some p + | _ -> None + in + let loc_to_loc ({ line; col } : loc) : Sourcemaps.Location.t = + { line; col } + in + let to_loc ({ col; line } : Types.loc) : loc = + { col = Int.of_string col; line = Int.of_string line - 1 } + in + let* span = + Span.to_thir span + |> List.find ~f:(fun (s : Types.span) -> + real_path s.filename |> Option.is_some) + in + let* src_filename = real_path span.filename in + let src_start = to_loc span.lo |> loc_to_loc in + let src_end = to_loc span.hi |> loc_to_loc in + let dst_start = loc_to_loc loc in + Some + Sourcemaps.Source_maps. + { + src = { start = src_start; end_ = Some src_end }; + gen = { start = dst_start; end_ = None }; + source = src_filename; + name = None; + } +end -module Make (F : Features.T) (View : Concrete_ident.VIEW_API) = struct - open Generic_printer_base - open Generic_printer_base.Make (F) - - module Class = struct - module U = Ast_utils.Make (F) - open! AST - open PPrint - - let iblock f = group >> jump 2 0 >> terminate (break 0) >> f >> group - - class print = - object (print) - inherit print_base as super - method printer_name = "Generic" - - method par_state : ast_position -> par_state = - function - | Lhs_LhsArrayAccessor | Ty_Tuple | Ty_TSlice | Ty_TArray_length - | Expr_If_cond | Expr_If_then | Expr_If_else | Expr_Array - | Expr_Assign | Expr_Closure_param | Expr_Closure_body - | Expr_Ascription_e | Expr_Let_lhs | Expr_Let_rhs | Expr_Let_body - | Expr_App_arg | Expr_ConstructTuple | Pat_ConstructTuple | Pat_PArray - | Pat_Ascription_pat | Param_pat | Item_Fn_body | GenericParam_GPConst - -> - AlreadyPar - | _ -> NeedsPar - - method namespace_of_concrete_ident - : concrete_ident -> string * string list = - fun i -> View.to_namespace i - - method concrete_ident' ~(under_current_ns : bool) : concrete_ident fn = - fun id -> - let id = View.to_view id in - let chunks = - if under_current_ns then [ id.definition ] - else id.crate :: (id.path @ [ id.definition ]) - in - separate_map (colon ^^ colon) utf8string chunks - - method name_of_concrete_ident : concrete_ident fn = - View.to_definition_name >> utf8string - - method mutability : 'a. 'a mutability fn = fun _ -> empty - - method primitive_ident : primitive_ident fn = - function - | Deref -> string "deref" - | Cast -> string "cast" - | LogicalOp And -> string "and" - | LogicalOp Or -> string "or" - - method local_ident : local_ident fn = View.local_ident >> utf8string - - method literal : literal_ctx -> literal fn = - (* TODO : escape *) - fun _ctx -> function - | String s -> utf8string s |> dquotes - | Char c -> char c |> bquotes - | Int { value; negative; _ } -> - string value |> precede (if negative then minus else empty) - | Float { value; kind; negative } -> - string value - |> precede (if negative then minus else empty) - |> terminate (string (show_float_kind kind)) - | Bool b -> OCaml.bool b - - method generic_value : generic_value fn = - function - | GLifetime _ -> string "Lifetime" - | GType ty -> print#ty_at GenericValue_GType ty - | GConst expr -> print#expr_at GenericValue_GConst expr - - method lhs : lhs fn = - function - | LhsLocalVar { var; _ } -> print#local_ident var - | LhsArbitraryExpr { e; _ } -> print#expr_at Lhs_LhsArbitraryExpr e - | LhsFieldAccessor { e; field; _ } -> - print#lhs e |> parens - |> terminate (dot ^^ print#global_ident_projector field) - | LhsArrayAccessor { e; index; _ } -> - print#lhs e |> parens - |> terminate (print#expr_at Lhs_LhsArrayAccessor index |> brackets) - - method ty_bool : document = string "bool" - method ty_char : document = string "char" - method ty_str : document = string "str" - - method ty_int : int_kind fn = - fun { size; signedness } -> - let signedness = match signedness with Signed -> "i" | _ -> "u" in - let size = - match int_of_size size with - | Some n -> OCaml.int n - | None -> string "size" - in - string signedness ^^ size - - method ty_float : float_kind fn = show_float_kind >> string - - method generic_values : generic_value list fn = - function - | [] -> empty - | values -> separate_map comma print#generic_value values |> angles - - method ty_app : concrete_ident -> generic_value list fn = - fun f args -> print#concrete_ident f ^^ print#generic_values args - - method ty_tuple : int -> ty list fn = - fun _n -> - separate_map (comma ^^ break 1) (print#ty_at Ty_Tuple) - >> iblock parens - - method! ty : par_state -> ty fn = - fun ctx ty -> - match ty with - | TBool -> string "bool" - | TChar -> string "char" - | TInt kind -> print#ty_int kind - | TFloat kind -> print#ty_float kind - | TStr -> string "String" - | TArrow (inputs, output) -> - separate_map (string "->") (print#ty_at Ty_TArrow) - (inputs @ [ output ]) - |> parens - |> precede (string "arrow!") - | TRef { typ; mut; _ } -> - ampersand ^^ print#mutability mut ^^ print#ty_at Ty_TRef typ - | TParam i -> print#local_ident i - | TSlice { ty; _ } -> print#ty_at Ty_TSlice ty |> brackets - | TRawPointer _ -> string "raw_pointer!()" - | TArray { typ; length } -> - print#ty_at Ty_TArray_length typ - ^/^ semi - ^/^ print#expr_at Ty_TArray_length length - |> brackets - | TAssociatedType _ -> string "assoc_type!()" - | TOpaque _ -> string "opaque_type!()" - | TApp _ -> super#ty ctx ty - | TDyn _ -> empty (* TODO *) - - method! expr' : par_state -> expr' fn = - fun ctx e -> - let wrap_parens = - group - >> - match ctx with AlreadyPar -> Fn.id | NeedsPar -> iblock braces - in - match e with - | If { cond; then_; else_ } -> - let if_then = - (string "if" ^//^ nest 2 (print#expr_at Expr_If_cond cond)) - ^/^ string "then" - ^//^ (print#expr_at Expr_If_then then_ |> braces |> nest 1) - in - (match else_ with - | None -> if_then - | Some else_ -> - if_then ^^ break 1 ^^ string "else" ^^ space - ^^ (print#expr_at Expr_If_else else_ |> iblock braces)) - |> wrap_parens - | Match { scrutinee; arms } -> - let header = - string "match" ^^ space - ^^ (print#expr_at Expr_Match_scrutinee scrutinee - |> terminate space |> iblock Fn.id) - |> group - in - let arms = - separate_map hardline - (print#arm >> group >> nest 2 - >> precede (bar ^^ space) - >> group) - arms - in - header ^^ iblock braces arms - | Let { monadic; lhs; rhs; body } -> - (Option.map - ~f:(fun monad -> print#expr_monadic_let ~monad) - monadic - |> Option.value ~default:print#expr_let) - ~lhs ~rhs body - |> wrap_parens - | Literal l -> print#literal Expr l - | Block { e; safety_mode; _ } -> ( - let e = lbrace ^/^ nest 2 (print#expr ctx e) ^/^ rbrace in - match safety_mode with - | Safe -> e - | Unsafe _ -> !^"unsafe " ^^ e) - | Array l -> - separate_map comma (print#expr_at Expr_Array) l - |> group |> brackets - | LocalVar i -> print#local_ident i - | GlobalVar (`Concrete i) -> print#concrete_ident i - | GlobalVar (`Primitive p) -> print#primitive_ident p - | GlobalVar (`TupleCons 0) -> print#expr_construct_tuple [] - | GlobalVar - (`TupleType _ | `TupleField _ | `Projector _ | `TupleCons _) -> - print#assertion_failure "GlobalVar" - | Assign { lhs; e; _ } -> - group (print#lhs lhs) - ^^ space ^^ equals - ^/^ group (print#expr_at Expr_Assign e) - ^^ semi - | Loop _ -> string "todo loop;" - | Break _ -> string "todo break;" - | Return _ -> string "todo return;" - | Continue _ -> string "todo continue;" - | QuestionMark { e; _ } -> - print#expr_at Expr_QuestionMark e |> terminate qmark - | Borrow { kind; e; _ } -> - string (match kind with Mut _ -> "&mut " | _ -> "&") - ^^ print#expr_at Expr_Borrow e - | AddressOf _ -> string "todo address of;" - | Closure { params; body; _ } -> - separate_map comma (print#pat_at Expr_Closure_param) params - |> group |> enclose bar bar - |> terminate (print#expr_at Expr_Closure_body body |> group) - |> wrap_parens - | Ascription { e; typ } -> - print#expr_at Expr_Ascription_e e - ^^ string "as" - ^/^ print#ty_at Expr_Ascription_typ typ - |> wrap_parens - | MacroInvokation _ -> print#assertion_failure "MacroInvokation" - | EffectAction _ -> print#assertion_failure "EffectAction" - | Quote quote -> print#quote quote - | App _ | Construct _ -> super#expr' ctx e - - method quote { contents; _ } = - List.map - ~f:(function - | `Verbatim code -> string code - | `Expr e -> print#expr_at Expr_Quote e - | `Pat p -> print#pat_at Expr_Quote p - | `Typ p -> print#ty_at Expr_Quote p) - contents - |> concat - - method expr_monadic_let - : monad:supported_monads * F.monadic_binding -> - lhs:pat -> - rhs:expr -> - expr fn = - fun ~monad:_ ~lhs ~rhs body -> print#expr_let ~lhs ~rhs body - - method expr_let : lhs:pat -> rhs:expr -> expr fn = - fun ~lhs ~rhs body -> - string "let" - ^/^ iblock Fn.id (print#pat_at Expr_Let_lhs lhs) - ^/^ equals - ^/^ iblock Fn.id (print#expr_at Expr_Let_rhs rhs) - ^^ semi - ^/^ (print#expr_at Expr_Let_body body |> group) - - method tuple_projection : size:int -> nth:int -> expr fn = - fun ~size:_ ~nth e -> - print#expr_at Expr_TupleProjection e - |> terminate (dot ^^ OCaml.int nth) - - method field_projection : concrete_ident -> expr fn = - fun i e -> - print#expr_at Expr_FieldProjection e - |> terminate (dot ^^ print#name_of_concrete_ident i) - - method expr_app : expr -> expr list -> generic_value list fn = - fun f args _generic_args -> - let args = - separate_map - (comma ^^ break 1) - (print#expr_at Expr_App_arg >> group) - args - in - let f = print#expr_at Expr_App_f f |> group in - f ^^ iblock parens args - - method doc_construct_tuple : document list fn = - separate (comma ^^ break 1) >> iblock parens - - method expr_construct_tuple : expr list fn = - List.map ~f:(print#expr_at Expr_ConstructTuple) - >> print#doc_construct_tuple +module AnnotatedString = struct + type t = string * Annotation.t list [@@deriving show, yojson, eq] + + let to_string = fst + + let to_spanned_strings ((s, annots) : t) : (Ast.span * string) list = + Annotation.split_with_string s annots + + let to_sourcemap : t -> Types.source_map = + snd >> List.filter_map ~f:Annotation.to_mapping >> Sourcemaps.Source_maps.mk + >> fun ({ + mappings; + sourceRoot; + sources; + sourcesContent; + names; + version; + file; + } : + Sourcemaps.Source_maps.t) -> + Types. + { mappings; sourceRoot; sources; sourcesContent; names; version; file } +end - method pat_construct_tuple : pat list fn = - List.map ~f:(print#pat_at Pat_ConstructTuple) - >> print#doc_construct_tuple +(** Helper class that brings imperative span *) +class span_helper : + object + method span_data : Annotation.t list + (** Get the span annotation accumulated while printing *) + + method with_span : span:span -> (unit -> document) -> document + (** Runs the printer `f` under a node of span `span` *) + + method current_span : span + (** Get the current span *) + end = + object (self) + val mutable current_span = Span.default + val mutable span_data : Annotation.t list = [] + method span_data = span_data + method current_span = current_span + + method with_span ~(span : span) (f : unit -> document) : document = + let prev_span = current_span in + current_span <- span; + let doc = f () |> self#spanned_doc |> custom in + current_span <- prev_span; + doc + + method private spanned_doc (doc : document) : custom = + let span = current_span in + object + method requirement : requirement = requirement doc + + method pretty : output -> state -> int -> bool -> unit = + fun o s i b -> + span_data <- ({ line = s.line; col = s.column }, span) :: span_data; + pretty o s i b doc + + method compact : output -> unit = fun o -> compact o doc + end + end - method global_ident_projector : global_ident fn = - function - | `Projector (`Concrete i) | `Concrete i -> print#concrete_ident i +module Make (F : Features.T) = struct + module AST = Ast.Make (F) + open Ast.Make (F) + module Gen = Generated_generic_printer_base.Make (F) + + type printer = (unit -> Annotation.t list, PPrint.document) Gen.object_type + type finalized_printer = (unit, string * Annotation.t list) Gen.object_type + + let finalize (new_printer : unit -> printer) : finalized_printer = + Gen.map (fun apply -> + let printer = new_printer () in + let doc = apply printer in + let buf = Buffer.create 0 in + PPrint.ToBuffer.pretty 1.0 80 buf doc; + (Buffer.contents buf, printer#get_span_data ())) + + class virtual base = + object (self) + inherit Gen.base as super + inherit span_helper + val mutable current_namespace : (string * string list) option = None + + method private catch_exn (handle : string -> document) + (f : unit -> document) : document = + self#catch_exn' + (fun context kind -> + Diagnostics.pretty_print_context_kind context kind |> handle) + f + + method private catch_exn' + (handle : Diagnostics.Context.t -> Diagnostics.kind -> document) + (f : unit -> document) : document = + try f () + with Diagnostics.SpanFreeError.Exn (Data (context, kind)) -> + handle context kind + + (** {2:specialize-expr Printer settings} *) + + method virtual printer_name : string + (** Mark a path as unreachable *) + + val concrete_ident_view : (module Concrete_ident.VIEW_API) = + (module Concrete_ident.DefaultViewAPI) + (** The concrete ident view to be used *) + + (** {2:specialize-expr Utility functions} *) + + method assertion_failure : 'any. string -> 'any = + fun details -> + let span = Span.to_thir self#current_span in + let kind = Types.AssertionFailure { details } in + let ctx = Diagnostics.Context.GenericPrinter self#printer_name in + Diagnostics.SpanFreeError.raise ~span ctx kind + (** An assertion failed *) + + method unreachable : 'any. unit -> 'any = + self#assertion_failure "Unreachable" + (** Mark a path as unreachable *) + + method local_ident (id : local_ident) : document = + let module View = (val concrete_ident_view) in + View.local_ident + (match String.chop_prefix ~prefix:"impl " id.name with + | Some _ -> + let name = "impl_" ^ Int.to_string ([%hash: string] id.name) in + { id with name } + | _ -> id) + |> string + (** {2:specialize-expr Printers for special types} *) + + method concrete_ident ~local (id : Concrete_ident.view) : document = + string + (if local then id.definition + else + String.concat ~sep:self#module_path_separator + (id.crate :: (id.path @ [ id.definition ]))) + (** [concrete_ident ~local id] prints a name without path if + [local] is true, otherwise it prints the full path, separated by + `module_path_separator`. *) + + method quote (quote : quote) : document = + List.map + ~f:(function + | `Verbatim code -> string code + | `Expr e -> self#print_expr AstPosition_Quote e + | `Pat p -> self#print_pat AstPosition_Quote p + | `Typ p -> self#print_ty AstPosition_Quote p) + quote.contents + |> concat + + (** {2:specialize-expr Specialized printers for [expr]} *) + + method virtual expr'_App_constant + : super:expr -> + constant:concrete_ident lazy_doc -> + generics:generic_value lazy_doc list -> + document + (** [expr'_App_constant ~super ~constant ~generics] prints the + constant [e] with generics [generics]. [super] is the + unspecialized [expr]. *) + + method virtual expr'_App_application + : super:expr -> + f:expr lazy_doc -> + args:expr lazy_doc list -> + generics:generic_value lazy_doc list -> + document + (** [expr'_App_application ~super ~f ~args ~generics] prints the + function application [e<...generics>(...args)]. [super] is the + unspecialized [expr]. *) + + method virtual expr'_App_tuple_projection + : super:expr -> size:int -> nth:int -> e:expr lazy_doc -> document + (** [expr'_App_tuple_projection ~super ~size ~nth ~e] prints + the projection of the [nth] component of the tuple [e] of + size [size]. [super] is the unspecialized [expr]. *) + + method virtual expr'_App_field_projection + : super:expr -> + field:concrete_ident lazy_doc -> + e:expr lazy_doc -> + document + (** [expr'_App_field_projection ~super ~field ~e] prints the + projection of the field [field] in the expression [e]. [super] + is the unspecialized [expr]. *) + + method virtual expr'_Construct_inductive + : super:expr -> + constructor:concrete_ident lazy_doc -> + is_record:bool -> + is_struct:bool -> + fields:(concrete_ident lazy_doc * expr lazy_doc) list -> + base:(expr lazy_doc * F.construct_base) lazy_doc option -> + document + (** [expr'_Construct_inductive ~super ~is_record ~is_struct + ~constructor ~base ~fields] prints the construction of an + inductive with base [base] and fields [fields]. [super] is the + unspecialized [expr]. TODO doc is_record is_struct *) + + method virtual expr'_Construct_tuple + : super:expr -> components:expr lazy_doc list -> document + + method virtual expr'_GlobalVar_concrete + : super:expr -> concrete_ident lazy_doc -> document + + method virtual expr'_GlobalVar_primitive + : super:expr -> primitive_ident -> document + + (** {2:specialize-pat Specialized printers for [pat]} *) + + method virtual pat'_PConstruct_inductive + : super:pat -> + constructor:concrete_ident lazy_doc -> + is_record:bool -> + is_struct:bool -> + fields:(concrete_ident lazy_doc * pat lazy_doc) list -> + document + + method virtual pat'_PConstruct_tuple + : super:pat -> components:pat lazy_doc list -> document + + (** {2:specialize-lhs Specialized printers for [lhs]} *) + + method virtual lhs_LhsFieldAccessor_field + : e:lhs lazy_doc -> + typ:ty lazy_doc -> + field:concrete_ident lazy_doc -> + witness:F.nontrivial_lhs -> + document + + method virtual lhs_LhsFieldAccessor_tuple + : e:lhs lazy_doc -> + typ:ty lazy_doc -> + nth:int -> + size:int -> + witness:F.nontrivial_lhs -> + document + + (** {2:specialize-ty Specialized printers for [ty]} *) + + method virtual ty_TApp_tuple : types:ty list -> document + (** [ty_TApp_tuple ~types] prints a tuple type with + compounds types [types]. *) + + method virtual ty_TApp_application + : typ:concrete_ident lazy_doc -> + generics:generic_value lazy_doc list -> + document + (** [ty_TApp_application ~typ ~generics] prints the type + [typ<...generics>]. *) + + (** {2:specialize-ty Specialized printers for [item]} *) + + method virtual item'_Type_struct + : super:item -> + name:concrete_ident lazy_doc -> + generics:generics lazy_doc -> + tuple_struct:bool -> + arguments: + (concrete_ident lazy_doc * ty lazy_doc * attr list lazy_doc) list -> + document + (** [item'_Type_struct ~super ~name ~generics ~tuple_struct ~arguments] prints the struct definition [struct name arguments]. `tuple_struct` says whether we are dealing with a tuple struct + (e.g. [struct Foo(T1, T2)]) or a named struct + (e.g. [struct Foo {field: T1, other: T2}])? *) + + method virtual item'_Type_enum + : super:item -> + name:concrete_ident lazy_doc -> + generics:generics lazy_doc -> + variants:variant lazy_doc list -> + document + (** [item'_Type_enum ~super ~name ~generics ~variants] prints + the enum type [enum name { ... }]. *) + + method virtual item'_Enum_Variant + : name:concrete_ident lazy_doc -> + arguments: + (concrete_ident lazy_doc * ty lazy_doc * attrs lazy_doc) list -> + is_record:bool -> + attrs:attrs lazy_doc -> + document + (** [item'_Enum_Variant] prints a variant of an enum. *) + + (** {2:common-nodes Printers for common nodes} *) + + method virtual common_array : document list -> document + (** [common_array values] is a default for printing array-like nodes: array patterns, array expressions. *) + + (** {2:defaults Default printers} **) + + method module_path_separator = "::" + (** [module_path_separator] is the default separator for + paths. `::` by default *) + + method pat'_PArray ~super:_ ~args = + List.map ~f:(fun arg -> arg#p) args |> self#common_array + + method expr'_Array ~super:_ args = + List.map ~f:(fun arg -> arg#p) args |> self#common_array + + method pat'_POr ~super:_ ~subpats = + List.map ~f:(fun subpat -> subpat#p) subpats + |> separate (break 1 ^^ char '|' ^^ space) + + (**/**) + (* This section is about defining or overriding + `_do_not_override_` methods. This is internal logic, whence this + is excluded from documentation (with the nice and user friendly + `(**/**)` ocamldoc syntax) *) + + method _do_not_override_lhs_LhsFieldAccessor ~e ~typ ~field ~witness = + let field = + match field with + | `Projector field -> field | _ -> - print#assertion_failure "global_ident_projector: not a projector" - - method doc_construct_inductive - : is_record:bool -> - is_struct:bool -> - constructor:concrete_ident -> - base:document option -> - (global_ident * document) list fn = - fun ~is_record ~is_struct:_ ~constructor ~base:_ args -> - if is_record then - print#concrete_ident constructor - ^^ space - ^^ iblock parens - (separate_map (break 0) - (fun (field, body) -> - (print#global_ident_projector field - |> terminate comma |> group) - ^^ colon ^^ space ^^ iblock Fn.id body) - args) - else - print#concrete_ident constructor - ^^ space - ^^ iblock parens (separate_map (break 0) snd args) - - method expr_construct_inductive - : is_record:bool -> - is_struct:bool -> - constructor:concrete_ident -> - base:(expr * F.construct_base) option -> - (global_ident * expr) list fn = - fun ~is_record ~is_struct ~constructor ~base -> - let base = - Option.map - ~f:(fst >> print#expr_at Expr_ConcreteInductive_base) - base + self#assertion_failure + @@ "LhsFieldAccessor: field not a [`Projector] " + in + match field with + | `TupleField (nth, size) -> + self#lhs_LhsFieldAccessor_tuple ~e ~typ ~nth ~size ~witness + | `Concrete field -> + let field : concrete_ident lazy_doc = + self#_do_not_override_lazy_of_concrete_ident + AstPos_lhs_LhsFieldAccessor_field field in - List.map ~f:(print#expr_at Expr_ConcreteInductive_field |> map_snd) - >> print#doc_construct_inductive ~is_record ~is_struct ~constructor - ~base - - method attr : attr fn = fun _ -> empty - - method! pat' : par_state -> pat' fn = - fun ctx -> - let wrap_parens = - group - >> - match ctx with AlreadyPar -> Fn.id | NeedsPar -> iblock braces + self#lhs_LhsFieldAccessor_field ~e ~typ ~field ~witness + + method _do_not_override_expr'_App ~super ~f ~args ~generic_args + ~bounds_impls ~trait = + let _ = (super, f, args, generic_args, bounds_impls, trait) in + match f#v with + | { e = GlobalVar i; _ } -> ( + let expect_one_arg where = + match args with + | [ arg ] -> arg + | _ -> self#assertion_failure @@ "Expected one arg at " ^ where in - function - | PWild -> underscore - | PAscription { typ; typ_span; pat } -> - print#pat_ascription ~typ ~typ_span pat |> wrap_parens - | PBinding { mut; mode; var; typ = _; subpat } -> ( - let p = - (match mode with ByRef _ -> string "&" | _ -> empty) - ^^ (match mut with Mutable _ -> string "mut " | _ -> empty) - ^^ print#local_ident var + match i with + | `Concrete _ | `Primitive _ -> ( + match (args, i) with + | [], `Concrete i -> + let constant = + self#_do_not_override_lazy_of_concrete_ident + AstPos_expr'_App_f i + in + self#expr'_App_constant ~super ~constant + ~generics:generic_args + | [], _ -> self#assertion_failure "Primitive app of arity 0" + | _ -> + self#expr'_App_application ~super ~f ~args + ~generics:generic_args) + | `TupleType _ | `TupleCons _ | `TupleField _ -> + self#assertion_failure "App: unexpected tuple" + | `Projector (`TupleField (nth, size)) -> + let e = expect_one_arg "projector tuple field" in + self#expr'_App_tuple_projection ~super ~size ~nth ~e + | `Projector (`Concrete field) -> + let e = expect_one_arg "projector concrete" in + let field = + self#_do_not_override_lazy_of_concrete_ident + AstPos_expr'_App_f field in - match subpat with - | Some (subpat, _) -> - p ^^ space ^^ at ^^ space - ^^ print#pat_at Pat_PBinding_subpat subpat - |> wrap_parens - | None -> p) - | PArray { args } -> - separate_map (break 0) - (print#pat_at Pat_PArray >> terminate comma >> group) - args - |> iblock brackets - | PDeref { subpat; _ } -> - ampersand ^^ print#pat_at Pat_PDeref subpat - | (PConstruct _ | PConstant _) as pat -> super#pat' ctx pat - | POr { subpats } -> - separate_map (bar ^^ break 1) (print#pat_at Pat_Or) subpats - - method pat_ascription : typ:ty -> typ_span:span -> pat fn = - fun ~typ ~typ_span pat -> - print#pat_at Pat_Ascription_pat pat - ^^ colon - ^^ print#with_span ~span:typ_span (fun () -> - print#ty_at Pat_Ascription_typ typ) - - method expr_unwrapped : par_state -> expr fn = - fun ctx { e; _ } -> print#expr' ctx e - - method param : param fn = - fun { pat; typ; typ_span; attrs } -> - let typ = - match typ_span with - | Some span -> - print#with_span ~span (fun _ -> print#ty_at Param_typ typ) - | None -> print#ty_at Param_typ typ + self#expr'_App_field_projection ~super ~field ~e) + | _ -> self#assertion_failure "Primitive app of arity 0" + + method _do_not_override_expr'_Construct ~super ~constructor ~is_record + ~is_struct ~fields ~base = + match constructor with + | `Concrete constructor -> + let constructor = + self#_do_not_override_lazy_of_concrete_ident + AstPos_expr'_Construct_constructor constructor in - print#attrs attrs ^^ print#pat_at Param_pat pat ^^ space ^^ colon - ^^ space ^^ typ - - method item' : item' fn = - function - | Fn { name; generics; body; params; safety } -> - let params = - iblock parens - (separate_map (comma ^^ break 1) print#param params) - in - let generics = print#generic_params generics.params in - let safety = - optional Base.Fn.id - (match safety with - | Safe -> None - | Unsafe _ -> Some !^"unsafe ") - in - safety ^^ !^"fn" ^^ space ^^ print#concrete_ident name ^^ generics - ^^ params - ^^ iblock braces (print#expr_at Item_Fn_body body) - | Quote quote -> print#quote quote - | _ -> string "item not implemented" - - method generic_param' : generic_param fn = - fun { ident; attrs; kind; _ } -> - let suffix = - match kind with - | GPLifetime _ -> space ^^ colon ^^ space ^^ string "'unk" - | GPType -> empty - | GPConst { typ } -> - space ^^ colon ^^ space - ^^ print#ty_at GenericParam_GPConst typ + let fields = + List.map + ~f:(fun field -> + let name, expr = field#v in + let name = + match name with + | `Concrete name -> name + | _ -> + self#assertion_failure + "expr'.Construct: field: non-`Concrete" + in + ( self#_do_not_override_lazy_of_concrete_ident + AstPos_expr'_Construct_fields name, + expr )) + fields in - let prefix = - match kind with - | GPConst _ -> string "const" ^^ space - | _ -> empty + self#expr'_Construct_inductive ~super ~constructor ~is_record + ~is_struct ~fields ~base + | `TupleCons _ -> + let components = List.map ~f:(fun field -> snd field#v) fields in + self#expr'_Construct_tuple ~super ~components + | `Primitive _ | `TupleType _ | `TupleField _ | `Projector _ -> + self#assertion_failure "Construct unexpected constructors" + + method _do_not_override_expr'_GlobalVar ~super global_ident = + match global_ident with + | `Concrete concrete -> + let concrete = + self#_do_not_override_lazy_of_concrete_ident + AstPos_expr'_GlobalVar_x0 concrete in - let ident = - let name = - if String.(ident.name = "_") then "Anonymous" else ident.name - in - { ident with name } + self#expr'_GlobalVar_concrete ~super concrete + | `Primitive primitive -> + self#expr'_GlobalVar_primitive ~super primitive + | _ -> + self#assertion_failure + @@ "GlobalVar: expected a concrete or primitive global ident, got:" + ^ [%show: global_ident] global_ident + + method _do_not_override_pat'_PConstruct ~super ~constructor ~is_record + ~is_struct ~fields = + match constructor with + | `Concrete constructor -> + let constructor = + self#_do_not_override_lazy_of_concrete_ident + AstPos_pat'_PConstruct_constructor constructor in - prefix ^^ print#attrs attrs ^^ print#local_ident ident ^^ suffix - - method generic_params : generic_param list fn = - separate_map comma print#generic_param >> group >> angles - - (*Option.map ~f:(...) guard |> Option.value ~default:empty*) - method arm' : arm' fn = - fun { arm_pat; body; guard } -> - let pat = print#pat_at Arm_pat arm_pat |> group in - let body = print#expr_at Arm_body body in - let guard = - Option.map - ~f:(fun { guard = IfLet { lhs; rhs; _ }; _ } -> - string " if let " ^^ print#pat_at Arm_pat lhs ^^ string " = " - ^^ print#expr_at Arm_body rhs) - guard - |> Option.value ~default:empty + let fields = + List.map + ~f:(fun field -> + let { field; pat } = field#v in + let field = + match field with + | `Concrete field -> field + | _ -> + self#assertion_failure + "expr'.Construct: field: non-`Concrete" + in + let pat = + self#_do_not_override_lazy_of_pat AstPos_field_pat__pat pat + in + ( self#_do_not_override_lazy_of_concrete_ident + AstPos_pat'_PConstruct_fields field, + pat )) + fields in - pat ^^ guard ^^ string " => " ^^ body ^^ comma - end - end - - include Class - - include Api (struct - type aux_info = unit + self#pat'_PConstruct_inductive ~super ~constructor ~is_record + ~is_struct ~fields + | `TupleCons _ -> + let components = + List.map + ~f:(fun field -> + self#_do_not_override_lazy_of_pat AstPos_field_pat__pat + field#v.pat) + fields + in + self#pat'_PConstruct_tuple ~super ~components + | `Primitive _ | `TupleType _ | `TupleField _ | `Projector _ -> + self#assertion_failure "Construct unexpected constructors" - let new_print () = (new Class.print :> print_object) - end) + method _do_not_override_ty_TApp ~ident ~args = + match ident with + | `Concrete ident -> + let typ = + self#_do_not_override_lazy_of_concrete_ident AstPos_ty_TApp_args + ident + in + self#ty_TApp_application ~typ ~generics:args |> group + | `Primitive _ | `TupleCons _ | `TupleField _ | `Projector _ -> + self#assertion_failure "TApp not concrete" + | `TupleType size -> + let types = + List.filter_map + ~f:(fun garg -> + match garg#v with GType t -> Some t | _ -> None) + args + in + if [%equal: int] (List.length args) size |> not then + self#assertion_failure "malformed [ty.TApp] tuple"; + self#ty_TApp_tuple ~types + + method _do_not_override_item'_Type ~super ~name ~generics ~variants + ~is_struct = + if is_struct then + match variants with + | [ variant ] -> + let variant_arguments = + List.map + ~f:(fun (ident, typ, attrs) -> + ( self#_do_not_override_lazy_of_concrete_ident + AstPos_variant__arguments ident, + self#_do_not_override_lazy_of_ty AstPos_variant__arguments + typ, + self#_do_not_override_lazy_of_attrs AstPos_variant__attrs + attrs )) + variant#v.arguments + in + self#item'_Type_struct ~super ~name ~generics + ~tuple_struct:(not variant#v.is_record) + ~arguments:variant_arguments + | _ -> self#unreachable () + else self#item'_Type_enum ~super ~name ~generics ~variants + + method _do_not_override_variant + : name:concrete_ident lazy_doc -> + arguments: + (concrete_ident lazy_doc * ty lazy_doc * attrs lazy_doc) list -> + is_record:bool -> + attrs:attrs lazy_doc -> + document = + self#item'_Enum_Variant + + method _do_not_override_lazy_of_local_ident ast_position + (id : local_ident) = + lazy_doc (fun (id : local_ident) -> self#local_ident id) ast_position id + + method _do_not_override_lazy_of_concrete_ident ast_position + (id : concrete_ident) : concrete_ident lazy_doc = + lazy_doc + (fun (id : concrete_ident) -> + let module View = (val concrete_ident_view) in + let id = View.to_view id in + let ns_crate, ns_path = + Option.value ~default:("", []) current_namespace + in + let local = + String.(ns_crate = id.crate) && [%eq: string list] ns_path id.path + in + self#concrete_ident ~local id) + ast_position id + + method _do_not_override_lazy_of_quote ast_position (value : quote) + : quote lazy_doc = + lazy_doc (fun (value : quote) -> self#quote value) ast_position value + + method! _do_not_override_lazy_of_item ast_position (value : item) + : item lazy_doc = + let module View = (val concrete_ident_view) in + current_namespace <- View.to_namespace value.ident |> Option.some; + super#_do_not_override_lazy_of_item ast_position value + + method _do_not_override_lazy_of_generics ast_position (value : generics) + : (generics lazy_doc + * generic_param lazy_doc list + * generic_constraint lazy_doc list) + lazy_doc = + let params = + List.map + ~f:(fun x -> + self#_do_not_override_lazy_of_generic_param + AstPos_generics__params x) + value.params + in + let constraints = + List.map + ~f:(fun x -> + self#_do_not_override_lazy_of_generic_constraint + AstPos_generics__constraints x) + value.constraints + in + lazy_doc + (fun (lazy_doc, _, _) -> lazy_doc#p) + ast_position + ( lazy_doc + (fun (value : generics) -> + self#wrap_generics ast_position value + (self#generics ~params ~constraints)) + ast_position value, + params, + constraints ) + + (**/**) + end end diff --git a/engine/lib/generic_printer/generic_printer_template.generate.js b/engine/lib/generic_printer/generic_printer_template.generate.js new file mode 100755 index 000000000..66ec63b8c --- /dev/null +++ b/engine/lib/generic_printer/generic_printer_template.generate.js @@ -0,0 +1,49 @@ +#!/usr/bin/env node + +// This script regenerates `generic_printer_template.ml` + +const {readFileSync, writeFileSync} = require('fs'); +const {execSync} = require('child_process'); + +const GENERIC_PRINTER_DIR = `lib/generic_printer`; +const GENERIC_PRINTER = `${GENERIC_PRINTER_DIR}/generic_printer.ml`; +const TEMPLATE = `${GENERIC_PRINTER_DIR}/generic_printer_template.ml`; + +// Utility function to format an OCaml module +let fmt = path => execSync(`ocamlformat -i ${path}`); + +// Go to the root of the engine +require('process').chdir(`${execSync('git rev-parse --show-toplevel').toString().trim()}/engine`); + + +// Prints the signature of module `Generic_printer` (using `ocaml-print-intf`) +let mli = execSync(`dune exec -- ocaml-print-intf ${GENERIC_PRINTER}`).toString().split('class virtual base')[2]; + +writeFileSync('/tmp/exported.mli', mli); + +// Parses all +let virtual_methods = [...mli.matchAll(/^( +)method (private )?virtual +(?.*) +:(?.*(\n \1.*)*)/gm)]; + +let output = []; +for(let v of virtual_methods) { + let {name, sig} = v.groups; + let out = sig.trim().split('->').slice(-1)[0].trim().split('.').slice(-1)[0]; + let args = sig.trim().split('->').map((s, i) => { + let chunks = s.trim().split(':').reverse(); + if(chunks.length > 2 || chunks.length == 0) { + throw "Chunks: bad length"; + } + let [type, name] = chunks; + name = name ? '~'+name+':_' : '_x'+(i + 1); + return {type, name}; + }).map(n => n.name).slice(0, -1).join(' '); + + output.push(`method ${name} ${args} = default_${out}_for "${name}"`); +} + +{ + let [before, _, after] = readFileSync(TEMPLATE).toString().split(/(?=\(\* (?:BEGIN|END) GENERATED \*\))/); + writeFileSync(TEMPLATE, before + '\n(* BEGIN GENERATED *)\n' + output.join('\n') + '\n' + after); +} + +fmt(TEMPLATE); diff --git a/engine/lib/generic_printer/generic_printer_template.ml b/engine/lib/generic_printer/generic_printer_template.ml new file mode 100644 index 000000000..110873754 --- /dev/null +++ b/engine/lib/generic_printer/generic_printer_template.ml @@ -0,0 +1,367 @@ +open! Prelude +open! Ast +open! PPrint + +module Make + (F : Features.T) (Default : sig + val default : string -> string + end) = +struct + module AST = Ast.Make (F) + open Ast.Make (F) + module Base = Generic_printer.Make (F) + open PPrint + + let default_string_for s = "TODO: please implement the method `" ^ s ^ "`" + let default_document_for = default_string_for >> string + + class printer = + object + inherit Base.base + + (* BEGIN GENERATED *) + method arm ~arm:_ ~span:_ = default_document_for "arm" + + method arm' ~super:_ ~arm_pat:_ ~body:_ ~guard:_ = + default_document_for "arm'" + + method attrs _x1 = default_document_for "attrs" + + method binding_mode_ByRef _x1 _x2 = + default_document_for "binding_mode_ByRef" + + method binding_mode_ByValue = default_document_for "binding_mode_ByValue" + method borrow_kind_Mut _x1 = default_document_for "borrow_kind_Mut" + method borrow_kind_Shared = default_document_for "borrow_kind_Shared" + method borrow_kind_Unique = default_document_for "borrow_kind_Unique" + method common_array _x1 = default_document_for "common_array" + + method dyn_trait_goal ~trait:_ ~non_self_args:_ = + default_document_for "dyn_trait_goal" + + method error_expr _x1 = default_document_for "error_expr" + method error_item _x1 = default_document_for "error_item" + method error_pat _x1 = default_document_for "error_pat" + method expr ~e:_ ~span:_ ~typ:_ = default_document_for "expr" + + method expr'_AddressOf ~super:_ ~mut:_ ~e:_ ~witness:_ = + default_document_for "expr'_AddressOf" + + method expr'_App_application ~super:_ ~f:_ ~args:_ ~generics:_ = + default_document_for "expr'_App_application" + + method expr'_App_constant ~super:_ ~constant:_ ~generics:_ = + default_document_for "expr'_App_constant" + + method expr'_App_field_projection ~super:_ ~field:_ ~e:_ = + default_document_for "expr'_App_field_projection" + + method expr'_App_tuple_projection ~super:_ ~size:_ ~nth:_ ~e:_ = + default_document_for "expr'_App_tuple_projection" + + method expr'_Ascription ~super:_ ~e:_ ~typ:_ = + default_document_for "expr'_Ascription" + + method expr'_Assign ~super:_ ~lhs:_ ~e:_ ~witness:_ = + default_document_for "expr'_Assign" + + method expr'_Block ~super:_ ~e:_ ~safety_mode:_ ~witness:_ = + default_document_for "expr'_Block" + + method expr'_Borrow ~super:_ ~kind:_ ~e:_ ~witness:_ = + default_document_for "expr'_Borrow" + + method expr'_Break ~super:_ ~e:_ ~label:_ ~witness:_ = + default_document_for "expr'_Break" + + method expr'_Closure ~super:_ ~params:_ ~body:_ ~captures:_ = + default_document_for "expr'_Closure" + + method expr'_Construct_inductive ~super:_ ~constructor:_ ~is_record:_ + ~is_struct:_ ~fields:_ ~base:_ = + default_document_for "expr'_Construct_inductive" + + method expr'_Construct_tuple ~super:_ ~components:_ = + default_document_for "expr'_Construct_tuple" + + method expr'_Continue ~super:_ ~e:_ ~label:_ ~witness:_ = + default_document_for "expr'_Continue" + + method expr'_EffectAction ~super:_ ~action:_ ~argument:_ = + default_document_for "expr'_EffectAction" + + method expr'_GlobalVar_concrete ~super:_ _x2 = + default_document_for "expr'_GlobalVar_concrete" + + method expr'_GlobalVar_primitive ~super:_ _x2 = + default_document_for "expr'_GlobalVar_primitive" + + method expr'_If ~super:_ ~cond:_ ~then_:_ ~else_:_ = + default_document_for "expr'_If" + + method expr'_Let ~super:_ ~monadic:_ ~lhs:_ ~rhs:_ ~body:_ = + default_document_for "expr'_Let" + + method expr'_Literal ~super:_ _x2 = default_document_for "expr'_Literal" + method expr'_LocalVar ~super:_ _x2 = default_document_for "expr'_LocalVar" + + method expr'_Loop ~super:_ ~body:_ ~kind:_ ~state:_ ~label:_ ~witness:_ = + default_document_for "expr'_Loop" + + method expr'_MacroInvokation ~super:_ ~macro:_ ~args:_ ~witness:_ = + default_document_for "expr'_MacroInvokation" + + method expr'_Match ~super:_ ~scrutinee:_ ~arms:_ = + default_document_for "expr'_Match" + + method expr'_QuestionMark ~super:_ ~e:_ ~return_typ:_ ~witness:_ = + default_document_for "expr'_QuestionMark" + + method expr'_Quote ~super:_ _x2 = default_document_for "expr'_Quote" + + method expr'_Return ~super:_ ~e:_ ~witness:_ = + default_document_for "expr'_Return" + + method field_pat ~field:_ ~pat:_ = default_document_for "field_pat" + + method generic_constraint_GCLifetime _x1 _x2 = + default_document_for "generic_constraint_GCLifetime" + + method generic_constraint_GCProjection _x1 = + default_document_for "generic_constraint_GCProjection" + + method generic_constraint_GCType _x1 = + default_document_for "generic_constraint_GCType" + + method generic_param ~ident:_ ~span:_ ~attrs:_ ~kind:_ = + default_document_for "generic_param" + + method generic_param_kind_GPConst ~typ:_ = + default_document_for "generic_param_kind_GPConst" + + method generic_param_kind_GPLifetime ~witness:_ = + default_document_for "generic_param_kind_GPLifetime" + + method generic_param_kind_GPType = + default_document_for "generic_param_kind_GPType" + + method generic_value_GConst _x1 = + default_document_for "generic_value_GConst" + + method generic_value_GLifetime ~lt:_ ~witness:_ = + default_document_for "generic_value_GLifetime" + + method generic_value_GType _x1 = + default_document_for "generic_value_GType" + + method generics ~params:_ ~constraints:_ = default_document_for "generics" + method guard ~guard:_ ~span:_ = default_document_for "guard" + + method guard'_IfLet ~super:_ ~lhs:_ ~rhs:_ ~witness:_ = + default_document_for "guard'_IfLet" + + method impl_expr ~kind:_ ~goal:_ = default_document_for "impl_expr" + + method impl_expr_kind_Builtin _x1 = + default_document_for "impl_expr_kind_Builtin" + + method impl_expr_kind_Concrete _x1 = + default_document_for "impl_expr_kind_Concrete" + + method impl_expr_kind_Dyn = default_document_for "impl_expr_kind_Dyn" + + method impl_expr_kind_ImplApp ~impl:_ ~args:_ = + default_document_for "impl_expr_kind_ImplApp" + + method impl_expr_kind_LocalBound ~id:_ = + default_document_for "impl_expr_kind_LocalBound" + + method impl_expr_kind_Parent ~impl:_ ~ident:_ = + default_document_for "impl_expr_kind_Parent" + + method impl_expr_kind_Projection ~impl:_ ~item:_ ~ident:_ = + default_document_for "impl_expr_kind_Projection" + + method impl_expr_kind_Self = default_document_for "impl_expr_kind_Self" + method impl_ident ~goal:_ ~name:_ = default_document_for "impl_ident" + + method impl_item ~ii_span:_ ~ii_generics:_ ~ii_v:_ ~ii_ident:_ ~ii_attrs:_ + = + default_document_for "impl_item" + + method impl_item'_IIFn ~body:_ ~params:_ = + default_document_for "impl_item'_IIFn" + + method impl_item'_IIType ~typ:_ ~parent_bounds:_ = + default_document_for "impl_item'_IIType" + + method item ~v:_ ~span:_ ~ident:_ ~attrs:_ = default_document_for "item" + + method item'_Alias ~super:_ ~name:_ ~item:_ = + default_document_for "item'_Alias" + + method item'_Enum_Variant ~name:_ ~arguments:_ ~is_record:_ ~attrs:_ = + default_document_for "item'_Enum_Variant" + + method item'_Fn ~super:_ ~name:_ ~generics:_ ~body:_ ~params:_ ~safety:_ = + default_document_for "item'_Fn" + + method item'_HaxError ~super:_ _x2 = default_document_for "item'_HaxError" + + method item'_IMacroInvokation ~super:_ ~macro:_ ~argument:_ ~span:_ + ~witness:_ = + default_document_for "item'_IMacroInvokation" + + method item'_Impl ~super:_ ~generics:_ ~self_ty:_ ~of_trait:_ ~items:_ + ~parent_bounds:_ ~safety:_ = + default_document_for "item'_Impl" + + method item'_NotImplementedYet = + default_document_for "item'_NotImplementedYet" + + method item'_Quote ~super:_ _x2 = default_document_for "item'_Quote" + + method item'_Trait ~super:_ ~name:_ ~generics:_ ~items:_ ~safety:_ = + default_document_for "item'_Trait" + + method item'_TyAlias ~super:_ ~name:_ ~generics:_ ~ty:_ = + default_document_for "item'_TyAlias" + + method item'_Type ~super:_ ~name:_ ~generics:_ ~variants:_ ~is_struct:_ = + default_document_for "item'_Type" + + method item'_Type_enum ~super:_ ~name:_ ~generics:_ ~variants:_ = + default_document_for "item'_Type_enum" + + method item'_Type_struct ~super:_ ~name:_ ~generics:_ ~tuple_struct:_ + ~arguments:_ = + default_document_for "item'_Type_struct" + + method item'_Use ~super:_ ~path:_ ~is_external:_ ~rename:_ = + default_document_for "item'_Use" + + method lhs_LhsArbitraryExpr ~e:_ ~witness:_ = + default_document_for "lhs_LhsArbitraryExpr" + + method lhs_LhsArrayAccessor ~e:_ ~typ:_ ~index:_ ~witness:_ = + default_document_for "lhs_LhsArrayAccessor" + + method lhs_LhsFieldAccessor_field ~e:_ ~typ:_ ~field:_ ~witness:_ = + default_document_for "lhs_LhsFieldAccessor_field" + + method lhs_LhsFieldAccessor_tuple ~e:_ ~typ:_ ~nth:_ ~size:_ ~witness:_ = + default_document_for "lhs_LhsFieldAccessor_tuple" + + method lhs_LhsLocalVar ~var:_ ~typ:_ = + default_document_for "lhs_LhsLocalVar" + + method literal_Bool _x1 = default_document_for "literal_Bool" + method literal_Char _x1 = default_document_for "literal_Char" + + method literal_Float ~value:_ ~negative:_ ~kind:_ = + default_document_for "literal_Float" + + method literal_Int ~value:_ ~negative:_ ~kind:_ = + default_document_for "literal_Int" + + method literal_String _x1 = default_document_for "literal_String" + + method loop_kind_ForIndexLoop ~start:_ ~end_:_ ~var:_ ~var_typ:_ + ~witness:_ = + default_document_for "loop_kind_ForIndexLoop" + + method loop_kind_ForLoop ~pat:_ ~it:_ ~witness:_ = + default_document_for "loop_kind_ForLoop" + + method loop_kind_UnconditionalLoop = + default_document_for "loop_kind_UnconditionalLoop" + + method loop_kind_WhileLoop ~condition:_ ~witness:_ = + default_document_for "loop_kind_WhileLoop" + + method loop_state ~init:_ ~bpat:_ ~witness:_ = + default_document_for "loop_state" + + method modul _x1 = default_document_for "modul" + + method param ~pat:_ ~typ:_ ~typ_span:_ ~attrs:_ = + default_document_for "param" + + method pat ~p:_ ~span:_ ~typ:_ = default_document_for "pat" + + method pat'_PAscription ~super:_ ~typ:_ ~typ_span:_ ~pat:_ = + default_document_for "pat'_PAscription" + + method pat'_PBinding ~super:_ ~mut:_ ~mode:_ ~var:_ ~typ:_ ~subpat:_ = + default_document_for "pat'_PBinding" + + method pat'_PConstant ~super:_ ~lit:_ = + default_document_for "pat'_PConstant" + + method pat'_PConstruct_inductive ~super:_ ~constructor:_ ~is_record:_ + ~is_struct:_ ~fields:_ = + default_document_for "pat'_PConstruct_inductive" + + method pat'_PConstruct_tuple ~super:_ ~components:_ = + default_document_for "pat'_PConstruct_tuple" + + method pat'_PDeref ~super:_ ~subpat:_ ~witness:_ = + default_document_for "pat'_PDeref" + + method pat'_PWild = default_document_for "pat'_PWild" + method printer_name = default_string_for "printer_name" + + method projection_predicate ~impl:_ ~assoc_item:_ ~typ:_ = + default_document_for "projection_predicate" + + method safety_kind_Safe = default_document_for "safety_kind_Safe" + method safety_kind_Unsafe _x1 = default_document_for "safety_kind_Unsafe" + + method supported_monads_MException _x1 = + default_document_for "supported_monads_MException" + + method supported_monads_MOption = + default_document_for "supported_monads_MOption" + + method supported_monads_MResult _x1 = + default_document_for "supported_monads_MResult" + + method trait_goal ~trait:_ ~args:_ = default_document_for "trait_goal" + + method trait_item ~ti_span:_ ~ti_generics:_ ~ti_v:_ ~ti_ident:_ + ~ti_attrs:_ = + default_document_for "trait_item" + + method trait_item'_TIDefault ~params:_ ~body:_ ~witness:_ = + default_document_for "trait_item'_TIDefault" + + method trait_item'_TIFn _x1 = default_document_for "trait_item'_TIFn" + method trait_item'_TIType _x1 = default_document_for "trait_item'_TIType" + + method ty_TApp_application ~typ:_ ~generics:_ = + default_document_for "ty_TApp_application" + + method ty_TApp_tuple ~types:_ = default_document_for "ty_TApp_tuple" + method ty_TArray ~typ:_ ~length:_ = default_document_for "ty_TArray" + method ty_TArrow _x1 _x2 = default_document_for "ty_TArrow" + + method ty_TAssociatedType ~impl:_ ~item:_ = + default_document_for "ty_TAssociatedType" + + method ty_TBool = default_document_for "ty_TBool" + method ty_TChar = default_document_for "ty_TChar" + method ty_TDyn ~witness:_ ~goals:_ = default_document_for "ty_TDyn" + method ty_TFloat _x1 = default_document_for "ty_TFloat" + method ty_TInt _x1 = default_document_for "ty_TInt" + method ty_TOpaque _x1 = default_document_for "ty_TOpaque" + method ty_TParam _x1 = default_document_for "ty_TParam" + method ty_TRawPointer ~witness:_ = default_document_for "ty_TRawPointer" + + method ty_TRef ~witness:_ ~region:_ ~typ:_ ~mut:_ = + default_document_for "ty_TRef" + + method ty_TSlice ~witness:_ ~ty:_ = default_document_for "ty_TSlice" + method ty_TStr = default_document_for "ty_TStr" + (* END GENERATED *) + end +end diff --git a/engine/lib/import_thir.ml b/engine/lib/import_thir.ml index 0dea69dbb..7b9202d1c 100644 --- a/engine/lib/import_thir.ml +++ b/engine/lib/import_thir.ml @@ -880,9 +880,9 @@ end) : EXPR = struct unimplemented ~issue_id:998 [ pat.span ] "Pattern match on union types: not supported" in - let name = def_id (Constructor { is_struct }) info.variant in - let args = List.map ~f:(c_field_pat info) subpatterns in - PConstruct { name; args; is_record; is_struct } + let constructor = def_id (Constructor { is_struct }) info.variant in + let fields = List.map ~f:(c_field_pat info) subpatterns in + PConstruct { constructor; fields; is_record; is_struct } | Tuple { subpatterns } -> (List.map ~f:c_pat subpatterns |> U.make_tuple_pat').p | Deref { subpattern } -> @@ -1379,12 +1379,12 @@ let cast_of_enum typ_name generics typ thir_span { is_record = variant.is_record; is_struct = false; - args = + fields = List.map ~f:(fun (cid, typ, _) -> { field = `Concrete cid; pat = { p = PWild; typ; span } }) variant.arguments; - name = `Concrete variant.name; + constructor = `Concrete variant.name; } in let pat = { p = pat; typ = self; span } in @@ -1674,7 +1674,7 @@ and c_item_unwrapped ~ident ~drop_body (item : Thir.item) : item list = generics = c_generics generics; self_ty = c_ty item.span self_ty; of_trait = - ( def_id Trait of_trait.def_id, + ( Concrete_ident.of_def_id Trait of_trait.def_id, List.map ~f:(c_generic_value item.span) of_trait.generic_args ); items = diff --git a/engine/lib/phases/phase_drop_match_guards.ml b/engine/lib/phases/phase_drop_match_guards.ml index ff5304d9a..d336e6ba1 100644 --- a/engine/lib/phases/phase_drop_match_guards.ml +++ b/engine/lib/phases/phase_drop_match_guards.ml @@ -120,7 +120,7 @@ module%inlined_contents Make (F : Features.T) = struct in let mk_opt_pattern (binding : B.pat option) : B.pat = - let (name : Concrete_ident.name), (args : B.field_pat list) = + let (name : Concrete_ident.name), (fields : B.field_pat list) = match binding with | Some b -> ( Core__option__Option__Some, @@ -128,9 +128,9 @@ module%inlined_contents Make (F : Features.T) = struct | None -> (Core__option__Option__None, []) in MS.pat_PConstruct - ~name: + ~constructor: (Global_ident.of_name (Constructor { is_struct = false }) name) - ~args ~is_record:false ~is_struct:false ~typ:opt_result_typ + ~fields ~is_record:false ~is_struct:false ~typ:opt_result_typ in let expr_none = mk_opt_expr None in diff --git a/engine/lib/phases/phase_hoist_disjunctive_patterns.ml b/engine/lib/phases/phase_hoist_disjunctive_patterns.ml index 332a094d8..cdec91d08 100644 --- a/engine/lib/phases/phase_hoist_disjunctive_patterns.ml +++ b/engine/lib/phases/phase_hoist_disjunctive_patterns.ml @@ -64,18 +64,18 @@ module Make (F : Features.T) = in match p.p with - | PConstruct { name; args; is_record; is_struct } -> - let args_as_pat = - List.rev_map args ~f:(fun arg -> self#visit_pat () arg.pat) + | PConstruct { constructor; fields; is_record; is_struct } -> + let fields_as_pat = + List.rev_map fields ~f:(fun arg -> self#visit_pat () arg.pat) in let subpats = - List.map (treat_args [ [] ] args_as_pat) - ~f:(fun args_as_pat -> - let args = - List.map2_exn args_as_pat args + List.map (treat_args [ [] ] fields_as_pat) + ~f:(fun fields_as_pat -> + let fields = + List.map2_exn fields_as_pat fields ~f:(fun pat { field; _ } -> { field; pat }) in - PConstruct { name; args; is_record; is_struct } + PConstruct { constructor; fields; is_record; is_struct } |> return_pat) in diff --git a/engine/lib/phases/phase_reconstruct_for_loops.ml b/engine/lib/phases/phase_reconstruct_for_loops.ml index a6b3c48b5..19e992497 100644 --- a/engine/lib/phases/phase_reconstruct_for_loops.ml +++ b/engine/lib/phases/phase_reconstruct_for_loops.ml @@ -131,10 +131,10 @@ struct p = PConstruct { - name = + constructor = `Concrete none_ctor; - args = + fields = []; _; }; @@ -180,10 +180,10 @@ struct p = PConstruct { - name = + constructor = `Concrete some_ctor; - args = + fields = [ { pat; diff --git a/engine/lib/phases/phase_reconstruct_question_marks.ml b/engine/lib/phases/phase_reconstruct_question_marks.ml index 1a4735b90..c7f88fd91 100644 --- a/engine/lib/phases/phase_reconstruct_question_marks.ml +++ b/engine/lib/phases/phase_reconstruct_question_marks.ml @@ -130,8 +130,8 @@ module%inlined_contents Make (FA : Features.T) = struct match p.p with | PConstruct { - name; - args = + constructor; + fields = [ { pat = @@ -145,7 +145,7 @@ module%inlined_contents Make (FA : Features.T) = struct ]; _; } -> - Some (name, var) + Some (constructor, var) | _ -> None in match e.e with diff --git a/engine/lib/phases/phase_simplify_question_marks.ml b/engine/lib/phases/phase_simplify_question_marks.ml index 4567ec48a..67ab9dfe0 100644 --- a/engine/lib/phases/phase_simplify_question_marks.ml +++ b/engine/lib/phases/phase_simplify_question_marks.ml @@ -111,17 +111,17 @@ module%inlined_contents Make (FA : Features.T) = struct let mk_pconstruct ~is_struct ~is_record ~span ~typ (constructor : Concrete_ident_generated.t) (fields : (Concrete_ident_generated.t * pat) list) = - let name = + let constructor = Global_ident.of_name (Constructor { is_struct }) constructor in - let args = + let fields = List.map ~f:(fun (field, pat) -> let field = Global_ident.of_name Field field in { field; pat }) fields in - let p = PConstruct { name; args; is_record; is_struct } in + let p = PConstruct { constructor; fields; is_record; is_struct } in { p; span; typ } (** [extract e] returns [Some (x, ty)] if [e] was a `y?` @@ -153,8 +153,8 @@ module%inlined_contents Make (FA : Features.T) = struct match p.p with | PConstruct { - name; - args = + constructor = name; + fields = [ { pat = diff --git a/engine/lib/phases/phase_transform_hax_lib_inline.ml b/engine/lib/phases/phase_transform_hax_lib_inline.ml index d2b2a4527..3005fddaa 100644 --- a/engine/lib/phases/phase_transform_hax_lib_inline.ml +++ b/engine/lib/phases/phase_transform_hax_lib_inline.ml @@ -52,7 +52,7 @@ module%inlined_contents Make (F : Features.T) = struct arm = { arm_pat = - { p = PConstruct { args = [ arg ]; _ }; _ }; + { p = PConstruct { fields = [ arg ]; _ }; _ }; _; }; _; diff --git a/engine/lib/print_rust.ml b/engine/lib/print_rust.ml index bea5c641a..1fb6f9a78 100644 --- a/engine/lib/print_rust.ml +++ b/engine/lib/print_rust.ml @@ -195,21 +195,21 @@ module Raw = struct | PWild -> !"_" | PAscription { typ; pat; _ } -> !"pat_ascription!(" & ppat pat & !" as " & pty e.span typ & !")" - | PConstruct { name; args; is_record; _ } -> - pglobal_ident e.span name + | PConstruct { constructor; fields; is_record; _ } -> + pglobal_ident e.span constructor & - if List.is_empty args then !"" + if List.is_empty fields then !"" else if is_record then !"{" & concat ~sep:!", " (List.map ~f:(fun { field; pat } -> !(last_of_global_ident field e.span) & !":" & ppat pat) - args) + fields) & !"}" else !"(" - & concat ~sep:!", " (List.map ~f:(fun { pat; _ } -> ppat pat) args) + & concat ~sep:!", " (List.map ~f:(fun { pat; _ } -> ppat pat) fields) & !")" | POr { subpats } -> concat ~sep:!" | " (List.map ~f:ppat subpats) | PArray { args } -> !"[" & concat ~sep:!"," (List.map ~f:ppat args) & !"]" @@ -344,7 +344,7 @@ module Raw = struct | None -> main) | Break { e; _ } -> !"(break (" & pexpr e & !"))" | Continue { e = None; _ } -> !"continue" - | Continue { e = Some (_, e); _ } -> + | Continue { e = Some (e, _); _ } -> !"state_passing_continue!(" & pexpr e & !")" | Return { e; _ } -> !"(return " & pexpr e & !")" | QuestionMark { e; _ } -> !"(" & pexpr e & !")?" @@ -576,7 +576,7 @@ module Raw = struct | Impl { generics; self_ty; of_trait; items; parent_bounds = _; safety } -> let trait = - pglobal_ident e.span (fst of_trait) + pglobal_ident e.span (`Concrete (fst of_trait)) & !"<" & concat ~sep:!"," (List.map ~f:(pgeneric_value e.span) (snd of_trait)) @@ -661,37 +661,82 @@ let rustfmt_annotated (x : AnnotatedString.t) : AnnotatedString.t = if String.equal rf "no" then x else try rustfmt_annotated' x with RetokenizationFailure -> x -let pitem : item -> AnnotatedString.Output.t = - Raw.pitem >> rustfmt_annotated >> AnnotatedString.Output.convert - -let pitems : item list -> AnnotatedString.Output.t = - List.concat_map ~f:Raw.pitem - >> rustfmt_annotated >> AnnotatedString.Output.convert - -let pitem_str : item -> string = pitem >> AnnotatedString.Output.raw_string - -let pty_str (e : ty) : string = - let e = Raw.pty (Span.dummy ()) e in - let ( ! ) = AnnotatedString.pure @@ Span.dummy () in - let ( & ) = AnnotatedString.( & ) in - let prefix = "type TypeWrapper = " in - let suffix = ";" in - let item = !prefix & e & !suffix in - rustfmt_annotated item |> AnnotatedString.Output.convert - |> AnnotatedString.Output.raw_string |> Stdlib.String.trim - |> String.chop_suffix_if_exists ~suffix - |> String.chop_prefix_if_exists ~prefix - |> Stdlib.String.trim - -let pexpr_str (e : expr) : string = - let e = Raw.pexpr e in - let ( ! ) = AnnotatedString.pure @@ Span.dummy () in - let ( & ) = AnnotatedString.( & ) in - let prefix = "fn expr_wrapper() {" in - let suffix = "}" in - let item = !prefix & e & !suffix in - rustfmt_annotated item |> AnnotatedString.Output.convert - |> AnnotatedString.Output.raw_string |> Stdlib.String.trim - |> String.chop_suffix_if_exists ~suffix - |> String.chop_prefix_if_exists ~prefix - |> Stdlib.String.trim +module type T = sig + val pitem : item -> AnnotatedString.Output.t + val pitems : item list -> AnnotatedString.Output.t + val pitem_str : item -> string + val pexpr_str : expr -> string + val pty_str : ty -> string +end + +module Traditional : T = struct + let pitem : item -> AnnotatedString.Output.t = + Raw.pitem >> rustfmt_annotated >> AnnotatedString.Output.convert + + let pitems : item list -> AnnotatedString.Output.t = + List.concat_map ~f:Raw.pitem + >> rustfmt_annotated >> AnnotatedString.Output.convert + + let pitem_str : item -> string = pitem >> AnnotatedString.Output.raw_string + + let pexpr_str (e : expr) : string = + let e = Raw.pexpr e in + let ( ! ) = AnnotatedString.pure @@ Span.dummy () in + let ( & ) = AnnotatedString.( & ) in + let prefix = "fn expr_wrapper() {" in + let suffix = "}" in + let item = !prefix & e & !suffix in + rustfmt_annotated item |> AnnotatedString.Output.convert + |> AnnotatedString.Output.raw_string |> Stdlib.String.trim + |> String.chop_suffix_if_exists ~suffix + |> String.chop_prefix_if_exists ~prefix + |> Stdlib.String.trim + + let pty_str (e : ty) : string = + let e = Raw.pty (Span.dummy ()) e in + let ( ! ) = AnnotatedString.pure @@ Span.dummy () in + let ( & ) = AnnotatedString.( & ) in + let prefix = "type TypeWrapper = " in + let suffix = ";" in + let item = !prefix & e & !suffix in + rustfmt_annotated item |> AnnotatedString.Output.convert + |> AnnotatedString.Output.raw_string |> Stdlib.String.trim + |> String.chop_suffix_if_exists ~suffix + |> String.chop_prefix_if_exists ~prefix + |> Stdlib.String.trim +end + +(* module Experimental : T = struct *) +(* module GenericRustPrinter = Generic_rust_printer.Make (Features.Full) *) + +(* let pitem : item -> AnnotatedString.Output.t = *) +(* GenericRustPrinter.item () *) +(* >> Generic_printer_api.AnnotatedString.to_spanned_strings *) +(* >> AnnotatedString.Output.convert *) + +(* let pitems : item list -> AnnotatedString.Output.t = *) +(* GenericRustPrinter.items () *) +(* >> Generic_printer_api.AnnotatedString.to_spanned_strings *) +(* >> AnnotatedString.Output.convert *) + +(* let pexpr : expr -> AnnotatedString.Output.t = *) +(* GenericRustPrinter.expr () *) +(* >> Generic_printer_api.AnnotatedString.to_spanned_strings *) +(* >> AnnotatedString.Output.convert *) + +(* let pitem_str : item -> string = *) +(* GenericRustPrinter.item () >> Generic_printer_api.AnnotatedString.to_string *) + +(* let pexpr_str : expr -> string = *) +(* GenericRustPrinter.expr () >> Generic_printer_api.AnnotatedString.to_string *) + +(* let pty_str : ty -> string = *) +(* GenericRustPrinter.ty () >> Generic_printer_api.AnnotatedString.to_string *) +(* end *) + +let experimental = + Sys.getenv "HAX_ENGINE_EXPERIMENTAL_RUST_PRINTER" |> Option.is_some + +include + (val if experimental then failwith "todo" (*module Experimental : T*) + else (module Traditional : T)) diff --git a/engine/lib/side_effect_utils.ml b/engine/lib/side_effect_utils.ml index 79f66fb0e..820ce0d7f 100644 --- a/engine/lib/side_effect_utils.ml +++ b/engine/lib/side_effect_utils.ml @@ -271,16 +271,16 @@ struct no_lbs { SideEffects.zero with - continue = Some (Option.map ~f:(fun (_, e) -> e.typ) e'); + continue = Some (Option.map ~f:(fun (e, _) -> e.typ) e'); } in match e' with - | Some (witness', e') -> + | Some (e', witness') -> HoistSeq.one env (self#visit_expr env e') (fun e' effects -> ( { e with e = - Continue { e = Some (witness', e'); label; witness }; + Continue { e = Some (e', witness'); label; witness }; }, m#plus ceffect effects )) | None -> (e, ceffect)) diff --git a/engine/lib/subtype.ml b/engine/lib/subtype.ml index 5c4656e5b..0e2c8fbff 100644 --- a/engine/lib/subtype.ml +++ b/engine/lib/subtype.ml @@ -121,13 +121,13 @@ struct | PWild -> PWild | PAscription { typ; typ_span; pat } -> PAscription { typ = dty span typ; pat = dpat pat; typ_span } - | PConstruct { name; args; is_record; is_struct } -> + | PConstruct { constructor; is_record; is_struct; fields } -> PConstruct { - name; - args = List.map ~f:(dfield_pat span) args; + constructor; is_record; is_struct; + fields = List.map ~f:(dfield_pat span) fields; } | POr { subpats } -> POr { subpats = List.map ~f:dpat subpats } | PArray { args } -> PArray { args = List.map ~f:dpat args } @@ -264,7 +264,7 @@ struct | Continue { e; label; witness = w1, w2 } -> Continue { - e = Option.map ~f:(S.state_passing_loop span *** dexpr) e; + e = Option.map ~f:(dexpr *** S.state_passing_loop span) e; label; witness = (S.continue span w1, S.loop span w2); } diff --git a/engine/utils/generate_from_ast/codegen_printer.ml b/engine/utils/generate_from_ast/codegen_printer.ml new file mode 100644 index 000000000..58b3368ed --- /dev/null +++ b/engine/utils/generate_from_ast/codegen_printer.ml @@ -0,0 +1,410 @@ +open Base +open Utils +open Types + +type state = { names_with_doc : string list } + +let ( let* ) x f = Option.bind ~f x +let super_types_list = [ "expr"; "pat"; "guard"; "arm"; "item" ] + +let get_super_type ty = + List.find ~f:(fun s -> String.equal (s ^ "'") ty) super_types_list + +let get_child_type ty = + if List.mem ~equal:String.equal super_types_list ty then Some (ty ^ "'") + else None + +let do_not_override_prefix = "_do_not_override_" + +let is_hidden_method = + let list = + [ + "expr'_App"; + "expr'_Construct"; + "ty_TApp"; + "lhs_LhsFieldAccessor"; + "local_ident"; + "pat'_PConstruct"; + "expr'_GlobalVar"; + "variant"; + ] + in + List.mem ~equal:[%eq: string] list + +let lazy_doc_manual_definitions = [ "_do_not_override_lazy_of_generics" ] + +let rec of_ty (state : state) (call_method : string -> ty:string -> string) + (t : Type.t) : ((unit -> string) -> string -> string) option = + let* args = + List.fold t.args ~init:(Some []) ~f:(fun acc x -> + let* acc = acc in + let* x = of_ty state call_method x in + Some (x :: acc)) + |> Option.map ~f:List.rev + in + match (t.typ, args) with + | "option", [ inner ] -> + Some + (fun pos value -> + "(match " ^ value ^ " with | None -> None | Some value -> Some (" + ^ inner pos "value" ^ "))") + | "list", [ inner ] -> + Some + (fun pos value -> + "(List.map ~f:(fun x -> " ^ inner pos "x" ^ ") " ^ value ^ ")") + | "prim___tuple_2", [ fst; snd ] -> + Some + (fun pos value -> + let base = + "(" + ^ fst pos ("(fst " ^ value ^ ")") + ^ "," + ^ snd pos ("(snd " ^ value ^ ")") + ^ ")" + in + let mk proj = + "(let x = " ^ base ^ "in lazy_doc (fun tuple -> (" ^ proj + ^ " tuple)#p) " ^ pos () ^ " x)" + in + match List.map ~f:(is_lazy_doc_typ state) t.args with + | [ false; true ] -> mk "snd" + | [ true; false ] -> mk "fst" + | _ -> base) + (* if String.is_prefix ~prefix:"F." (List.nth t.args 1 |> Option.value ~default:"") then "(let x = " ^ base ^ "in lazy_doc x)" else base) *) + | "prim___tuple_3", [ fst; snd; thd ] -> + Some + (fun pos value -> + "(let (value1, value2, value3) = " ^ value ^ " in (" + ^ fst pos "value1" ^ "," ^ snd pos "value2" ^ "," ^ thd pos "value3" + ^ "))") + | _ when List.mem ~equal:[%eq: string] state.names_with_doc t.typ -> + Some + (fun pos value -> + "(print#" ^ do_not_override_prefix ^ "lazy_of_" ^ t.typ + ^ (if Option.is_some (get_super_type t.typ) then " ~super" else "") + ^ " " ^ pos () ^ " " ^ value ^ ")") + | _ -> Some (fun pos value -> "(" ^ value ^ ")") + +and string_ty_of_ty' (state : state) (t : Type.t) = + if String.is_prefix t.typ ~prefix:"prim___tuple_" then + let args = List.map t.args ~f:(string_ty_of_ty' state) in + let n = List.count args ~f:(String.is_suffix ~suffix:"lazy_doc)") in + let base = + "(" + ^ String.concat ~sep:" * " (List.map t.args ~f:(string_ty_of_ty' state)) + ^ ")" + in + if [%eq: int] n 1 then "(" ^ base ^ " lazy_doc)" else base + else + "(" + ^ (if List.is_empty t.args then "" + else + "(" + ^ String.concat ~sep:", " (List.map t.args ~f:(string_ty_of_ty' state)) + ^ ") ") + ^ t.typ + ^ (if List.mem ~equal:[%eq: string] state.names_with_doc t.typ then + " lazy_doc" + else "") + ^ ")" + +and is_lazy_doc_typ (state : state) = string_ty_of_ty' state >> is_lazy_doc_typ' +and is_lazy_doc_typ' = String.is_suffix ~suffix:"lazy_doc)" + +let string_ty_of_ty (state : state) (t : Type.t) = + let s = string_ty_of_ty' state t in + match s with + | "(generics lazy_doc)" -> + "((generics lazy_doc * generic_param lazy_doc list * generic_constraint \ + lazy_doc list) lazy_doc)" + | _ -> s + +let meth_name' typ_name variant_name = + typ_name ^ if String.is_empty variant_name then "" else "_" ^ variant_name + +let meth_name typ_name variant_name = + let meth = meth_name' typ_name variant_name in + (if is_hidden_method meth then do_not_override_prefix else "") ^ meth + +let print_variant state (call_method : string -> ty:string -> string) + (register_position : string option -> string) (super_type : string option) + (register_signature : string -> unit) (t_name : string) (v : Variant.t) : + string = + let meth_name = meth_name t_name v.name in + let meth = "print#" ^ meth_name in + let mk named fields = + let head = + v.name + ^ (if named then " { " else " ( ") + ^ String.concat ~sep:(if named then ";" else ",") (List.map ~f:fst fields) + ^ (if named then " } " else ")") + ^ " -> " + in + let args = + List.map + ~f:(fun (field_name, ty) -> + let value = + match of_ty state call_method ty with + | Some f -> + let pos = register_position (Some field_name) in + f (fun _ -> pos) field_name + | None -> field_name + in + let name = "~" ^ field_name ^ ":" in + (if named then name else "") ^ "(" ^ value ^ ")") + fields + in + let call = + String.concat ~sep:" " + (meth + :: ((if Option.is_some super_type then [ "~super" ] else []) @ args)) + in + let signature = + let ty = + List.map + ~f:(fun (name, ty) -> + let name = if named then name ^ ":" else "" in + name ^ string_ty_of_ty state ty) + fields + |> String.concat ~sep:" -> " + in + let super = + match super_type with + | Some super_type -> " super:(" ^ super_type ^ ") -> " + | None -> "" + in + register_signature + ("method virtual " ^ meth_name ^ " : " ^ super ^ ty ^ " -> document") + in + head ^ call + in + "\n | " + ^ + match v.payload with + | Record fields -> mk true fields + | None -> v.name ^ " -> " ^ meth + | Tuple types -> + mk false (List.mapi ~f:(fun i ty -> ("x" ^ Int.to_string i, ty)) types) + +let catch_errors_for = [ "expr"; "item"; "pat" ] + +let print_datatype state (dt : Datatype.t) + (register_entrypoint : string -> unit) + (register_position : string -> string -> string option -> string) = + let super_type = get_super_type dt.name in + let sigs = ref [] in + let method_name = do_not_override_prefix ^ "lazy_of_" ^ dt.name in + let print_variants variants wrapper = + let head = + "(**/**) method " ^ method_name + ^ (match super_type with Some t -> " ~(super: " ^ t ^ ")" | _ -> "") + ^ " ast_position (value: " ^ dt.name ^ "): " ^ dt.name ^ " lazy_doc =" + in + let body = + (if Option.is_some (get_child_type dt.name) then + "\n let super = value in" + else "") + ^ "\n match value with" + ^ String.concat ~sep:"" + (List.map + ~f:(fun variant -> + print_variant state + (fun name ~ty:_ -> name) + (register_position dt.name variant.Variant.name) + super_type + (fun s -> sigs := s :: !sigs) + dt.name variant) + variants) + in + let body = + "(print#wrap_" ^ dt.name ^ " ast_position value (" ^ body ^ "))" + in + let body = wrapper body in + sigs := + ("method wrap_" ^ dt.name ^ " (_pos: ast_position) (_value: " ^ dt.name + ^ ") (doc: document): document = doc") + :: !sigs; + let def = + head ^ "lazy_doc (fun (value: " ^ dt.name ^ ") -> " ^ body + ^ ") ast_position value" + in + if List.mem ~equal:[%eq: string] lazy_doc_manual_definitions method_name + then "(* skipping " ^ method_name ^ " *) (**/**)" + else def ^ "(**/**)" + in + let main = + match dt.kind with + | Variant variants -> print_variants variants Fn.id + | Record record -> + let wrapper = + if List.exists ~f:(fst >> [%eq: string] "span") record then + fun body -> + "print#with_span ~span:value.span (fun _ -> " ^ body ^ ")" + else Fn.id + in + let wrapper = + if List.mem ~equal:[%eq: string] catch_errors_for dt.name then + fun body -> + "print#catch_exn print#error_" ^ dt.name ^ " (fun () -> " + ^ wrapper body ^ ")" + else wrapper + in + print_variants [ { name = ""; payload = Record record } ] wrapper + | TypeSynonym ty -> + print_variants [ { name = ""; payload = Tuple [ ty ] } ] (fun x -> x) + | _ -> "(* Not translating " ^ dt.name ^ " *)" + in + let print = + let name = "print_" ^ dt.name in + let ty = "ast_position -> " ^ dt.name ^ " -> " in + let body = + "fun ast_position x -> (print#" ^ method_name ^ " ast_position x)#p" + in + if Option.is_none super_type then + "method " ^ name ^ ": " ^ ty ^ " document = " ^ body + else "" + in + let entrypoint = + let name = "entrypoint_" ^ dt.name in + let ty = dt.name ^ " -> " in + let body = "print#print_" ^ dt.name ^ " AstPos_Entrypoint" in + if Option.is_none super_type then ( + register_entrypoint (name ^ " : " ^ ty ^ " 'a"); + "method " ^ name ^ ": " ^ ty ^ " document = " ^ body) + else "" + in + String.concat ~sep:"\n\n" (main :: print :: entrypoint :: !sigs) + +let hardcoded = + {| +module LazyDoc = struct + type 'a lazy_doc = + < compact : output -> unit + ; pretty : output -> state -> int -> bool -> unit + ; requirement : int + ; p : document + ; v : 'a + ; ast_position : ast_position > + let lazy_doc : 'a. ('a -> document) -> ast_position -> 'a -> 'a lazy_doc = + fun to_document pos value -> + let lazy_doc = ref None in + let doc () = + match !lazy_doc with + | None -> + let doc = to_document value in + lazy_doc := Some doc; + doc + | Some doc -> doc + in + object (self) + method requirement : requirement = requirement (doc ()) + method pretty : output -> state -> int -> bool -> unit = + fun o s i b -> pretty o s i b (doc ()) + method compact : output -> unit = fun o -> compact o (doc ()) + method p = custom (self :> custom) + method v = value + method ast_position = pos + end +end +open LazyDoc +|} + +let class_prelude = + {| + method virtual with_span: span:span -> (unit -> document) -> document + method virtual catch_exn : (string -> document) -> (unit -> document) -> document + + method virtual _do_not_override_lazy_of_local_ident: _ + method virtual _do_not_override_lazy_of_concrete_ident: _ +|} + +let mk datatypes = + let datatypes = + List.filter + ~f:(fun dt -> not ([%eq: string] dt.Datatype.name "mutability")) + datatypes + in + let state = + let names_with_doc = List.map ~f:(fun dt -> dt.name) datatypes in + let names_with_doc = + "quote" :: "concrete_ident" :: "local_ident" :: names_with_doc + in + { names_with_doc } + in + let positions = ref [ "AstPos_Entrypoint"; "AstPos_NotApplicable" ] in + let entrypoint_types = ref [] in + let class_body = + List.map + ~f:(fun dt -> + print_datatype state dt + (fun x -> entrypoint_types := x :: !entrypoint_types) + (fun ty variant field -> + let pos = + "AstPos_" ^ ty ^ "_" ^ variant + ^ match field with Some field -> "_" ^ field | _ -> "" + in + positions := pos :: !positions; + pos)) + datatypes + |> String.concat ~sep:"\n\n" + in + let object_poly = String.concat ~sep:";\n " !entrypoint_types in + let object_span_data_map = + String.concat ~sep:"\n" + (List.map + ~f:(fun s -> + let n = fst (String.lsplit2_exn ~on:':' s) in + "method " ^ n ^ " = obj#" ^ n) + !entrypoint_types) + in + let object_map = + String.concat ~sep:"\n" + (List.map + ~f:(fun s -> + let n = fst (String.lsplit2_exn ~on:':' s) in + "method " ^ n ^ " x = f (fun obj -> obj#" ^ n ^ " x)") + !entrypoint_types) + in + Printf.sprintf + {| +open! Prelude +open! Ast +open PPrint +type ast_position = %s | AstPosition_Quote + +%s + +module Make (F : Features.T) = struct + module AST = Ast.Make (F) + open Ast.Make (F) + + class virtual base = object (print) + %s + end + + type ('get_span_data, 'a) object_type = < + get_span_data : 'get_span_data; + %s + > + + let map (type get_span_data) (type a) (type b) + (f: ((get_span_data, a) object_type -> a) -> b) + : (unit, b) object_type = object + method get_span_data: unit = () + %s + end + + let map_get_span_data (type a) (type b) (type t) + (obj: (a, t) object_type) + (get_span_data: b) + : (b, t) object_type = object + method get_span_data: b = get_span_data + %s + end +end +|} + (String.concat ~sep:" | " + (List.dedup_and_sort ~compare:String.compare !positions)) + hardcoded + (class_prelude ^ class_body) + object_poly object_map object_span_data_map diff --git a/engine/utils/generate_from_ast/generate_from_ast.ml b/engine/utils/generate_from_ast/generate_from_ast.ml index 9bc114e5c..7526afa76 100644 --- a/engine/utils/generate_from_ast/generate_from_ast.ml +++ b/engine/utils/generate_from_ast/generate_from_ast.ml @@ -33,6 +33,7 @@ let _main = |> match Sys.get_argv () with | [| _; "visitors" |] -> Codegen_visitor.mk + | [| _; "printer" |] -> Codegen_printer.mk | [| _; "ast_builder" |] -> Codegen_ast_builder.mk | [| _; "ast_destruct" |] -> Codegen_ast_destruct.mk | [| _; "json" |] -> diff --git a/engine/utils/sourcemaps/base64.ml b/engine/utils/sourcemaps/base64.ml new file mode 100644 index 000000000..064b85a61 --- /dev/null +++ b/engine/utils/sourcemaps/base64.ml @@ -0,0 +1,10 @@ +open Prelude + +let alphabet = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +let encode (n : int) : char = + assert (n >= 0 && n < 64); + String.get alphabet n + +let decode (c : char) : int = String.index alphabet c |> Option.value_exn diff --git a/engine/utils/sourcemaps/dune b/engine/utils/sourcemaps/dune new file mode 100644 index 000000000..cf4e7dc83 --- /dev/null +++ b/engine/utils/sourcemaps/dune @@ -0,0 +1,9 @@ +(library + (name sourcemaps) + (package hax-engine) + (inline_tests) + (preprocess + (pps ppx_inline_test ppx_yojson_conv ppx_deriving.show ppx_deriving.eq)) + (libraries base)) + +(include_subdirs unqualified) diff --git a/engine/utils/sourcemaps/location.ml b/engine/utils/sourcemaps/location.ml new file mode 100644 index 000000000..cf2bda904 --- /dev/null +++ b/engine/utils/sourcemaps/location.ml @@ -0,0 +1,22 @@ +open Prelude + +type t = { line : int; col : int } [@@deriving eq] + +let show { line; col } = + "(" ^ Int.to_string line ^ ":" ^ Int.to_string col ^ ")" + +let pp (fmt : Stdlib.Format.formatter) (s : t) : unit = + Stdlib.Format.pp_print_string fmt @@ show s + +let default = { line = 0; col = 0 } +let plus_cols x cols = { x with col = x.col + cols } +let op ( + ) x y = { line = x.line + y.line; col = x.col + y.col } +let ( + ) = op ( + ) +let ( - ) = op ( - ) + +let compare (x : t) (y : t) : int = + let open Int in + if x.line > y.line then 1 + else if x.line = y.line then + if x.col > y.col then 1 else if x.col = y.col then 0 else -1 + else -1 diff --git a/engine/utils/sourcemaps/mappings/dual.ml b/engine/utils/sourcemaps/mappings/dual.ml new file mode 100644 index 000000000..09548fd9f --- /dev/null +++ b/engine/utils/sourcemaps/mappings/dual.ml @@ -0,0 +1,10 @@ +type 'a t = { gen : 'a; src : 'a } [@@deriving show, eq] + +let transpose ~(default : 'a t) ({ gen; src } : 'a option t) : 'a t option = + match (gen, src) with + | Some gen, None -> Some { gen; src = default.src } + | None, Some src -> Some { gen = default.gen; src } + | Some gen, Some src -> Some { gen; src } + | _ -> None + +let default (type a) (default : a) : a t = { gen = default; src = default } diff --git a/engine/utils/sourcemaps/mappings/instruction.ml b/engine/utils/sourcemaps/mappings/instruction.ml new file mode 100644 index 000000000..966e4cba3 --- /dev/null +++ b/engine/utils/sourcemaps/mappings/instruction.ml @@ -0,0 +1,104 @@ +open Prelude +open Types + +type t = + | ShiftGenLinesResetGenCols of { lines : int } + | ShiftGenCols of int + | Full of { shift_gen_col : int; shift_src : Location.t; meta : meta } +[@@deriving show { with_path = false }, eq] + +let encode_one : t -> string * [ `Sep | `NeedsSep ] = function + | ShiftGenLinesResetGenCols { lines } -> + Stdlib.prerr_endline ("lines:::" ^ Int.to_string lines); + (String.make lines ';', `Sep) + | ShiftGenCols n -> (Vql.encode_base64 [ n ], `NeedsSep) + | Full { shift_gen_col; shift_src; meta = { file_offset; name } } -> + ( Vql.encode_base64 + ([ shift_gen_col; file_offset; shift_src.line; shift_src.col ] + @ match name with Some name -> [ name ] | None -> []), + `NeedsSep ) + +let encode : t list -> string = + List.map ~f:encode_one + >> List.fold_left + ~f:(fun (acc, sep) (str, sep') -> + let acc = + acc + ^ + match (sep, sep') with `NeedsSep, `NeedsSep -> "," ^ str | _ -> str + in + (acc, sep')) + ~init:("", `Sep) + >> fst + +let decode_one (s : string) : t = + match Vql.decode_base64 s with + | [ cols ] -> ShiftGenCols cols + | shift_gen_col :: file_offset :: line :: col :: rest -> + let name = match rest with [ name ] -> Some name | _ -> None in + let meta = { file_offset; name } in + let shift_src : Location.t = { line; col } in + Full { shift_gen_col; shift_src; meta } + | _ -> failwith "??" + +let rec decode' (s : string) : t option list = + if String.is_empty s then [] + else + let n = + String.lfindi ~f:(fun _ -> function ';' | ',' -> true | _ -> false) s + |> Option.value ~default:(String.length s) + in + (if n > 0 then Some (decode_one (String.prefix s n)) + else + match String.get s 0 with + | ';' -> Some (ShiftGenLinesResetGenCols { lines = 1 }) + | ',' -> None + | _ -> failwith "should not be possible") + :: decode' (String.drop_prefix s (Int.max 1 n)) + +let decode : string -> t list = decode' >> List.filter_map ~f:Fn.id + +let eval_one (s : Location.t Dual.t) (i : t) : Location.t Dual.t * meta option = + match i with + | ShiftGenLinesResetGenCols { lines } -> + ({ s with gen = { line = s.gen.line + lines; col = 0 } }, None) + | ShiftGenCols i -> ({ s with gen = Location.plus_cols s.gen i }, None) + | Full { shift_gen_col; shift_src; meta } -> + let gen = Location.plus_cols s.gen shift_gen_col in + let src = Location.(s.src + shift_src) in + ({ gen; src }, Some meta) + +let to_points ?(init = Dual.default Location.default) : t list -> point list = + List.fold_left ~init:(init, []) ~f:(fun (s, acc) i -> + let s, r = eval_one s i in + (s, (s, r) :: acc)) + >> snd >> List.rev + +let from_points : point list -> t list = + List.folding_map ~init:(Dual.default Location.default) + ~f:(fun { src; gen } (x, m) -> + let d = + Location.(Dual.{ Dual.src = x.src - src; Dual.gen = x.gen - gen }) + in + let shift_gen_col = (if Int.(d.gen.line = 0) then d else x).gen.col in + let output = + (if Int.(d.gen.line = 0) then [] + else [ ShiftGenLinesResetGenCols { lines = d.gen.line } ]) + @ + match m with + | Some meta -> [ Full { shift_gen_col; shift_src = d.src; meta } ] + | None when Int.(shift_gen_col = 0) -> [] + | _ -> [ ShiftGenCols shift_gen_col ] + in + let x = match m with Some _ -> x | None -> { x with src } in + (x, output)) + >> List.concat + +let%test _ = + let f = decode >> to_points >> from_points >> encode in + [ + ";AAAA,SAAS,KAAAA,GAAG,YAAAC,GAAU,UAAAC,SAAc;;;ACApC,SAAS,KAAAC,GAAG,aAAAC,SAAiB;AAC7B,SAAS,YAAAC,SAAgB;AAWlB,IAAMC,IAAN,cAA2BF,EAAsC;AAAA,EAGtE,YAAYG,GAAqB;AAC/B,UAAMA,CAAK;AAIb,SAAAC,IAAa,MAAM,KAAK,SAAS,EAAEC,GAAQ,KAAK,MAAMA,IAAS,EAAE,CAAC;AAClE,SAAAC,IAAa,MAAM,KAAK,SAAS,EAAED,GAAQ,KAAK,MAAMA,IAAS,EAAE,CAAC;AAJhE,SAAK,MAAMA,IAASF,EAAMI;AAAA,EAC5B;AAAA,EAKA,SAAS;AACP,WAAOR,EAAC;AAAA,MAAI,OAAM;AAAA,OAChBA,EAAC,YAAI,KAAK,MAAM,KAAM,GACtBA,EAAC,WACCA,EAAC;AAAA,MAAO,SAAS,KAAKO;AAAA,OAAY,GAAC,GAClC,KACA,KAAK,MAAMD,GACX,KACDN,EAAC;AAAA,MAAO,SAAS,KAAKK;AAAA,OAAY,GAAC,CACrC,CACF;AAAA,EACF;AACF,GAEWI,IAAkB,CAACL,MAAwB;AACpD,MAAI,CAACM,GAAOC,CAAQ,IAAIT,EAASE,EAAMI,CAAa;AACpD,SAAOR,EAAC;AAAA,IAAI,OAAM;AAAA,KAChBA,EAAC,YAAII,EAAMQ,CAAO,GAClBZ,EAAC,WACCA,EAAC;AAAA,IAAO,SAAS,MAAMW,EAASD,IAAQ,CAAC;AAAA,KAAG,GAAC,GAC5C,KACAA,GACA,KACDV,EAAC;AAAA,IAAO,SAAS,MAAMW,EAASD,IAAQ,CAAC;AAAA,KAAG,GAAC,CAC/C,CACF;AACF;;;AD9CAG;AAAA,EACEC,EAAAC,GAAA,MACED,EAACE,GAAA;AAAA,IAAaC,GAAO;AAAA,IAAYC,GAAe;AAAA,GAAK,GACrDJ,EAACK,GAAA;AAAA,IAAgBF,GAAO;AAAA,IAAYC,GAAe;AAAA,GAAK,CAC1D;AAAA,EACA,SAAS,eAAe,MAAM;AAChC;"; + ] + |> List.for_all ~f:(fun s -> String.equal s (f s)) + +let from_spanned : Spanned.t list -> t list = Spanned.to_points >> from_points diff --git a/engine/utils/sourcemaps/mappings/mappings.ml b/engine/utils/sourcemaps/mappings/mappings.ml new file mode 100644 index 000000000..67fb40347 --- /dev/null +++ b/engine/utils/sourcemaps/mappings/mappings.ml @@ -0,0 +1,41 @@ +open Prelude +include Types + +type range = { start : Location.t; end_ : Location.t option } +[@@deriving show, eq] + +module Chunk = struct + type t = { gen : range; src : range; meta : meta } [@@deriving show, eq] + + let compare (x : t) (y : t) = Location.compare x.gen.start y.gen.start + + let from_spanned ((start, end_, meta) : Spanned.t) : t = + let gen = { start = start.gen; end_ = end_.gen } in + let src = { start = start.src; end_ = end_.src } in + { gen; src; meta } + + let to_spanned ({ gen; src; meta } : t) : Spanned.t = + ( { gen = gen.start; src = src.start }, + { gen = gen.end_; src = src.end_ }, + meta ) + + let%test _ = + let x = ";AAAA,SAAS,KAAAA,GAAG,YAAAC,GAAU" in + let s = Instruction.(decode x |> to_points) |> Spanned.from_points in + [%eq: Spanned.t list] (List.map ~f:(from_spanned >> to_spanned) s) s + + let decode : string -> t list = + Instruction.(decode >> to_points >> Spanned.from_points) + >> List.map ~f:from_spanned + + let encode : t list -> string = + List.map ~f:to_spanned >> Instruction.from_spanned >> Instruction.encode + + let%test _ = + let x = + ";AAAA,SAAS,KAAAA,GAAG,YAAAC,GAAU,UAAAC,SAAc;;;ACApC,SAAS,KAAAC,GAAG,aAAAC,SAAiB;AAC7B,SAAS,YAAAC,SAAgB;AAWlB,IAAMC,IAAN,cAA2BF,EAAsC" + in + decode x |> encode |> [%eq: string] x +end + +include Chunk diff --git a/engine/utils/sourcemaps/mappings/mappings.mli b/engine/utils/sourcemaps/mappings/mappings.mli new file mode 100644 index 000000000..7bc0e9d55 --- /dev/null +++ b/engine/utils/sourcemaps/mappings/mappings.mli @@ -0,0 +1,13 @@ +type meta = { file_offset : int; name : int option } [@@deriving show, eq] +type range = { start : Location.t; end_ : Location.t option } + +module Chunk : sig + type t = { gen : range; src : range; meta : meta } [@@deriving show, eq] + + val compare : t -> t -> int +end + +open Chunk + +val decode : string -> t list +val encode : t list -> string diff --git a/engine/utils/sourcemaps/mappings/spanned.ml b/engine/utils/sourcemaps/mappings/spanned.ml new file mode 100644 index 000000000..965485025 --- /dev/null +++ b/engine/utils/sourcemaps/mappings/spanned.ml @@ -0,0 +1,44 @@ +open Prelude +open Types + +type t = Location.t Dual.t * Location.t option Dual.t * meta +[@@deriving show, eq] + +let to_points (pts : t list) : point list = + List.map pts ~f:Option.some + |> Fn.flip List.append [ None ] + |> List.folding_map ~init:None ~f:(fun acc x -> + let prev_end = + match (acc, x) with + | Some end_, Some (start, _, _) + when [%eq: Location.t] start.Dual.gen end_.Dual.gen |> not -> + Some end_ + | Some end_, None -> Some end_ + | _ -> None + in + let out, end_ = + match x with + | Some (start, end_, meta) -> + ([ (start, Some meta) ], Dual.transpose ~default:start end_) + | None -> ([], None) + in + ( end_, + (prev_end |> Option.map ~f:(fun e -> (e, None)) |> Option.to_list) + @ out )) + |> List.concat + +let from_points : point list -> t list = + List.rev + >> List.folding_map + ~init:(None, Map.empty (module Int)) + ~f:(fun (gen_loc_0, src_locs) ((loc_start : _ Dual.t), meta) -> + match meta with + | Some meta -> + let src_loc_0 = Map.find src_locs meta.file_offset in + let src_locs = + Map.set src_locs ~key:meta.file_offset ~data:loc_start.src + in + let loc_end = Dual.{ gen = gen_loc_0; src = src_loc_0 } in + ((Some loc_start.gen, src_locs), Some (loc_start, loc_end, meta)) + | None -> ((Some loc_start.gen, src_locs), None)) + >> List.filter_map ~f:Fn.id >> List.rev diff --git a/engine/utils/sourcemaps/mappings/types.ml b/engine/utils/sourcemaps/mappings/types.ml new file mode 100644 index 000000000..be2cd146e --- /dev/null +++ b/engine/utils/sourcemaps/mappings/types.ml @@ -0,0 +1,4 @@ +open Prelude + +type meta = { file_offset : int; name : int option } [@@deriving show, eq] +type point = Location.t Dual.t * meta option [@@deriving show, eq] diff --git a/engine/utils/sourcemaps/prelude.ml b/engine/utils/sourcemaps/prelude.ml new file mode 100644 index 000000000..e4d6ca4bd --- /dev/null +++ b/engine/utils/sourcemaps/prelude.ml @@ -0,0 +1,5 @@ +include Base +include Ppx_yojson_conv_lib.Yojson_conv.Primitives + +let ( << ) f g x = f (g x) +let ( >> ) f g x = g (f x) diff --git a/engine/utils/sourcemaps/source_maps.ml b/engine/utils/sourcemaps/source_maps.ml new file mode 100644 index 000000000..6da383baa --- /dev/null +++ b/engine/utils/sourcemaps/source_maps.ml @@ -0,0 +1,53 @@ +open Prelude +module Location = Location +include Mappings + +type mapping = { + gen : range; + src : range; + source : string; + name : string option; +} + +type t = { + mappings : string; + sourceRoot : string; + sources : string list; + sourcesContent : string option list; + names : string list; + version : int; + file : string; +} +[@@deriving yojson] + +let dedup_freq (l : string list) : string list = + let hashtbl : (string, int) Hashtbl.t = Hashtbl.create (module String) in + List.iter ~f:(Hashtbl.incr hashtbl) l; + Hashtbl.to_alist hashtbl + |> List.sort ~compare:(fun (_, x) (_, y) -> Int.(y - x)) + |> List.map ~f:fst + +let mk ?(file = "") ?(sourceRoot = "") ?(sourcesContent = fun _ -> None) + (mappings : mapping list) : t = + let sources = List.map ~f:(fun x -> x.source) mappings |> dedup_freq in + let names = List.filter_map ~f:(fun x -> x.name) mappings |> dedup_freq in + let f { gen; src; source; name } = + let file_offset, _ = + List.findi_exn ~f:(fun _ -> String.equal source) sources + in + let name = + Option.map + ~f:(fun name -> + List.findi_exn ~f:(fun _ -> String.equal name) names |> fst) + name + in + let meta = { file_offset; name } in + Chunk.{ gen; src; meta } + in + let mappings = List.map mappings ~f |> List.sort ~compare:Chunk.compare in + Stdlib.prerr_endline @@ [%show: Chunk.t list] mappings; + let mappings = Mappings.encode mappings in + let sourcesContent = List.map ~f:sourcesContent sources in + { mappings; sourceRoot; sourcesContent; sources; names; version = 3; file } + +let to_json = [%yojson_of: t] >> Yojson.Safe.pretty_to_string diff --git a/engine/utils/sourcemaps/source_maps.mli b/engine/utils/sourcemaps/source_maps.mli new file mode 100644 index 000000000..73105053b --- /dev/null +++ b/engine/utils/sourcemaps/source_maps.mli @@ -0,0 +1,33 @@ +type range = { start : Location.t; end_ : Location.t option } + +module Location : sig + type t = { line : int; col : int } [@@deriving eq] +end + +type mapping = { + gen : range; + src : range; + source : string; + name : string option; +} +(** A source file to generated file mapping *) + +type t = { + mappings : string; + sourceRoot : string; + sources : string list; + sourcesContent : string option list; + names : string list; + version : int; + file : string; +} +[@@deriving yojson] + +val mk : + ?file:string -> + ?sourceRoot:string -> + ?sourcesContent:(string -> string option) -> + mapping list -> + t + +val to_json : t -> string diff --git a/engine/utils/sourcemaps/vql.ml b/engine/utils/sourcemaps/vql.ml new file mode 100644 index 000000000..50bc07a45 --- /dev/null +++ b/engine/utils/sourcemaps/vql.ml @@ -0,0 +1,48 @@ +open Prelude + +let rec encode_one ?(first = true) (n : int) : int list = + let n = if first then (Int.abs n lsl 1) + if n < 0 then 1 else 0 else n in + let lhs, rhs = (n lsr 5, n land 0b11111) in + let last = Int.equal lhs 0 in + let output = (if last then 0b000000 else 0b100000) lor rhs in + output :: (if last then [] else encode_one ~first:false lhs) + +let encode : int list -> int list = List.concat_map ~f:encode_one + +let encode_base64 : int list -> string = + encode >> List.map ~f:Base64.encode >> String.of_char_list + +let rec decode_one' (first : bool) (l : int list) : int * int list = + match l with + | [] -> (0, []) + | hd :: tl -> + assert (hd < 64); + let c = Int.shift_right hd 5 |> Int.bit_and 0b1 in + let last = Int.equal c 0 in + if first then + let sign = match Int.bit_and hd 0b1 with 1 -> -1 | _ -> 1 in + let hd = Int.shift_right hd 1 |> Int.bit_and 0b1111 in + if last then (sign * hd, tl) + else + let next, tl = decode_one' false tl in + let value = hd + Int.shift_left next 4 in + (sign * value, tl) + else + let hd = Int.bit_and hd 0b11111 in + if last then (hd, tl) + else + let next, tl = decode_one' false tl in + (hd + Int.shift_left next 5, tl) + +let rec decode (l : int list) : int list = + match decode_one' true l with n, [] -> [ n ] | n, tl -> n :: decode tl + +let decode_base64 : string -> int list = + String.to_list >> List.map ~f:Base64.decode >> decode + +let%test _ = + let tests = + [ [ 132; 6; 2323; 64; 32; 63; 31; 65; 33 ]; [ 133123232 ]; [ 0; 0; 0 ] ] + in + let tests = tests @ List.map ~f:(List.map ~f:(fun x -> -x)) tests in + List.for_all ~f:(fun x -> [%eq: int list] x (encode x |> decode)) tests diff --git a/flake.nix b/flake.nix index 778ab9967..10c622a15 100644 --- a/flake.nix +++ b/flake.nix @@ -56,6 +56,7 @@ cat "${hax-env-file}" | xargs -I{} echo "export {}" fi ''; + ocamlPackages = pkgs.ocamlPackages; in rec { packages = { inherit rustc ocamlformat rustfmt fstar hax-env; @@ -73,7 +74,7 @@ #!${pkgs.stdenv.shell} ${packages.hax-rust-frontend.hax-engine-names-extract}/bin/hax-engine-names-extract | sed 's|/nix/store/\(.\{6\}\)|/nix_store/\1-|g' ''; - inherit rustc; + inherit rustc ocamlPackages; }; hax-rust-frontend = pkgs.callPackage ./cli { inherit rustc craneLib; @@ -162,11 +163,11 @@ }; packages = [ ocamlformat - pkgs.ocamlPackages.ocaml-lsp - pkgs.ocamlPackages.ocamlformat-rpc-lib - pkgs.ocamlPackages.ocaml-print-intf - pkgs.ocamlPackages.odoc - pkgs.ocamlPackages.utop + ocamlPackages.ocaml-lsp + ocamlPackages.ocamlformat-rpc-lib + ocamlPackages.ocaml-print-intf + ocamlPackages.odoc + ocamlPackages.utop pkgs.just pkgs.cargo-expand diff --git a/hax-types/src/engine_api.rs b/hax-types/src/engine_api.rs index 38df58943..8b916fc18 100644 --- a/hax-types/src/engine_api.rs +++ b/hax-types/src/engine_api.rs @@ -14,11 +14,40 @@ pub struct EngineOptions { )>, } +#[derive_group(Serializers)] +#[allow(non_snake_case)] +#[derive(JsonSchema, Debug, Clone)] +pub struct SourceMap { + pub mappings: String, + pub sourceRoot: String, + pub sources: Vec, + pub sourcesContent: Vec>, + pub names: Vec, + pub version: u8, + pub file: String, +} + +impl SourceMap { + pub fn inline_sources_content(&mut self) { + self.sourcesContent = vec![]; + for source in &self.sources { + let path = if self.sourceRoot.is_empty() { + source.clone() + } else { + format!("{}/{}", &self.sourceRoot, source) + }; + let contents = Some(std::fs::read_to_string(path).unwrap()); + self.sourcesContent.push(contents); + } + } +} + #[derive_group(Serializers)] #[derive(JsonSchema, Debug, Clone)] pub struct File { pub path: String, pub contents: String, + pub sourcemap: Option, } #[derive_group(Serializers)] diff --git a/justfile b/justfile index abc4b305a..b52f992aa 100644 --- a/justfile +++ b/justfile @@ -28,13 +28,21 @@ expand *FLAGS: # Show the Rust to OCaml generated types available to the engine. @list-types: - just _ensure_binary_availability ocamlformat ocamlformat + just _ensure_command_in_path ocamlformat ocamlformat cd engine && dune describe pp lib/types.ml \ | sed -e '1,/open ParseError/ d' \ | sed '/let rec pp_/,$d' \ | ocamlformat --impl - \ | just _pager +# Show the OCaml module `Generated_generic_printer_base` +@show-generated-printer-ml: + just _ensure_command_in_path ocamlformat ocamlformat + cd engine && dune describe pp lib/generated_generic_printer_base.ml \ + | ocamlformat --impl - \ + | just _pager + + # Format all the code fmt: cargo fmt