diff --git a/Makefile b/Makefile index c4f8057b..207901ce 100644 --- a/Makefile +++ b/Makefile @@ -96,6 +96,7 @@ js: clean: $(DUNE) clean $(MAKE) -C atdpy clean + $(MAKE) -C atdts clean rm -rf tmp .PHONY: all-supported-ocaml-versions diff --git a/atd/src/annot.ml b/atd/src/annot.ml index bd94be71..d6fab496 100644 --- a/atd/src/annot.ml +++ b/atd/src/annot.ml @@ -2,7 +2,7 @@ Utilities for interpreting annotations of type Ast.annot. *) -open Import +open Stdlib_extra type t = Ast.annot @@ -168,6 +168,7 @@ type schema = schema_section list let validate_section sec root = (* split fields by location where they may occur *) let in_module_head = ref [] in + let in_import = ref [] in let in_type_def = ref [] in let in_type_expr = ref [] in let in_variant = ref [] in @@ -202,7 +203,8 @@ let validate_section sec root = ) in Ast.fold_annot - ~module_head:(check in_module_head) + ~module_:(check in_module_head) + ~import:(check in_import) ~type_def:(check in_type_def) ~type_expr:(check in_type_expr) ~variant:(check in_variant) diff --git a/atd/src/ast.ml b/atd/src/ast.ml index 9aae772e..c5a90991 100644 --- a/atd/src/ast.ml +++ b/atd/src/ast.ml @@ -1,4 +1,4 @@ -open Import +open Stdlib_extra open Lexing @@ -8,22 +8,36 @@ let dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos) exception Atd_error of string -type full_module = module_head * module_body +type module_ = { + module_head: module_head; + imports: import list; + type_defs: type_def list; +} and module_head = loc * annot -and module_body = module_item list - and annot = annot_section list and annot_section = string * (loc * annot_field list) and annot_field = string * (loc * string option) -and type_def = loc * (string * type_param * annot) * type_expr +and type_def = { + loc: loc; + name: type_name; + param: type_param; + annot: annot; + value: type_expr; + orig: type_def option; +} -and module_item = - | Type of type_def +and import = { + loc: loc; + path: string list; + alias: string option; + name: string; + annot: annot +} and type_param = string list @@ -42,7 +56,9 @@ and type_expr = the only predefined types with a type parameter (and no special syntax). *) -and type_inst = loc * string * type_expr list +and type_inst = loc * type_name * type_expr list + +and type_name = Type_name.t = TN of string list and variant = | Variant of loc * (string * annot) * type_expr option @@ -58,14 +74,12 @@ and field_kind = and simple_field = (loc * (string * field_kind * annot) * type_expr) and field = - [ `Field of simple_field - | `Inherit of (loc * type_expr) ] + | Field of simple_field + | Inherit of (loc * type_expr) type any = - | Full_module of full_module - | Module_head of module_head - | Module_body of module_body - | Module_item of module_item + | Module of module_ + | Import of import | Type_def of type_def | Type_expr of type_expr | Variant of variant @@ -98,30 +112,35 @@ let rec amap_type_expr f = function Name (loc, (loc2, name, List.map (amap_type_expr f) args), f a) and amap_variant f = function - Variant (loc, (name, a), o) -> + | Variant (loc, (name, a), o) -> let o = Option.map (amap_type_expr f) o in Variant (loc, (name, f a), o) | Inherit (loc, x) -> Inherit (loc, amap_type_expr f x) and amap_field f = function - `Field (loc, (name, kind, a), x) -> - `Field (loc, (name, kind, f a), amap_type_expr f x) - | `Inherit (loc, x) -> - `Inherit (loc, amap_type_expr f x) + | Field (loc, (name, kind, a), x) -> + Field (loc, (name, kind, f a), amap_type_expr f x) + | Inherit (loc, x) -> + Inherit (loc, amap_type_expr f x) + and amap_cell f (loc, x, a) = (loc, amap_type_expr f x, f a) -let amap_module_item f (Type (loc, (name, param, a), x)) = - Type (loc, (name, param, f a), amap_type_expr f x) +let amap_import f (x : import) = + { x with annot = f x.annot } -let amap_head f (loc, a) = (loc, f a) +let amap_type_def f (x : type_def) : type_def = + { x with value = amap_type_expr f x.value } -let amap_body f l = - List.map (amap_module_item f) l +let amap_head f (loc, a) = (loc, f a) -let map_all_annot f ((head, body) : full_module) = - (amap_head f head, amap_body f body) +let map_all_annot f (x : module_) = + { + module_head = amap_head f x.module_head; + imports = List.map (amap_import f) x.imports; + type_defs = List.map (amap_type_def f) x.type_defs; + } let set_type_expr_loc loc = function | Sum (_, a, b) -> Sum (loc, a, b) @@ -166,8 +185,8 @@ let annot_of_variant (x : variant) = let annot_of_field (x : field) = match x with - | `Field (_, (_, _, an), _) -> an - | `Inherit _ -> [] + | Field (_, (_, _, an), _) -> an + | Inherit _ -> [] let map_annot f = function | Sum (loc, vl, a) -> Sum (loc, vl, f a) @@ -183,10 +202,8 @@ let map_annot f = function Name (loc, (loc2, name, args), f a) type visitor_hooks = { - full_module: (full_module -> unit) -> full_module -> unit; - module_head: (module_head -> unit) -> module_head -> unit; - module_body: (module_body -> unit) -> module_body -> unit; - module_item: (module_item -> unit) -> module_item -> unit; + module_: (module_ -> unit) -> module_ -> unit; + import: (import -> unit) -> import -> unit; type_def: (type_def -> unit) -> type_def -> unit; type_expr: (type_expr -> unit) -> type_expr -> unit; variant: (variant -> unit) -> variant -> unit; @@ -224,9 +241,9 @@ and visit_variant hooks x = and visit_field hooks x = let cont x = - match x with - | `Field (loc, (name, kind, a), x) -> visit_type_expr hooks x - | `Inherit (loc, x) -> visit_type_expr hooks x + match (x : field) with + | Field (loc, (name, kind, a), x) -> visit_type_expr hooks x + | Inherit (loc, x) -> visit_type_expr hooks x in hooks.field cont x @@ -234,34 +251,23 @@ and visit_cell hooks x = let cont (loc, x, a) = visit_type_expr hooks x in hooks.cell cont x -let visit_type_def hooks x = - let cont (loc, (name, param, a), x) = visit_type_expr hooks x in - hooks.type_def cont x - -let visit_module_item hooks x = - let cont (Type x) = visit_type_def hooks x in - hooks.module_item cont x +let visit_import hooks x = + hooks.import (fun _ -> ()) x -let visit_module_head hooks x = - let cont x = () in - hooks.module_head cont x - -let visit_module_body hooks x = - let cont x = List.iter (visit_module_item hooks) x in - hooks.module_body cont x +let visit_type_def hooks (x : type_def) = + let cont x = visit_type_expr hooks x.value in + hooks.type_def cont x -let visit_full_module hooks x = - let cont (head, body) = - visit_module_head hooks head; - visit_module_body hooks body +let visit_module hooks (x : module_) = + let cont (x : module_) = + List.iter (visit_import hooks) x.imports; + List.iter (visit_type_def hooks) x.type_defs in - hooks.full_module cont x + hooks.module_ cont x let visit - ?(full_module = fun cont x -> cont x) - ?(module_head = fun cont x -> cont x) - ?(module_body = fun cont x -> cont x) - ?(module_item = fun cont x -> cont x) + ?(module_ = fun cont x -> cont x) + ?(import = fun cont x -> cont x) ?(type_def = fun cont x -> cont x) ?(type_expr = fun cont x -> cont x) ?(variant = fun cont x -> cont x) @@ -269,10 +275,8 @@ let visit ?(field = fun cont x -> cont x) () = let hooks : visitor_hooks = { - full_module; - module_head; - module_body; - module_item; + module_; + import; type_def; type_expr; variant; @@ -281,10 +285,8 @@ let visit } in let visit (any : any) = match any with - | Full_module x -> visit_full_module hooks x - | Module_head x -> visit_module_head hooks x - | Module_body x -> visit_module_body hooks x - | Module_item x -> visit_module_item hooks x + | Module x -> visit_module hooks x + | Import x -> visit_import hooks x | Type_def x -> visit_type_def hooks x | Type_expr x -> visit_type_expr hooks x | Variant x -> visit_variant hooks x @@ -294,7 +296,8 @@ let visit visit let fold_annot - ?module_head + ?module_ + ?import ?type_def ?type_expr ?variant @@ -312,8 +315,10 @@ let fold_annot in let visitor = visit - ~module_head:(fold module_head (fun (_, an) -> an)) - ~type_def:(fold type_def (fun (_, (_, _, an), _) -> an)) + ~module_:(fold module_ + (fun { module_head = (_, an); _ } -> an)) + ~import:(fold import (fun (x : import) -> x.annot)) + ~type_def:(fold type_def (fun (x : type_def) -> x.annot)) ~type_expr:(fold type_expr annot_of_type_expr) ~variant:(fold variant annot_of_variant) ~cell:(fold cell (fun (_, _, an) -> an)) @@ -357,19 +362,18 @@ let rec fold (f : type_expr -> 'a -> 'a) (x : type_expr) acc = | Tvar (_, _string) -> acc -and fold_variant f x acc = +and fold_variant f (x : variant) acc = match x with Variant (_, _, Some type_expr) -> fold f type_expr acc | Variant _ -> acc | Inherit (_, type_expr) -> fold f type_expr acc -and fold_field f x acc = +and fold_field f (x : field) acc = match x with - `Field (_, _, type_expr) -> fold f type_expr acc - | `Inherit (_, type_expr) -> fold f type_expr acc - + Field (_, _, type_expr) -> fold f type_expr acc + | Inherit (_, type_expr) -> fold f type_expr acc -module Type_names = Set.Make (String) +module Type_names = Set.Make (Type_name) let extract_type_names ?(ignorable = []) x = let ign s = List.mem s ignorable in @@ -383,7 +387,7 @@ let extract_type_names ?(ignorable = []) x = fold ( fun x acc -> match x with - Name (_, (_, name, _), _) -> add name acc + | Name (_, (_, name, _), _) -> add name acc | _ -> acc ) x Type_names.empty @@ -398,6 +402,11 @@ let is_required = function | With_default -> false | Required -> true +let local_name_of_import (x : import) = + match x.alias with + | None -> x.name + | Some local_name -> local_name + module Map = struct type mappers = { @@ -449,23 +458,17 @@ module Map = struct | Variant _ as x -> x | Inherit (loc, x) -> Inherit (loc, type_expr m x) - and field m x = + and field m (x : field) = match x with - | `Field (loc, k, x) -> `Field (loc, k, type_expr m x) - | `Inherit (loc, x) -> `Inherit (loc, type_expr m x) - - let type_def m (loc, (name, params, an), x) = - (loc, (name, params, an), type_expr m x) - - let module_item m x = - match x with - | Type x -> Type (type_def m x) + | Field (loc, k, x) -> Field (loc, k, type_expr m x) + | Inherit (loc, x) -> Inherit (loc, type_expr m x) - let module_body m x = - List.map (module_item m) x + let type_def m (x : type_def) : type_def = + { x with value = type_expr m x.value } - let full_module m (head, body) = - (head, module_body m body) + let module_ m { module_head; imports; type_defs } = + let type_defs = List.map (type_def m) type_defs in + { module_head; imports; type_defs } end let use_only_specific_variants x = @@ -473,11 +476,11 @@ let use_only_specific_variants x = match x with | Name (loc, (loc2, name, [arg]), an) -> (match name with - | "list" -> List (loc, arg, an) - | "option" -> Option (loc, arg, an) - | "nullable" -> Nullable (loc, arg, an) - | "shared" -> Shared (loc, arg, an) - | "wrap" -> Wrap (loc, arg, an) + | TN ["list"] -> List (loc, arg, an) + | TN ["option"] -> Option (loc, arg, an) + | TN ["nullable"] -> Nullable (loc, arg, an) + | TN ["shared"] -> Shared (loc, arg, an) + | TN ["wrap"] -> Wrap (loc, arg, an) | _ -> x) | Name (loc, (loc2, name, _), an) as x -> @@ -494,15 +497,15 @@ let use_only_specific_variants x = | Wrap _ as x -> x in let mappers = { Map.type_expr } in - Map.full_module mappers x + Map.module_ mappers x let use_only_name_variant x = let type_expr x = match x with - | List (loc, arg, an) -> Name (loc, (loc, "list", [arg]), an) - | Option (loc, arg, an) -> Name (loc, (loc, "option", [arg]), an) - | Nullable (loc, arg, an) -> Name (loc, (loc, "nullable", [arg]), an) - | Shared (loc, arg, an) -> Name (loc, (loc, "shared", [arg]), an) + | List (loc, arg, an) -> Name (loc, (loc, TN ["list"], [arg]), an) + | Option (loc, arg, an) -> Name (loc, (loc, TN ["option"], [arg]), an) + | Nullable (loc, arg, an) -> Name (loc, (loc, TN ["nullable"], [arg]), an) + | Shared (loc, arg, an) -> Name (loc, (loc, TN ["shared"], [arg]), an) | Name _ | Sum _ @@ -512,4 +515,19 @@ let use_only_name_variant x = | Wrap _ as x -> x in let mappers = { Map.type_expr } in - Map.full_module mappers x + Map.module_ mappers x + +let create_import ~loc ~path ?alias ~annot () : import = + let name = + match List.rev path, alias with + | [], _ -> invalid_arg "Ast.create_import: empty path" + | name :: _, None -> name + | _ :: _, Some override -> override + in + { + loc; + path; + alias; + name; + annot; + } diff --git a/atd/src/ast.mli b/atd/src/ast.mli index 400a3a3d..067b3962 100644 --- a/atd/src/ast.mli +++ b/atd/src/ast.mli @@ -27,30 +27,58 @@ and annot_field = string * (loc * string option) (** An annotation field, i.e. a key with an optional value within an annotation. *) - -type full_module = module_head * module_body +type module_ = { + module_head: module_head; + imports: import list; + type_defs: type_def list; +} (** Contents of an ATD file. *) and module_head = loc * annot (** The head of an ATD file is just a list of annotations. *) -and module_body = module_item list - (** The body of an ATD file is a list of type definitions. - Type definitions are implicitely mutually - recursive. They can be sorted based on dependencies - using {!Atd.Util.tsort}. +(** Require the existence of another ATD module. + The concrete syntax is [import external_name as local_name]. + The annotations specify language-specific options such as where to + find the implementation or alternate names. *) +and import = private { + loc: loc; + + path: string list; + (** The full name of the ATD module. + Unless an alias is specified, the local name of the module is + the last component e.g. [import foo.bar] imports module [foo.bar] + which is known locally as just [bar]. *) + + alias: string option; + (** The local name used to identify the imported ATD module, overriding + the default name. + Typically, this is an abbreviation as in + [import bubble_gum_factory_api as bg]. *) -and module_item = - | Type of type_def - (** There is currently only one kind of module items, - that is single type definitions. *) + name: string; + (** The local name of the module. It's the value of [alias] if there is + one, otherwise it's the last component of [path]. + It's a single path component, i.e. it doesn't contain periods. *) + + annot: annot +} -and type_def = loc * (string * type_param * annot) * type_expr - (** A type definition. *) +(** A type definition. *) +and type_def = { + loc: loc; + name: type_name; + param: type_param; + annot: annot; + value: type_expr; + (* Polymorphic type definition from which this definition has been derived + through monomorphization, if applicable. *) + orig: type_def option; +} +(** List of type variables without the tick. *) and type_param = string list - (** List of type variables without the tick. *) and type_expr = | Sum of loc * variant list * annot @@ -89,8 +117,10 @@ and type_expr = - [Tvar]: a type variable identifier without the tick *) -and type_inst = loc * string * type_expr list - (** A type name and its arguments *) +and type_inst = loc * type_name * type_expr list + (** A dot-separated type name and its arguments *) + +and type_name = Type_name.t = TN of string list and variant = | Variant of loc * (string * annot) * type_expr option @@ -153,8 +183,8 @@ v} and simple_field = (loc * (string * field_kind * annot) * type_expr) and field = - [ `Field of simple_field - | `Inherit of (loc * type_expr) ] + | Field of simple_field + | Inherit of (loc * type_expr) (** A single record field or an [inherit] statement. [`Inherit] statements can be expanded into fields using {!Atd_inherit} @@ -163,16 +193,22 @@ and field = *) type any = - | Full_module of full_module - | Module_head of module_head - | Module_body of module_body - | Module_item of module_item + | Module of module_ + | Import of import | Type_def of type_def | Type_expr of type_expr | Variant of variant | Cell of cell | Field of field - (** Type for any kind of node, used to define a visitor root. *) + (** Type for any kind of node, used to define a visitor root. + Also used to simplify the interface of the [Print] module. *) + +val create_import : + loc:loc -> + path:string list -> + ?alias:string -> + annot:annot -> + unit -> import val loc_of_type_expr : type_expr -> loc (** Extract the source location of any type expression. *) @@ -214,16 +250,14 @@ val map_annot : (annot -> annot) -> type_expr -> type_expr This is a shallow transformation. Sub-expressions are not affected. *) -val map_all_annot : (annot -> annot) -> full_module -> full_module +val map_all_annot : (annot -> annot) -> module_ -> module_ (** Replacement of all annotations occurring in an ATD module. *) val visit : - ?full_module: ((full_module -> unit) -> full_module -> unit) -> - ?module_head: ((module_head -> unit) -> module_head -> unit) -> - ?module_body: ((module_body -> unit) -> module_body -> unit) -> - ?module_item: ((module_item -> unit) -> module_item -> unit) -> + ?module_: ((module_ -> unit) -> module_ -> unit) -> + ?import: ((import -> unit) -> import -> unit) -> ?type_def: ((type_def -> unit) -> type_def -> unit) -> ?type_expr: ((type_expr -> unit) -> type_expr -> unit) -> ?variant: ((variant -> unit) -> variant -> unit) -> @@ -233,8 +267,8 @@ val visit : (any -> unit) (** Create a function that will visit all the nodes of a tree by default. Each optional field defines what to do when encountering a node - of a particular kind. For example, the [full_module] that you provide - would be applied as [full_module cont x]. The [cont] function + of a particular kind. For example, the [module_] that you provide + would be applied as [module_ cont x]. The [cont] function must be called for the visitor to continue down the tree, if this is desired. Arbitrary code can be executed before or after the call to [cont]. [cont] may be called on a modified version @@ -251,12 +285,13 @@ val visit : ) () in - visitor (Full_module root) + visitor (Module root) v} *) val fold_annot : - ?module_head: (module_head -> annot -> 'a -> 'a) -> + ?module_: (module_ -> annot -> 'a -> 'a) -> + ?import: (import -> annot -> 'a -> 'a) -> ?type_def: (type_def -> annot -> 'a -> 'a) -> ?type_expr: (type_expr -> annot -> 'a -> 'a) -> ?variant: (variant -> annot -> 'a -> 'a) -> @@ -276,8 +311,8 @@ val fold : (type_expr -> 'a -> 'a) -> type_expr -> 'a -> 'a *) val extract_type_names : - ?ignorable : string list -> - type_expr -> string list + ?ignorable : type_name list -> + type_expr -> type_name list (** Extract all the type names occurring in a type expression under [`Name], without duplicates. @@ -291,6 +326,10 @@ val is_parametrized : type_expr -> bool val is_required : field_kind -> bool +val local_name_of_import : import -> string + (** Extract the name of the imported module, taking into account the + possible aliasing. *) + (** Replace nodes by other nodes of the same type. First the user-given mapper is applied to a node, then the children nodes are mapped recursively. @@ -306,15 +345,13 @@ module Map : sig val variant : mappers -> variant -> variant val field : mappers -> field -> field val type_def : mappers -> type_def -> type_def - val module_item : mappers -> module_item -> module_item - val module_body : mappers -> module_body -> module_body - val full_module : mappers -> full_module -> full_module + val module_ : mappers -> module_ -> module_ end -val use_only_specific_variants : full_module -> full_module +val use_only_specific_variants : module_ -> module_ (** Use the dedicated variants [Int], [List], etc. instead of the generic variant [Name]. *) -val use_only_name_variant : full_module -> full_module +val use_only_name_variant : module_ -> module_ (** Use the generic variant [Name] instead of the dedicated variants [Int], [List], etc. *) diff --git a/atd/src/check.ml b/atd/src/check.ml index b49ab359..17b4adc8 100644 --- a/atd/src/check.ml +++ b/atd/src/check.ml @@ -1,9 +1,14 @@ (* Semantic verification *) -open Import +open Stdlib_extra open Ast +type env = { + def_tbl: Predef.table; + imports: Imports.t; +} + let add_name accu = function Name (_, (_, k, _), _) -> k :: accu | _ -> accu @@ -13,7 +18,7 @@ let get_kind = function | Record _ -> `Record | _ -> `Other -let check_inheritance tbl (t0 : type_expr) = +let check_inheritance env (t0 : type_expr) = let not_a kind _ = let msg = sprintf "Cannot inherit from non-%s type" @@ -28,17 +33,17 @@ let check_inheritance tbl (t0 : type_expr) = let rec check kind inherited (t : type_expr) = match t with Sum (_, vl, _) when kind = `Sum -> - List.iter ( - function - Inherit (_, t) -> check kind inherited t + List.iter (fun (x : variant) -> + match x with + | Inherit (_, t) -> check kind inherited t | Variant _ -> () ) vl | Record (_, fl, _) when kind = `Record -> - List.iter ( - function - `Inherit (_, t) -> check kind inherited t - | `Field _ -> () + List.iter (fun (x : field) -> + match x with + | Inherit (_, t) -> check kind inherited t + | Field _ -> () ) fl | Sum _ @@ -50,17 +55,23 @@ let check_inheritance tbl (t0 : type_expr) = | Shared _ | Wrap _ as x -> not_a kind x - | Name (_, (loc, k, _), _) -> - if List.mem k inherited then + | Name (_, (loc, name, _), _) -> + if List.mem name inherited then error_at (loc_of_type_expr t0) "Cyclic inheritance" else let (_arity, opt_def) = - try Hashtbl.find tbl k - with Not_found -> error_at loc ("Undefined type " ^ k) + match Imports.resolve env.imports loc name with + | Some _, _base_name -> + error_at loc ("We cannot inherit from an external type: " + ^ Print.tn name) + | None, base_name -> + try Hashtbl.find env.def_tbl name + with Not_found -> + error_at loc ("Undefined type " ^ base_name) in (match opt_def with None -> () - | Some (_, _, t) -> check kind (k :: inherited) t + | Some x -> check kind (x.name :: inherited) x.value ) | Tvar _ -> @@ -71,15 +82,15 @@ let check_inheritance tbl (t0 : type_expr) = check (get_kind t0) (add_name [] t0) t0 -let check_type_expr tbl tvars (t : type_expr) = +let check_type_expr env tvars (t : type_expr) = let rec check : type_expr -> unit = function Sum (_, vl, _) as x -> List.iter (check_variant (Hashtbl.create 10)) vl; - check_inheritance tbl x + check_inheritance env x | Record (_, fl, _) as x -> List.iter (check_field (Hashtbl.create 10)) fl; - check_inheritance tbl x + check_inheritance env x | Tuple (_, tl, _) -> List.iter (fun (_, x, _) -> check x) tl | List (_, t, _) -> check t @@ -91,23 +102,33 @@ let check_type_expr tbl tvars (t : type_expr) = check t | Wrap (_, t, _) -> check t - | Name (_, (loc, k, tal), _) -> - assert (k <> "list" && k <> "option" - && k <> "nullable" && k <> "shared" && k <> "wrap"); - let (arity, _opt_def) = - try Hashtbl.find tbl k - with Not_found -> error_at loc ("Undefined type " ^ k) - in - let n = List.length tal in - if arity <> n then - error_at loc (sprintf "Type %s was defined to take %i parameters, \ - but %i argument%s." - k arity n (if n > 1 then "s are given" - else " is given") - ); - - List.iter check tal - + | Name (_, (loc, name, tal), _) -> + assert (name <> TN ["list"] && name <> TN ["option"] + && name <> TN ["nullable"] && name <> TN ["shared"] + && name <> TN ["wrap"]); + (match Imports.resolve env.imports loc name with + | Some _, _base_name -> + (* external type; we can't check its arity *) + () + | None, base_name -> + let (arity, _opt_def) = + try Hashtbl.find env.def_tbl name + with Not_found -> + error_at loc ("Undefined type " ^ base_name) + in + let n = List.length tal in + if arity <> n then + error_at loc (sprintf + "Type %s was defined to take %i parameters, \ + but %i argument%s." + (Print.tn name) + arity n + (if n > 1 then "s are given" + else " is given") + ); + + List.iter check tal + ) | Tvar (loc, s) -> if not (List.mem s tvars) then error_at loc (sprintf "Unbound type variable '%s" s) @@ -129,14 +150,14 @@ let check_type_expr tbl tvars (t : type_expr) = check t and check_field accu = function - `Field (loc, (k, _, _), t) -> + | Field (loc, (k, _, _), t) -> if Hashtbl.mem accu k then error_at loc (sprintf "Multiple definitions of the same field %s" k); Hashtbl.add accu k (); check t - | `Inherit (_, t) -> + | Inherit (_, t) -> (* overriding is allowed, for now without a warning *) check t in @@ -144,27 +165,13 @@ let check_type_expr tbl tvars (t : type_expr) = check t -let check (l : Ast.module_body) = - let predef = Predef.make_table () in - let tbl = Hashtbl.copy predef in - - (* first pass: put all definitions in the table *) - List.iter ( - function Type ((loc, (k, pl, _), _) as x) -> - if Hashtbl.mem tbl k then - if Hashtbl.mem predef k then - error_at loc - (sprintf "%s is a predefined type, it cannot be redefined." k) - else - error_at loc - (sprintf "Type %s is defined for the second time." k) - else - Hashtbl.add tbl k (List.length pl, Some x) - ) l; - +let check (x : Ast.module_) = + let env = { + def_tbl = Predef.make_table x.type_defs; + imports = Imports.load x.imports; + } in (* second pass: check existence and arity of types in type expressions, check that inheritance is not cyclic *) - List.iter ( - function (Ast.Type (_, (_, tvars, _), t)) -> - check_type_expr tbl tvars t - ) l + List.iter (fun (x : type_def) -> + check_type_expr env x.param x.value + ) x.type_defs diff --git a/atd/src/check.mli b/atd/src/check.mli index 85d7217c..8aeb274f 100644 --- a/atd/src/check.mli +++ b/atd/src/check.mli @@ -5,4 +5,4 @@ (** Check the validity of an ATD file. Raises an exception on the first error encountered. *) -val check : Ast.module_body -> unit +val check : Ast.module_ -> unit diff --git a/atd/src/doc.ml b/atd/src/doc.ml index cd143d0c..fa88a2bf 100644 --- a/atd/src/doc.ml +++ b/atd/src/doc.ml @@ -1,4 +1,4 @@ -open Import +open Stdlib_extra type inline = Doc_types.inline = | Text of string diff --git a/atd/src/expand.ml b/atd/src/expand.ml index 781996e1..64925420 100644 --- a/atd/src/expand.ml +++ b/atd/src/expand.ml @@ -55,39 +55,13 @@ *) -open Import +open Stdlib_extra open Ast module S = Stdlib.Set.Make (String) module M = Stdlib.Map.Make (String) - -(* - To support -o-name-overlap, we need to generate a few type annotations. - But types generated by expansion like _1, _2, etc. are not actually - written out in the interface or implementation, so they must be mapped - back to the original polymorphic types for annotation purposes. - - This table contains the mappings. Its format is: - key = generated type name - value = (original type name, - original number of parameters) - - For example, if we have the generated output: - type 'a t = ... - type _1 = int t - Then the idea is, in the reader and writer functions, instead of using - _1 in the annotation, we use _ t. The entry in original_types would be: - ("_1", ("t", 1)) - - (The alternate strategy of actually producing a definition for type _1 - aliasing int t in the implementation doesn't work, because the annotations - will disagree with the interface in the case of recursive types.) -*) -type original_types = (string, string * int) Hashtbl.t - - (* Format of the table: key = type name (without arguments) @@ -125,28 +99,28 @@ let rec mapvar_expr a) | List (loc, t, a) -> List (loc, mapvar_expr f t, a) - | Name (loc, (loc2, "list", [t]), a) -> - Name (loc, (loc2, "list", [mapvar_expr f t]), a) + | Name (loc, (loc2, TN ["list"], [t]), a) -> + Name (loc, (loc2, TN ["list"], [mapvar_expr f t]), a) | Option (loc, t, a) -> Option (loc, mapvar_expr f t, a) - | Name (loc, (loc2, "option", [t]), a) -> - Name (loc, (loc2, "option", [mapvar_expr f t]), a) + | Name (loc, (loc2, TN ["option"], [t]), a) -> + Name (loc, (loc2, TN ["option"], [mapvar_expr f t]), a) | Nullable (loc, t, a) -> Nullable (loc, mapvar_expr f t, a) - | Name (loc, (loc2, "nullable", [t]), a) -> - Name (loc, (loc2, "nullable", [mapvar_expr f t]), a) + | Name (loc, (loc2, TN ["nullable"], [t]), a) -> + Name (loc, (loc2, TN ["nullable"], [mapvar_expr f t]), a) | Shared (loc, t, a) -> Shared (loc, mapvar_expr f t, a) - | Name (loc, (loc2, "shared", [t]), a) -> - Name (loc, (loc2, "shared", [mapvar_expr f t]), a) + | Name (loc, (loc2, TN ["shared"], [t]), a) -> + Name (loc, (loc2, TN ["shared"], [mapvar_expr f t]), a) | Wrap (loc, t, a) -> Wrap (loc, mapvar_expr f t, a) - | Name (loc, (loc2, "wrap", [t]), a) -> - Name (loc, (loc2, "wrap", [mapvar_expr f t]), a) + | Name (loc, (loc2, TN ["wrap"], [t]), a) -> + Name (loc, (loc2, TN ["wrap"], [mapvar_expr f t]), a) | Tvar (loc, s) -> Tvar (loc, f s) @@ -154,8 +128,8 @@ let rec mapvar_expr Name (loc, (loc2, k, List.map (mapvar_expr f) args), a) and mapvar_field f = function - `Field (loc, k, t) -> `Field (loc, k, mapvar_expr f t) - | `Inherit (loc, t) -> `Inherit (loc, mapvar_expr f t) + | Field (loc, k, t) -> Field (loc, k, mapvar_expr f t) + | Inherit (loc, t) -> Inherit (loc, mapvar_expr f t) and mapvar_variant f = function | Variant (loc, k, opt_t) -> @@ -172,8 +146,10 @@ let var_of_int i = let vars_of_int n = List.init n var_of_int -let is_special s = String.length s > 0 && s.[0] = '@' - +let is_special name = + match name with + | TN [s] -> String.length s > 0 && s.[0] = '@' + | TN _ -> false (* Standardize a type expression by numbering the type variables @@ -212,8 +188,8 @@ let make_type_name loc orig_name args an = in let normalized_args = List.map (mapvar_expr assign_name) args in let new_name = - sprintf "@(%s)" - (Print.string_of_type_name orig_name normalized_args an) + TN [sprintf "@(%s)" + (Print.string_of_type_inst orig_name normalized_args an)] in let mapping = List.rev !mapping in let new_args = @@ -225,7 +201,7 @@ let make_type_name loc orig_name args an = let is_abstract (x : type_expr) = match x with - Name (_, (_, "abstract", _), _) -> true + Name (_, (_, TN ["abstract"], _), _) -> true | _ -> false let expr_of_lvalue loc name param annot = @@ -249,12 +225,10 @@ let add_annot (x : type_expr) a : type_expr = let expand ?(keep_builtins = false) ?(keep_poly = false) (l : type_def list) - : type_def list * original_types = + : type_def list = let seqnum, tbl = init_table () in - let original_types = Hashtbl.create 16 in - let rec subst env (t : type_expr) : type_expr = match t with Sum (loc, vl, a) -> @@ -266,44 +240,44 @@ let expand List.map (fun (loc, x, a) -> (loc, subst env x, a)) tl, a) | List (loc as loc2, t, a) - | Name (loc, (loc2, "list", [t]), a) -> + | Name (loc, (loc2, TN ["list"], [t]), a) -> let t' = subst env t in if keep_builtins then - Name (loc, (loc2, "list", [t']), a) + Name (loc, (loc2, TN ["list"], [t']), a) else - subst_type_name loc loc2 "list" [t'] a + subst_type_name loc loc2 (TN ["list"]) [t'] a | Option (loc as loc2, t, a) - | Name (loc, (loc2, "option", [t]), a) -> + | Name (loc, (loc2, TN ["option"], [t]), a) -> let t' = subst env t in if keep_builtins then - Name (loc, (loc2, "option", [t']), a) + Name (loc, (loc2, TN ["option"], [t']), a) else - subst_type_name loc loc2 "option" [t'] a + subst_type_name loc loc2 (TN ["option"]) [t'] a | Nullable (loc as loc2, t, a) - | Name (loc, (loc2, "nullable", [t]), a) -> + | Name (loc, (loc2, TN ["nullable"], [t]), a) -> let t' = subst env t in if keep_builtins then - Name (loc, (loc2, "nullable", [t']), a) + Name (loc, (loc2, TN ["nullable"], [t']), a) else - subst_type_name loc loc2 "nullable" [t'] a + subst_type_name loc loc2 (TN ["nullable"]) [t'] a | Shared (loc as loc2, t, a) - | Name (loc, (loc2, "shared", [t]), a) -> + | Name (loc, (loc2, TN ["shared"], [t]), a) -> let t' = subst env t in if keep_builtins then - Name (loc, (loc2, "shared", [t']), a) + Name (loc, (loc2, TN ["shared"], [t']), a) else - subst_type_name loc loc2 "shared" [t'] a + subst_type_name loc loc2 (TN ["shared"]) [t'] a | Wrap (loc as loc2, t, a) - | Name (loc, (loc2, "wrap", [t]), a) -> + | Name (loc, (loc2, TN ["wrap"], [t]), a) -> let t' = subst env t in if keep_builtins then - Name (loc, (loc2, "wrap", [t']), a) + Name (loc, (loc2, TN ["wrap"], [t']), a) else - subst_type_name loc loc2 "wrap" [t'] a + subst_type_name loc loc2 (TN ["wrap"]) [t'] a | Tvar (_, s) as x -> Option.value (List.assoc s env) ~default:x @@ -369,8 +343,6 @@ let expand (* Create entry in the table, indicating that we are working on it *) Hashtbl.add tbl name (i, n_param, None, None); - Hashtbl.add original_types name (orig_name, List.length orig_args); - (* Get the original type definition *) let (_, _, orig_opt_td, _) = try Hashtbl.find tbl orig_name @@ -378,15 +350,15 @@ let expand assert false (* All original type definitions must have been put in the table initially *) in - let ((_, _, _) as td') = + let (td' : type_def) = match orig_opt_td with None -> assert false (* Original type definitions must all exist, even for predefined types and abstract types. *) - | Some (_, (k, pl, def_an), t) -> - assert (k = orig_name); + | Some (x : type_def) -> + assert (x.name = orig_name); let new_params = vars_of_int n_param in - let t = add_annot t an0 in + let t = add_annot x.value an0 in let t = set_type_expr_loc loc t in (* @@ -421,7 +393,7 @@ let expand 'y -> 'a *) - let env = List.map2 (fun var value -> (var, value)) pl args in + let env = List.map2 (fun var value -> (var, value)) x.param args in let t' = if is_abstract t then @@ -430,7 +402,7 @@ let expand use 'a t and preserve "t" *) let t = - expr_of_lvalue loc orig_name pl + expr_of_lvalue loc orig_name x.param (Ast.annot_of_type_expr t) in subst_only_args env t @@ -441,13 +413,19 @@ let expand else t' in - (loc, (name, new_params, def_an), t') + ({ x with + loc; + name; + param = new_params; + annot = x.annot; + value = t'; + } : type_def) in Hashtbl.replace tbl name (i, n_param, None, Some td') and subst_field env = function - | `Field (loc, k, t) -> `Field (loc, k, subst env t) - | `Inherit (loc, t) -> `Inherit (loc, subst env t) + | Field (loc, k, t) -> Field (loc, k, subst env t) + | Inherit (loc, t) -> Inherit (loc, subst env t) and subst_variant env = function Variant (loc, k, opt_t) as x -> @@ -459,23 +437,23 @@ let expand and subst_only_args env = function List (loc, t, a) - | Name (loc, (_, "list", [t]), a) -> + | Name (loc, (_, TN ["list"], [t]), a) -> List (loc, subst env t, a) | Option (loc, t, a) - | Name (loc, (_, "option", [t]), a) -> + | Name (loc, (_, TN ["option"], [t]), a) -> Option (loc, subst env t, a) | Nullable (loc, t, a) - | Name (loc, (_, "nullable", [t]), a) -> + | Name (loc, (_, TN ["nullable"], [t]), a) -> Nullable (loc, subst env t, a) | Shared (loc, t, a) - | Name (loc, (_, "shared", [t]), a) -> + | Name (loc, (_, TN ["shared"], [t]), a) -> Shared (loc, subst env t, a) | Wrap (loc, t, a) - | Name (loc, (_, "wrap", [t]), a) -> + | Name (loc, (_, TN ["wrap"], [t]), a) -> Wrap (loc, subst env t, a) | Name (loc, (loc2, name, args), an) -> @@ -486,24 +464,24 @@ let expand (* first pass: add all original definitions to the table *) List.iter ( - fun ((_, (k, pl, _), _) as td) -> + fun (x : type_def) -> incr seqnum; let i = !seqnum in - let n = List.length pl in - Hashtbl.add tbl k (i, n, Some td, None) + let n = List.length x.param in + Hashtbl.add tbl x.name (i, n, Some x, None) ) l; (* second pass: perform substitutions and insert new definitions *) List.iter ( - fun ((loc, (k, pl, a), t) as td) -> - if pl = [] || keep_poly then ( + fun (td : type_def) -> + if td.param = [] || keep_poly then ( let (i, n, _, _) = - try Hashtbl.find tbl k + try Hashtbl.find tbl td.name with Not_found -> assert false in - let t' = subst [] t in - let td' = (loc, (k, pl, a), t') in - Hashtbl.replace tbl k (i, n, Some td, Some td') + let t' = subst [] td.value in + let td' = { td with value = t' } in + Hashtbl.replace tbl td.name (i, n, Some td, Some td') ) ) l; @@ -519,11 +497,12 @@ let expand ) tbl [] in let l = List.sort (fun (i, _) (j, _) -> compare i j) l in - (List.map snd l, original_types) + List.map snd l -let replace_type_names (subst : string -> string) (t : type_expr) : type_expr = +let replace_type_names + (subst : type_name -> type_name) (t : type_expr) : type_expr = let rec replace (t : type_expr) : type_expr = match t with Sum (loc, vl, a) -> Sum (loc, List.map replace_variant vl, a) @@ -540,8 +519,8 @@ let replace_type_names (subst : string -> string) (t : type_expr) : type_expr = Name (loc, (loc2, subst k, List.map replace l), a) and replace_field = function - `Field (loc, k, t) -> `Field (loc, k, replace t) - | `Inherit (loc, t) -> `Inherit (loc, replace t) + | Field (loc, k, t) -> Field (loc, k, replace t) + | Inherit (loc, t) -> Inherit (loc, replace t) and replace_variant = function Variant (loc, k, opt_t) as x -> @@ -622,12 +601,13 @@ let suggest_good_name = | _ (* digit *) -> "x" ^ name let standardize_type_names - ~prefix ~original_types (defs : type_def list) : type_def list = + ~prefix (defs : type_def list) : type_def list = let reserved_identifiers = - List.map (fun (k, _, _) -> k) Predef.list - @ List.filter_map (fun (_, (k, _, _), _) -> - if is_special k then None - else Some k + List.map (fun (name, _, _) -> Print.tn name) Predef.list + @ List.filter_map (fun (x : type_def) -> + let name = x.name in + if is_special name then None + else Some (Print.tn name) ) defs in let name_registry = @@ -640,48 +620,48 @@ let standardize_type_names let new_id id = (* The leading underscore is used to identify generated type names in other places. *) - Unique_name.translate - name_registry - ~preferred_translation:(prefix ^ suggest_good_name id) - id + let str_id = Print.tn id in + let new_str_id = + Unique_name.translate + name_registry + ~preferred_translation:(prefix ^ suggest_good_name str_id) + str_id + in + TN [new_str_id] in let replace_name k = if is_special k then - let k' = new_id k in - begin try - let orig_info = Hashtbl.find original_types k in - Hashtbl.remove original_types k; - Hashtbl.add original_types k' orig_info - with Not_found -> - assert false (* Must have been added during expand *) - end; - k' + new_id k else k in let defs = List.map ( - fun (loc, (k, pl, a), t) -> - let k' = replace_name k in - (loc, (k', pl, a), t) + fun (x : type_def) -> + { x with name = replace_name x.name } ) defs in let subst id = - match Unique_name.translate_only name_registry id with - | Some x -> x - | None -> - (* must have been defined as abstract *) - id - in - List.map (fun (loc, x, t) -> (loc, x, replace_type_names subst t)) defs - - -let expand_module_body - ?(prefix = "_") ?keep_builtins ?keep_poly ?(debug = false) l = - let td_list = List.map (function (Type td) -> td) l in - let (td_list, original_types) = expand ?keep_builtins ?keep_poly td_list in - let td_list = - if debug then td_list - else standardize_type_names ~prefix ~original_types td_list + match id with + | TN [name] -> + (match Unique_name.translate_only name_registry name with + | Some x -> TN [x] + | None -> + (* must have been defined as abstract *) + id + ) + | TN _ as x -> x in - (List.map (fun td -> (Type td)) td_list, original_types) + List.map (fun (x : type_def) -> + { x with value = replace_type_names subst x.value } + ) defs + +let expand_type_defs + ?(prefix = "_") + ?keep_builtins + ?keep_poly + ?(debug = false) + td_list = + let td_list = expand ?keep_builtins ?keep_poly td_list in + if debug then td_list + else standardize_type_names ~prefix td_list diff --git a/atd/src/expand.mli b/atd/src/expand.mli index c3ee372d..32e95570 100644 --- a/atd/src/expand.mli +++ b/atd/src/expand.mli @@ -1,22 +1,11 @@ (** Monomorphization of type definitions *) -type original_types = (string, string * int) Hashtbl.t -(** To support the generation of annotations for types that are created - during the monomorphization process, a mapping must be kept connecting - the monomorphic type name to the original polymorphic one, including its - original number of parameters. - - This table is only used in producing those annotations to support the - Atdgen command line option -o-name-overlap. It can probably be ignored - for most uses of expand_module_body. -*) - -val expand_module_body : +val expand_type_defs : ?prefix:string -> ?keep_builtins:bool -> ?keep_poly:bool -> ?debug:bool -> - Ast.module_body -> Ast.module_body * original_types + Ast.type_def list -> Ast.type_def list (** Monomorphization of type expressions. diff --git a/atd/src/imports.ml b/atd/src/imports.ml new file mode 100644 index 00000000..8c44fa90 --- /dev/null +++ b/atd/src/imports.ml @@ -0,0 +1,52 @@ +(* + Manage external definitions via 'import' statements. +*) + +open Printf +open Ast + +(* Map local module name to import info. *) +type t = (string, import) Hashtbl.t + +let load imports = + (* keep track of full module names that were already loaded *) + let globals = Hashtbl.create 100 in + (* our main table *) + let locals = Hashtbl.create 100 in + imports + |> List.iter (fun (x : import) -> + let name = x.name in + if Hashtbl.mem locals name then + error_at x.loc + (sprintf +{|Local module name %s is shadowing another module of the same local name. +Consider using 'as' to give it a non-conflicting name.|} + name + ) + else if Hashtbl.mem globals x.path then + error_at x.loc + (sprintf "Module %s is loaded twice." (String.concat "." x.path)) + else ( + Hashtbl.add locals name x; + Hashtbl.add globals x.path () + ) + ); + locals + +let resolve locals loc (x : type_name) = + match Type_name.split x with + | None, base_name -> None, base_name + | Some module_name, base_name -> + (match Hashtbl.find_opt locals module_name with + | None -> + error_at loc (sprintf +{|Unknown module name %s. +Hint: + import %s +or + import xxx as %s +|} + module_name module_name module_name) + | Some import -> + Some import, base_name + ) diff --git a/atd/src/imports.mli b/atd/src/imports.mli new file mode 100644 index 00000000..ad0a9697 --- /dev/null +++ b/atd/src/imports.mli @@ -0,0 +1,47 @@ +(** + Manage external definitions via 'import' statements. + + Here's an import statement: + +{v + import fiz.buz.std_foo as foo + ^^^^^^^^^^^^^^^ + module name + ^^^ + local alias +v} + + This declares the existence of an external ATD module known globally as + [fiz.buz.std_foo]. Its local name would normally be the last component + of the dotted module name ([std_foo]) but since an alias is specified + with [as], that alias is the local name of the module. Aliases are useful + for disambiguating module names whose last component are identical + as well as for shortening them for convenience. + + A dotted type name such as [foo.bar] could occur anywhere as a type + expression and the presence of two components separated by a dot indicate + a type that's defined externally. Here's the anatomy of an external type: + +{v + type t = foo.bar list + ^^^ + local + module + name + ^^^ + type name +v} +*) + +(** A table holding the imports. *) +type t + +(** Load a list of imports and check that their local names are different. *) +val load : Ast.import list -> t + +(** Look up a type name to determine if it's defined externally. + If so, return the information about the imported module + (e.g. [import fiz.std_foo as foo]). Also return the type's base name + (last component e.g. [bar] in [foo.bar]). +*) +val resolve : t -> Ast.loc -> Ast.type_name -> (Ast.import option * string) diff --git a/atd/src/inherit.ml b/atd/src/inherit.ml index 8f33f027..068a361d 100644 --- a/atd/src/inherit.ml +++ b/atd/src/inherit.ml @@ -3,20 +3,11 @@ *) -open Import +open Stdlib_extra open Ast module S = Set.Make (String) - -let load_defs l = - let tbl = Predef.make_table () in - List.iter ( - fun ((_, (k, pl, _), _) as td) -> - Hashtbl.add tbl k (List.length pl, Some td) - ) l; - tbl - let keep_last_defined get_name l = let _, l = List.fold_right ( @@ -29,11 +20,11 @@ let keep_last_defined get_name l = l let get_field_name : field -> string = function - `Field (_, (k, _, _), _) -> k - | `Inherit _ -> assert false + | Field (_, (k, _, _), _) -> k + | Inherit _ -> assert false let get_variant_name : variant -> string = function - Variant (_, (k, _), _) -> k + | Variant (_, (k, _), _) -> k | Inherit _ -> assert false @@ -68,23 +59,23 @@ let expand ?(inherit_fields = true) ?(inherit_variants = true) tbl t0 = ) | List (loc, t, a) - | Name (loc, (_, "list", [t]), a) -> + | Name (loc, (_, TN ["list"], [t]), a) -> List (loc, subst false param t, a) | Option (loc, t, a) - | Name (loc, (_, "option", [t]), a) -> + | Name (loc, (_, TN ["option"], [t]), a) -> Option (loc, subst false param t, a) | Nullable (loc, t, a) - | Name (loc, (_, "nullable", [t]), a) -> + | Name (loc, (_, TN ["nullable"], [t]), a) -> Nullable (loc, subst false param t, a) | Shared (loc, t, a) - | Name (loc, (_, "shared", [t]), a) -> + | Name (loc, (_, TN ["shared"], [t]), a) -> Shared (loc, subst false param t, a) | Wrap (loc, t, a) - | Name (loc, (_, "wrap", [t]), a) -> + | Name (loc, (_, TN ["wrap"], [t]), a) -> Wrap (loc, subst false param t, a) | Tvar (_, s) -> Option.value (List.assoc s param) ~default:t @@ -92,13 +83,15 @@ let expand ?(inherit_fields = true) ?(inherit_variants = true) tbl t0 = | Name (loc, (loc2, k, args), a) -> let expanded_args = List.map (subst false param) args in if deref then - let _, vars, _, t = + let vars, t = try match Hashtbl.find tbl k with - _, Some (_, (k, vars, a), t) -> k, vars, a, t - | _, None -> failwith ("Cannot inherit from type " ^ k) + _, Some (x : type_def) -> x.param, x.value + | _, None -> failwith ("Cannot inherit from type " + ^ Print.tn k) with Not_found -> - failwith ("Missing type definition for " ^ k) + failwith ("Missing type definition for " + ^ Print.tn k) in let param = List.combine vars expanded_args in subst true param t @@ -106,8 +99,8 @@ let expand ?(inherit_fields = true) ?(inherit_variants = true) tbl t0 = Name (loc, (loc2, k, expanded_args), a) and subst_field param = function - `Field (loc, k, t) -> [ `Field (loc, k, subst false param t) ] - | `Inherit (_, t) as x -> + | Field (loc, k, t) -> [ Field (loc, k, subst false param t) ] + | Inherit (_, t) as x -> (match subst true param t with Record (_, vl, _) -> if inherit_fields then vl @@ -135,12 +128,12 @@ let expand ?(inherit_fields = true) ?(inherit_variants = true) tbl t0 = let expand_module_body ?inherit_fields ?inherit_variants - (l : Ast.module_body) = - let td_list = List.map (function (Ast.Type td) -> td) l in - let tbl = load_defs td_list in - let td_list = - List.map ( - fun (loc, name, t) -> - (loc, name, expand ?inherit_fields ?inherit_variants tbl t) - ) td_list in - List.map (fun td -> Ast.Type td) td_list + (_imports : Ast.import list) (defs : Ast.type_def list) = + (* TODO: use 'imports' to improve error messages when a user expects + 'inherit' to work on imported types *) + let tbl = Predef.make_table defs in + List.map (fun (x : type_def) -> + { x with + value = expand ?inherit_fields ?inherit_variants tbl x.value; + } + ) defs diff --git a/atd/src/inherit.mli b/atd/src/inherit.mli index 342e4567..86a5877b 100644 --- a/atd/src/inherit.mli +++ b/atd/src/inherit.mli @@ -3,7 +3,7 @@ val expand_module_body : ?inherit_fields : bool -> ?inherit_variants : bool -> - Ast.module_body -> Ast.module_body + Ast.import list -> Ast.type_def list -> Ast.type_def list (** Expand [inherit] statements found in sum types and product types. diff --git a/atd/src/json.ml b/atd/src/json.ml index 9d133956..b82e603b 100644 --- a/atd/src/json.ml +++ b/atd/src/json.ml @@ -59,6 +59,7 @@ type json_repr = | Float of json_float | Int | List of json_list + | Name | Nullable | Option | Record of json_record diff --git a/atd/src/json.mli b/atd/src/json.mli index 501cdbf3..d7740e82 100644 --- a/atd/src/json.mli +++ b/atd/src/json.mli @@ -54,6 +54,7 @@ type json_repr = | Float of json_float | Int | List of json_list + | Name (* type name *) | Nullable | Option | Record of json_record @@ -62,7 +63,7 @@ type json_repr = | Tuple | Unit | Variant of json_variant - | Wrap + | Wrap (* opaque type *) val annot_schema_json : Annot.schema diff --git a/atd/src/jsonschema.ml b/atd/src/jsonschema.ml index ae1c0151..16de1238 100644 --- a/atd/src/jsonschema.ml +++ b/atd/src/jsonschema.ml @@ -64,7 +64,7 @@ type t = { } let make_id type_name = - "#/definitions/" ^ type_name + "#/definitions/" ^ Print.tn type_name let trans_description_simple loc an = match Doc.get_doc loc an with @@ -99,7 +99,7 @@ let trans_type_expr ~xprop (x : Ast.type_expr) : type_expr = let fields = List.map (fun (x : field) -> match x with - | `Field ((loc, (name, kind, an), e) : simple_field) -> + | Field ((loc, (name, kind, an), e) : simple_field) -> let json_name = Json.get_json_fname name an in let required = match kind with @@ -114,7 +114,7 @@ let trans_type_expr ~xprop (x : Ast.type_expr) : type_expr = in let descr = trans_description loc an in ((json_name, trans_type_expr unwrapped_e, descr), required) - | `Inherit _ -> assert false + | Inherit _ -> assert false ) fl in let properties = List.map fst fields in @@ -133,7 +133,7 @@ let trans_type_expr ~xprop (x : Ast.type_expr) : type_expr = (match e, json_repr with | _, Array -> Array (trans_type_expr e) - | Tuple (loc, [(_, Name (_, (_, "string", _), _), _); + | Tuple (loc, [(_, Name (_, (_, TN ["string"], _), _), _); (_, value, _)], an2), Object -> Map (trans_type_expr value) | _, Object -> @@ -156,36 +156,36 @@ let trans_type_expr ~xprop (x : Ast.type_expr) : type_expr = | Tvar (loc, name) -> error_at loc "unsupported: parametrized types" | Name (loc, (loc2, name, args), a) -> (match name with - | "unit" -> Null - | "bool" -> Boolean - | "int" -> Integer - | "float" -> Number - | "string" -> String - | "abstract" -> Any + | TN ["unit"] -> Null + | TN ["bool"] -> Boolean + | TN ["int"] -> Integer + | TN ["float"] -> Number + | TN ["string"] -> String + | TN ["abstract"] -> Any | _ -> Ref (make_id name) ) in trans_type_expr x -let trans_item +let trans_def ~xprop - (Type (loc, (name, param, an), e) : module_item) : def = - if param <> [] then - error_at loc "unsupported: parametrized types"; - let description = trans_description_simple loc an in + (x : type_def) : def = + if x.param <> [] then + error_at x.loc "unsupported: parametrized types"; + let description = trans_description_simple x.loc x.annot in { - name; + name = (Print.tn x.name); description; - type_expr = trans_type_expr ~xprop e; + type_expr = trans_type_expr ~xprop x.value; } -let trans_full_module +let trans_module ~version ~xprop ~src_name ~root_type - ((head, body) : full_module) : t = - let defs = List.map (trans_item ~xprop) body in + (module_ : module_) : t = + let defs = List.map (trans_def ~xprop) module_.type_defs in let root_defs, defs = List.partition (fun x -> x.name = root_type) defs in let root_def = match root_defs with @@ -204,7 +204,7 @@ let trans_full_module - description of the whole module - description of the root type *) - let loc, an = head in + let loc, an = module_.module_head in let auto_comment = sprintf "Translated by atdcat from %s." src_name in [ Some auto_comment; @@ -362,7 +362,7 @@ let print ?(xprop = true) ~src_name ~root_type oc ast = ast - |> trans_full_module ~version ~xprop ~src_name ~root_type + |> trans_module ~version ~xprop ~src_name ~root_type |> to_json ~version |> Yojson.Safe.pretty_to_channel oc; output_char oc '\n' diff --git a/atd/src/jsonschema.mli b/atd/src/jsonschema.mli index 8a69be2e..2eedb77e 100644 --- a/atd/src/jsonschema.mli +++ b/atd/src/jsonschema.mli @@ -26,4 +26,4 @@ val print : ?xprop:bool -> src_name:string -> root_type:string -> - out_channel -> Ast.full_module -> unit + out_channel -> Ast.module_ -> unit diff --git a/atd/src/lexer.mll b/atd/src/lexer.mll index c5a7d5a9..8feca36d 100644 --- a/atd/src/lexer.mll +++ b/atd/src/lexer.mll @@ -1,6 +1,6 @@ { - open Import + open Stdlib_extra open Lexing open Parser @@ -104,6 +104,8 @@ rule token = parse | "?" { QUESTION } | "~" { TILDE } | "." { DOT } + | "import" { IMPORT } + | "as" { AS } | "type" { TYPE } | "of" { OF } | "inherit" { INHERIT } diff --git a/atd/src/parser.mly b/atd/src/parser.mly index bbc557ca..f6b6db79 100644 --- a/atd/src/parser.mly +++ b/atd/src/parser.mly @@ -4,7 +4,7 @@ requires menhir. */ %{ - open Import + open Stdlib_extra open Ast let syntax_error s pos1 pos2 = @@ -14,21 +14,25 @@ %token TYPE EQ OP_PAREN CL_PAREN OP_BRACK CL_BRACK OP_CURL CL_CURL SEMICOLON COMMA COLON STAR OF EOF BAR LT GT INHERIT - QUESTION TILDE DOT + QUESTION TILDE DOT IMPORT AS %token < string > STRING LIDENT UIDENT TIDENT -%start full_module -%type < Ast.full_module > full_module +%start module_ +%type < Ast.module_ > module_ %% -full_module: -| x = annot y = module_body { ((($startpos(x), $endpos(x)), x), y) } -; - -module_body: -| module_item module_body { $1 :: $2 } -| EOF { [] } -| _e=error { syntax_error "Syntax error" $startpos(_e) $endpos(_e) } +module_: +| an = annot; + imports = list(import); + type_defs = list(type_def); + EOF + { let loc = ($startpos(an), $endpos(an)) in + { + module_head = (loc, an); + imports; + type_defs; + } + } ; annot: @@ -63,10 +67,23 @@ lident_path: | LIDENT { [$1] } ; -module_item: - -| TYPE p = type_param s = LIDENT a = annot EQ t = type_expr - { Type (($startpos, $endpos), (s, p, a), t) } +type_def: +| TYPE; + p = type_param; + s = LIDENT; + a = annot EQ; + t = type_expr + { let loc = ($startpos, $endpos) in + let orig : type_def = { + loc; + name = TN [s]; + param = p; + annot = a; + value = t; + orig = None; + } in + ({ orig with orig = Some orig } : type_def) + } | TYPE type_param LIDENT annot EQ _e=error { syntax_error "Expecting type expression" $startpos(_e) $endpos(_e) } @@ -74,6 +91,22 @@ module_item: { syntax_error "Expecting '='" $startpos(_e) $endpos(_e) } | TYPE _e=error { syntax_error "Expecting type name" $startpos(_e) $endpos(_e) } + +import: +| IMPORT; + path = separated_nonempty_list(DOT, LIDENT); + alias = alias; + annot = annot; + { let loc = ($startpos, $endpos) in + (Ast.create_import + ~loc ~path ?alias ~annot () : import) } +| IMPORT; _e=error + { syntax_error "Expecting ATD module name" $startpos(_e) $endpos(_e) } +; + +alias: +| AS name = LIDENT { Some name } +| { None } ; type_param: @@ -106,16 +139,17 @@ type_expr: | OP_PAREN l = cartesian_product CL_PAREN a = annot { Tuple (($startpos, $endpos), l, a) } -| x = type_inst a = annot +| x = type_inst; + a = annot { let pos1 = $startpos in let pos2 = $endpos in let loc = (pos1, pos2) in let _, name, args = x in match name, args with - "list", [x] -> List (loc, x, a) - | "option", [x] -> Option (loc, x, a) - | "nullable", [x] -> Nullable (loc, x, a) - | "shared", [x] -> + | TN ["list"], [x] -> List (loc, x, a) + | TN ["option"], [x] -> Option (loc, x, a) + | TN ["nullable"], [x] -> Nullable (loc, x, a) + | TN ["shared"], [x] -> let a = if Annot.has_field ~sections:["share"] ~field:"id" a then (* may cause ID clashes if not used properly *) @@ -125,10 +159,11 @@ type_expr: ~section:"share" ~field:"id" (Some (Annot.create_id ())) a in Shared (loc, x, a) - | "wrap", [x] -> Wrap (loc, x, a) + | TN ["wrap"], [x] -> Wrap (loc, x, a) - | ("list"|"option"|"nullable"|"shared"|"wrap"), _ -> - syntax_error (sprintf "%s expects one argument" name) pos1 pos2 + | TN ["list"|"option"|"nullable"|"shared"|"wrap"], _ -> + syntax_error (sprintf "%s expects one argument" + (Print.tn name)) pos1 pos2 | _ -> (Name (loc, x, a) : type_expr) } @@ -154,7 +189,9 @@ annot_expr: ; type_inst: -| l = type_args s = LIDENT { (($startpos, $endpos), s, l) } +| args = type_args; + path = separated_nonempty_list(DOT, LIDENT) + { (($startpos, $endpos), TN path, args) } ; type_args: @@ -201,9 +238,9 @@ field_list: field: | fn = field_name a = annot COLON t = type_expr { let k, fk = fn in - `Field (($startpos, $endpos), (k, fk, a), t) } + Field (($startpos, $endpos), (k, fk, a), t) } | INHERIT t = type_expr - { `Inherit (($startpos, $endpos), t) } + { Inherit (($startpos, $endpos), t) } | field_name annot COLON _e=error { syntax_error "Expecting type expression after ':'" $startpos(_e) $endpos(_e) } diff --git a/atd/src/predef.ml b/atd/src/predef.ml index 4d820644..0e258efb 100644 --- a/atd/src/predef.ml +++ b/atd/src/predef.ml @@ -2,67 +2,139 @@ Table of predefined types. *) +open Printf open Ast +let set_orig (x : type_def) = { x with orig = Some x } + let list_def : type_def = let loc = dummy_loc in - ( - loc, - ("list", ["a"], []), - List (loc, Tvar (loc, "a"), []) - ) + set_orig { + loc; + name = TN ["list"]; + param = ["a"]; + annot = []; + value = List (loc, Tvar (loc, "a"), []); + orig = None; + } let option_def : type_def = let loc = dummy_loc in - ( - loc, - ("option", ["a"], []), - Option (loc, Tvar (loc, "a"), []) - ) + set_orig { + loc; + name = TN ["option"]; + param = ["a"]; + annot = []; + value = Option (loc, Tvar (loc, "a"), []); + orig = None; + } let nullable_def : type_def = let loc = dummy_loc in - ( - loc, - ("nullable", ["a"], []), - Nullable (loc, Tvar (loc, "a"), []) - ) + set_orig { + loc; + name = TN ["nullable"]; + param = ["a"]; + annot = []; + value = Nullable (loc, Tvar (loc, "a"), []); + orig = None; + } let shared_def : type_def = let loc = dummy_loc in - ( - loc, - ("shared", ["a"], []), - Shared (loc, Tvar (loc, "a"), []) - ) + set_orig { + loc; + name = TN ["shared"]; + param = ["a"]; + annot = []; + value = Shared (loc, Tvar (loc, "a"), []); + orig = None; + } let wrap_def : type_def = let loc = dummy_loc in - ( - loc, - ("wrap", ["a"], []), - Wrap (loc, Tvar (loc, "a"), []) - ) - + set_orig { + loc; + name = TN ["wrap"]; + param = ["a"]; + annot = []; + value = Wrap (loc, Tvar (loc, "a"), []); + orig = None; + } let list = [ - "unit", 0, None; - "bool", 0, None; - "int", 0, None; - "float", 0, None; - "string", 0, None; - "abstract", 0, None; - "list", 1, Some list_def; - "option", 1, Some option_def; - "nullable", 1, Some nullable_def; - "shared", 1, Some shared_def; - "wrap", 1, Some wrap_def; + TN ["unit"], 0, None; + TN ["bool"], 0, None; + TN ["int"], 0, None; + TN ["float"], 0, None; + TN ["string"], 0, None; + TN ["abstract"], 0, None; + TN ["list"], 1, Some list_def; + TN ["option"], 1, Some option_def; + TN ["nullable"], 1, Some nullable_def; + TN ["shared"], 1, Some shared_def; + TN ["wrap"], 1, Some wrap_def; ] -let make_table () = - let tbl = Hashtbl.create 20 in +type table = (type_name, int * Ast.type_def option) Hashtbl.t + +let make_table user_defs : table = + let predef : table = Hashtbl.create 20 in + (* add predefined types *) List.iter ( fun (k, n, opt_t) -> - Hashtbl.add tbl k (n, opt_t) + if Hashtbl.mem predef k then + invalid_arg ("Predef.make_table: duplicate entry " ^ Print.tn k) + else + Hashtbl.add predef k (n, opt_t) ) list; + let tbl = Hashtbl.copy predef in + (* add user definitions *) + List.iter ( + fun (x : type_def) -> + let name = x.name in + let loc = x.loc in + if Hashtbl.mem tbl name then + if Hashtbl.mem predef name then + error_at loc + (sprintf "%s is a predefined type, it cannot be redefined." + (Print.tn name)) + else + error_at loc + (sprintf "Type %s is defined for the second time." + (Print.tn name)) + else + Hashtbl.add tbl name (List.length x.param, Some x) + ) user_defs; tbl + +let rec get_original_definition tbl name = + match Hashtbl.find_opt tbl name with + | None -> None + | Some (n, opt_def) as res -> + match opt_def with + | None -> res + | Some def -> + match def.value with + | Name (loc, (loc2, name, args), an ) -> + (match get_original_definition tbl name with + | None -> res + | Some _ as res -> res + ) + | _ -> res + +let get_construct tbl name = + match get_original_definition tbl name with + | None -> None + | Some (_n, None) -> None + | Some (n, Some def) -> Some (n, def.value) + +let get_construct_of_expr tbl (x : type_expr) = + match x with + | Name (loc, (loc2, name, []), an) -> + (match get_original_definition tbl name with + | None -> None + | Some (_n, None) -> Some x + | Some (n, Some def) -> Some def.value + ) + | construct -> Some construct diff --git a/atd/src/predef.mli b/atd/src/predef.mli index 6a64fce7..70d150c4 100644 --- a/atd/src/predef.mli +++ b/atd/src/predef.mli @@ -1,5 +1,44 @@ (** The collection of core types known by ATD. *) -val list : (string * int * Ast.type_def option) list +(** List of all predefined type names with their arity and their definition + if applicable. -val make_table : unit -> (string, int * Ast.type_def option) Hashtbl.t + The parametrized types [list], [option], etc. all have a definition + while the simple types like [bool] and [int] have an entry in the list + but no associated definition ([None]). +*) +val list : (Ast.type_name * int * Ast.type_def option) list + +type table = (Ast.type_name, int * Ast.type_def option) Hashtbl.t + +(** Create a lookup table from the list of predefined type definitions + and extra definitions. *) +val make_table : Ast.type_def list -> table + +(** De-alias a type name recursively. + This is useful to determine the actual type constructor behind a name. + For this, see also [get_construct]. + For example, looking up ["special"] given the + ATD definition [type special = int list] would return the definition + for ["list"]. +*) +val get_original_definition : + table -> Ast.type_name -> (int * Ast.type_def option) option + +(** Determine the type construct by returning the right-handside of the + original type definition associated with type alias. + For example, looking up ["special"] given the + ATD definition [type special = int list] would return + [(1, List ...)] where [1] indicates that the type expression depends on + one type parameter. +*) +val get_construct : + table -> Ast.type_name -> (int * Ast.type_expr) option + +(** Determine the type construct associated with a type expression. + The result may be [Name] only if it's a predefined type. If a type + name is undefined, the result is [None]. + This is intended for determining default values. +*) +val get_construct_of_expr : + table -> Ast.type_expr -> Ast.type_expr option diff --git a/atd/src/print.ml b/atd/src/print.ml index eab8929c..6e09f712 100644 --- a/atd/src/print.ml +++ b/atd/src/print.ml @@ -52,7 +52,7 @@ let format_prop (k, (_, opt)) = (make_atom (quote_string s)) ) -let default_annot (s, (_, l)) = +let default_format_annot (s, (_, l)) = match l with [] -> make_atom ("<" ^ s ^ ">") | l -> @@ -69,6 +69,7 @@ let default_annot (s, (_, l)) = ] ) +let tn = Type_name.to_string let string_of_field k = function Required -> k @@ -76,7 +77,7 @@ let string_of_field k = function | With_default -> "~" ^ k -let make_closures format_annot = +let format ?(format_annot = default_format_annot) any = let append_annots (l : annot) x = match l with @@ -102,33 +103,7 @@ let make_closures format_annot = ) in - let rec format_module_item (x : module_item) = - match x with - Type (_, (s, param, a), t) -> - let left = - if a = [] then - let l = - make_atom "type" :: - prepend_type_param param - [ make_atom (s ^ " =") ] - in - horizontal_sequence l - else - let l = - make_atom "type" - :: prepend_type_param param [ make_atom s ] - in - let x = append_annots a (horizontal_sequence l) in - horizontal_sequence [ x; make_atom "=" ] - in - Label ( - (left, label), - format_type_expr t - ) - - - - and prepend_type_param l tl = + let rec prepend_type_param l tl = match l with [] -> tl | _ -> @@ -144,7 +119,7 @@ let make_closures format_annot = match l with [] -> tl | _ -> - let x = + let x : t = match l with [t] -> format_type_expr t | l -> List (("(", ",", ")", plist), List.map format_type_expr l) @@ -171,7 +146,7 @@ let make_closures format_annot = append_annots a ( List ( ("(", "*", ")", lplist), - List.map format_tuple_field l + List.map format_cell l ) ) @@ -191,7 +166,7 @@ let make_closures format_annot = format_type_name "wrap" [t] a | Name (_, (_, name, args), a) -> - format_type_name name args a + format_type_name (tn name) args a | Tvar (_, name) -> make_atom ("'" ^ name) @@ -204,12 +179,12 @@ let make_closures format_annot = and format_inherit t = horizontal_sequence [ make_atom "inherit"; format_type_expr t ] - and format_tuple_field (_, x, a) = + and format_cell (_, x, a) = prepend_colon_annots a (format_type_expr x) and format_field x = match x with - `Field (_, (k, fk, a), t) -> + | Field (_, (k, fk, a), t) -> Label ( (horizontal_sequence0 [ append_annots a (make_atom (string_of_field k fk)); @@ -217,7 +192,7 @@ let make_closures format_annot = ], label), format_type_expr t ) - | `Inherit (_, t) -> format_inherit t + | Inherit (_, t) -> format_inherit t and format_variant x = match x with @@ -237,28 +212,66 @@ let make_closures format_annot = | Inherit (_, t) -> format_inherit t in - let format_full_module ((_, an), l) = + let format_import ({ loc = _; path; alias; name; annot } : import) = + let opt_alias = + match alias with + | None -> [] + | Some local_name -> [make_atom ("as " ^ local_name)] + in + make_atom "import" :: make_atom (String.concat "." path) :: opt_alias + |> horizontal_sequence + |> append_annots annot + in + + let format_type_def (x : type_def) = + let left = + if x.annot = [] then + let l = + make_atom "type" :: + prepend_type_param x.param + [ make_atom (tn x.name ^ " =") ] + in + horizontal_sequence l + else + let l = + make_atom "type" + :: prepend_type_param x.param [ make_atom (tn x.name) ] + in + let x = append_annots x.annot (horizontal_sequence l) in + horizontal_sequence [ x; make_atom "=" ] + in + Label ( + (left, label), + format_type_expr x.value + ) + in + + let format_module (x : module_) = Easy_format.List ( ("", "", "", rlist), - List.map format_annot an @ List.map format_module_item l + List.map format_annot (snd x.module_head) + @ List.map format_import x.imports + @ List.map format_type_def x.type_defs ) in - format_full_module, format_type_name, format_type_expr - - - -let format ?(annot = default_annot) x = - let f, _, _ = make_closures annot in - f x + let format_any (x : any) = + match x with + | Module x -> format_module x + | Import x -> format_import x + | Type_def x -> format_type_def x + | Type_expr x -> format_type_expr x + | Variant x -> format_variant x + | Cell x -> format_cell x + | Field x -> format_field x + in -let _default_format, default_format_type_name, default_format_type_expr = - make_closures default_annot + format_any any -let string_of_type_name name args an = - let x = default_format_type_name name args an in - Easy_format.Pretty.to_string x +let to_string ?format_annot x = + format ?format_annot x + |> Easy_format.Pretty.to_string -let string_of_type_expr expr = - let x = default_format_type_expr expr in - Easy_format.Pretty.to_string x +let string_of_type_inst name args an = + let loc = dummy_loc in + to_string (Type_expr (Name (loc, (loc, name, args), an))) diff --git a/atd/src/print.mli b/atd/src/print.mli index 05881923..eb0c6fbc 100644 --- a/atd/src/print.mli +++ b/atd/src/print.mli @@ -1,22 +1,25 @@ (** Pretty-printing of ATD data *) -val default_annot : Ast.annot_section -> Easy_format.t +val default_format_annot : Ast.annot_section -> Easy_format.t +(** Same as [format] but works on any kind of node wrapped into [any] + e.g. [format_any (Variant x)]. +*) val format : - ?annot: (Ast.annot_section -> Easy_format.t) -> - Ast.full_module -> Easy_format.t - (** Pretty-printing. Use the functions of the [Easy_format.Pretty] - module to convert an [Easy_format.t] into a string - or add it to a channel or buffer. + ?format_annot: (Ast.annot_section -> Easy_format.t) -> + Ast.any -> Easy_format.t - @param annot can be used to specify another way of formatting - annotations. The default is available as - [default_format_annot]. - *) +(** Turn any AST node into a string. See also [format]. *) +val to_string : + ?format_annot: (Ast.annot_section -> Easy_format.t) -> + Ast.any -> string -val string_of_type_name : - string -> Ast.type_expr list -> Ast.annot -> string - (** Convert a type name with its arguments and its annotations - into a string. *) +(** Convert a type name with its arguments and its annotations + into a string. *) +val string_of_type_inst : + Ast.type_name -> Ast.type_expr list -> Ast.annot -> string -val string_of_type_expr : Ast.type_expr -> string +(** Concatenate the components of a type name into a string. + For example, [TN ["foo"; "bar"]] gives ["foo.bar"]. + Shorthand for [Type_name.to_string]. *) +val tn : Ast.type_name -> string diff --git a/atd/src/reflect.ml b/atd/src/reflect.ml index 60747ed8..cbcba0c7 100644 --- a/atd/src/reflect.ml +++ b/atd/src/reflect.ml @@ -2,7 +2,7 @@ Conversion of an ATD tree to OCaml source code for that value. *) -open Import +open Stdlib_extra let print_loc buf (_, _) = bprintf buf "loc" @@ -37,52 +37,52 @@ let print_annot_list buf l = let rec print_type_expr buf (x : Ast.type_expr) = match x with | Sum (loc, variant_list, annot_list) -> - bprintf buf "`Sum (%a, %a, %a)" + bprintf buf "Sum (%a, %a, %a)" print_loc loc (print_list print_variant) variant_list print_annot_list annot_list | Record (loc, field_list, annot_list) -> - bprintf buf "`Record (%a, %a, %a)" + bprintf buf "Record (%a, %a, %a)" print_loc loc (print_list print_field) field_list print_annot_list annot_list | Tuple (loc, cell_list, annot_list) -> - bprintf buf "`Tuple (%a, %a, %a)" + bprintf buf "Tuple (%a, %a, %a)" print_loc loc (print_list print_cell) cell_list print_annot_list annot_list | List (loc, type_expr, annot_list) -> - bprintf buf "`List (%a, %a, %a)" + bprintf buf "List (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | Option (loc, type_expr, annot_list) -> - bprintf buf "`Option (%a, %a, %a)" + bprintf buf "Option (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | Nullable (loc, type_expr, annot_list) -> - bprintf buf "`Nullable (%a, %a, %a)" + bprintf buf "Nullable (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | Shared (loc, type_expr, annot_list) -> - bprintf buf "`Shared (%a, %a, %a)" + bprintf buf "Shared (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | Wrap (loc, type_expr, annot_list) -> - bprintf buf "`Wrap (%a, %a, %a)" + bprintf buf "Wrap (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | Name (loc, type_inst, annot_list) -> - bprintf buf "`Name (%a, %a, %a)" + bprintf buf "Name (%a, %a, %a)" print_loc loc print_type_inst type_inst print_annot_list annot_list | Tvar (loc, string) -> - bprintf buf "`Tvar (%a, %S)" + bprintf buf "Tvar (%a, %S)" print_loc loc string @@ -95,65 +95,80 @@ and print_cell buf (loc, x, a) = and print_variant buf x = match x with Variant (loc, (s, a), o) -> - bprintf buf "`Variant (%a, (%S, %a), %a)" + bprintf buf "Variant (%a, (%S, %a), %a)" print_loc loc s print_annot_list a (print_opt print_type_expr) o | Inherit (loc, x) -> - bprintf buf "`Inherit (%a, %a)" + bprintf buf "Inherit (%a, %a)" print_loc loc print_type_expr x -and print_field buf x = +and print_field buf (x : Ast.field) = match x with - `Field (loc, (s, kind, a), x) -> - bprintf buf "`Field (%a, (%S, %a, %a), %a)" - print_loc loc - s print_field_kind kind print_annot_list a - print_type_expr x - | `Inherit (loc, x) -> - bprintf buf "`Inherit (%a, %a)" - print_loc loc - print_type_expr x + | Field (loc, (s, kind, a), x) -> + bprintf buf "Field (%a, (%S, %a, %a), %a)" + print_loc loc + s print_field_kind kind print_annot_list a + print_type_expr x + | Inherit (loc, x) -> + bprintf buf "Inherit (%a, %a)" + print_loc loc + print_type_expr x and print_field_kind buf fk = Buffer.add_string buf (match fk with - Required -> "`Required" - | Optional -> "`Optional" - | With_default -> "`With_default") + Required -> "Required" + | Optional -> "Optional" + | With_default -> "With_default") -and print_type_inst buf (loc, s, l) = +and print_type_inst buf (loc, name, l) = bprintf buf "(%a, %S, %a)" print_loc loc - s + (Print.tn name) (print_list print_type_expr) l - -let print_module_item buf (Ast.Type (loc, (name, param, a), x)) = - bprintf buf "`Type (%a, (%S, %a, %a), %a)" +let print_import buf ({ loc; path; alias; name; annot } : Ast.import) = + bprintf buf "{ loc = %a; path = %a; alias = %a; name = %S; annot = %a }" print_loc loc - name (print_list print_qstring) param print_annot_list a - print_type_expr x - -let print_module_body buf l = + (print_list print_qstring) path + (print_opt print_qstring) alias + name + print_annot_list annot + +let rec print_type_def buf (x: Ast.type_def) = + bprintf buf "{ loc = %a; name = %S; param = %a; annot = %a; \ + value = %a; orig = %a; } " + print_loc x.loc + (Print.tn x.name) + (print_list print_qstring) x.param print_annot_list x.annot + print_type_expr x.value + (print_opt print_type_def) x.orig + +let print_list print_item buf l = bprintf buf "[\n"; List.iter (fun x -> - print_module_item buf x; - bprintf buf ";\n" - ) l; + print_item buf x; + bprintf buf ";\n" + ) l; bprintf buf "]\n" -let print_module_body_def buf name l = +let print_imports_def buf name l = bprintf buf "\ -let %s_body : Ast.module_body = +let %s_imports : Ast.imports list = let loc = Ast.dummy_loc in %a +" + name (print_list print_import) l -let %s = %s_body (* for backward compatibility with atd <= 1.0.1 *) +let print_type_defs_def buf name l = + bprintf buf "\ +let %s_type_defs : Ast.type_defs list = + let loc = Ast.dummy_loc in +%a " - name print_module_body l - name name + name (print_list print_type_def) l let print_module_head_def buf name an = bprintf buf "\ @@ -163,11 +178,15 @@ let %s_head : Ast.module_head = " name print_annot_list an -let print_full_module_def buf name ((_, an), l) = - print_module_head_def buf name an; - print_module_body_def buf name l; +let print_module_def buf name (x : Ast.module_) = + print_module_head_def buf name (snd x.module_head); + print_imports_def buf name x.imports; + print_type_defs_def buf name x.type_defs; bprintf buf "\ -let %s_full : Ast.full_module = - (%s_head, %s_body) +let %s_full : Ast.module_ = { + module_head = %s_head; + imports = %s_imports; + type_defs = %s_type_defs; +} " - name name name + name name name name diff --git a/atd/src/reflect.mli b/atd/src/reflect.mli index 2d09de98..53b94bbf 100644 --- a/atd/src/reflect.mli +++ b/atd/src/reflect.mli @@ -2,8 +2,8 @@ Conversion of an AST value into OCaml source code that creates this value *) -val print_full_module_def : Buffer.t -> string -> Ast.full_module -> unit +val print_module_def : Buffer.t -> string -> Ast.module_ -> unit (** - [print_full_module_def buf name x] prints OCaml source code + [print_module_def buf name x] prints OCaml source code that would construct the given ATD tree [x] and call it [name]. *) diff --git a/atd/src/sort.ml b/atd/src/sort.ml index 324dfc81..39ec28e9 100644 --- a/atd/src/sort.ml +++ b/atd/src/sort.ml @@ -14,7 +14,7 @@ http://scienceblogs.com/goodmath/2007/10/30/computing-strongly-connected-c/ *) -open Import +open Stdlib_extra module type Param = sig diff --git a/atd/src/import.ml b/atd/src/stdlib_extra.ml similarity index 97% rename from atd/src/import.ml rename to atd/src/stdlib_extra.ml index da85e84a..659be005 100644 --- a/atd/src/import.ml +++ b/atd/src/stdlib_extra.ml @@ -1,3 +1,7 @@ +(* + Various general-purpose utilities. +*) + module List = struct include List diff --git a/atd/src/type_name.ml b/atd/src/type_name.ml new file mode 100644 index 00000000..0519635a --- /dev/null +++ b/atd/src/type_name.ml @@ -0,0 +1,25 @@ +(* + Utilities for manipulating type names, since they're not plain strings. +*) + +type t = TN of string list + +let compare = Stdlib.compare +let equal = Stdlib.(=) + +let to_string (TN path) = String.concat "." path + +let basename name = + match name with + | TN [base_name] + | TN [_; base_name] -> base_name + | TN [] -> invalid_arg "Type_name.basename: empty name" + | TN (_ :: _ as path) -> List.rev path |> List.hd + +let split name = + match name with + | TN [base_name] -> None, base_name + | TN [local_module_name; base_name] -> Some local_module_name, base_name + | TN [] -> invalid_arg "Type_name.split: empty name" + | TN _ -> invalid_arg ("Type_name.split: more than two components in " + ^ to_string name) diff --git a/atd/src/type_name.mli b/atd/src/type_name.mli new file mode 100644 index 00000000..65bcbbe6 --- /dev/null +++ b/atd/src/type_name.mli @@ -0,0 +1,38 @@ +(** + Utilities for manipulating type names as found in the ATD AST. + + This module can serve as the input to Map or Set functors. e.g. +{v + module Names = Set.Make (Type_name) +v} +*) + +(** The type of a type name. + + The simple ATD type name [a] is represented as [TN ["a"]]. + The composite ATD type name [a.b.c] is represented as [TN ["a"; "b"; "c"]]. + + ATD type definitions normally have a single component. + The list of path components may not be empty. + Two components indicate a type provided by an external module. + + At the moment, the semantics of imports doesn't allow type names of + more than two components. +*) +type t = TN of string list + +val compare : t -> t -> int +val equal : t -> t -> bool + +(** Format to a string in ATD syntax. + For example, [TN ["a"; "b"]] gives [a.b]. *) +val to_string : t -> string + +(** Return the base name, i.e. the last component in the path. *) +val basename : t -> string + +(** Return the module name if any, and the base name. + An exception is raised if the number of path components is other than + 1 or 2. +*) +val split : t -> string option * string diff --git a/atd/src/util.ml b/atd/src/util.ml index cd186d12..cd63df8f 100644 --- a/atd/src/util.ml +++ b/atd/src/util.ml @@ -11,26 +11,31 @@ let read_lexbuf lexbuf = Lexer.init_fname lexbuf pos_fname pos_lnum; - let head, body = Parser.full_module Lexer.token lexbuf in - Check.check body; - let body = + let module_ = Parser.module_ Lexer.token lexbuf in + Check.check module_; + let type_defs = if inherit_fields || inherit_variants then - Inherit.expand_module_body ~inherit_fields ~inherit_variants body + Inherit.expand_module_body ~inherit_fields ~inherit_variants + module_.imports module_.type_defs else - body + module_.type_defs in - let (body, original_types) = + let type_defs = if expand then - Expand.expand_module_body ?keep_builtins ?keep_poly ~debug: xdebug body - else (body, Hashtbl.create 0) + Expand.expand_type_defs ?keep_builtins ?keep_poly ~debug: xdebug + type_defs + else + type_defs + in + let module_ = + { module_ with type_defs } in - let full_module = (head, body) in (match annot_schema with | None -> () | Some schema -> - Annot.validate schema (Ast.Full_module full_module) + Annot.validate schema (Ast.Module module_) ); - (full_module, original_types) + module_ let read_channel ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug @@ -82,25 +87,29 @@ let load_string module Tsort = Sort.Make ( struct - type t = Ast.module_item - type id = string (* type name *) - - let id def = - let Ast.Type (_, (name, _, _), _) = def in - name - - let to_string name = name + type t = Ast.type_def + type id = Ast.type_name + let id (x : t) = x.name + let to_string name = Print.tn name end ) -let tsort l0 = - let ignorable = [ "unit"; "bool"; "int"; "float"; "string"; "abstract" ] in - let l = - List.map ( - fun def -> - let Ast.Type (_, (_, _, _), x) = def in - let deps = Ast.extract_type_names ~ignorable x in - (def, deps) - ) l0 - in - List.rev (Tsort.sort l) +let tsort ?(all_rec = false) type_defs0 = + let ignorable : Ast.type_name list = [ + TN ["unit"]; + TN ["bool"]; + TN ["int"]; + TN ["float"]; + TN ["string"]; + TN ["abstract"] + ] in + if all_rec then + [(true, type_defs0)] + else + let type_defs = + List.map (fun (x : Ast.type_def) -> + let deps = Ast.extract_type_names ~ignorable x.value in + (x, deps) + ) type_defs0 + in + List.rev (Tsort.sort type_defs) diff --git a/atd/src/util.mli b/atd/src/util.mli index aeb0e258..69badca2 100644 --- a/atd/src/util.mli +++ b/atd/src/util.mli @@ -10,7 +10,7 @@ val read_lexbuf : ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> - Lexing.lexbuf -> Ast.full_module * Expand.original_types + Lexing.lexbuf -> Ast.module_ (** Read an ATD file from a lexbuf. See also [read_channel], [load_file] and [load_string]. @@ -66,7 +66,7 @@ val read_channel : ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> - in_channel -> Ast.full_module * Expand.original_types + in_channel -> Ast.module_ (** Read an ATD file from an [in_channel]. Options: see [read_lexbuf]. The default [pos_fname] is set to [""] when appropriate. *) @@ -80,7 +80,7 @@ val load_file : ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> - string -> Ast.full_module * Expand.original_types + string -> Ast.module_ (** Read an ATD file. Options: see [read_lexbuf]. The default [pos_fname] is the given input file name. *) @@ -94,11 +94,12 @@ val load_string : ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> - string -> Ast.full_module * Expand.original_types + string -> Ast.module_ (** Read ATD data from a string. Options: see [read_lexbuf]. *) val tsort : - Ast.module_body -> (bool * Ast.module_body) list + ?all_rec:bool -> + Ast.type_def list -> (bool * Ast.type_def list) list (** Topological sort for dependency analysis. [tsort] splits definitions into mutually-recursive groups, @@ -106,4 +107,7 @@ val tsort : of its own group or previous groups. The boolean flags indicate groups of one or more mutually recursive definitions. + + @param all_rec assume all definitions are mutually dependent, skipping + actual topological sorting. *) diff --git a/atd/test/annot.ml b/atd/test/annot.ml index d830ba3e..679c9453 100644 --- a/atd/test/annot.ml +++ b/atd/test/annot.ml @@ -31,13 +31,13 @@ let schema : Atd.Annot.schema = [ ] let test_valid_input atd_input = - let root, _orig_types = Atd.Util.load_string atd_input in - Atd.Annot.validate schema (Atd.Ast.Full_module root) + let root = Atd.Util.load_string atd_input in + Atd.Annot.validate schema (Atd.Ast.Module root) let test_invalid_input atd_input = - let root, _orig_types = Atd.Util.load_string atd_input in + let root = Atd.Util.load_string atd_input in try - Atd.Annot.validate schema (Atd.Ast.Full_module root); + Atd.Annot.validate schema (Atd.Ast.Module root); assert false with Atd.Ast.Atd_error msg -> printf "Error (expected): %s\n%!" msg diff --git a/atdcat/src/atdcat.ml b/atdcat/src/atdcat.ml index 9363522f..c3c65ae9 100644 --- a/atdcat/src/atdcat.ml +++ b/atdcat/src/atdcat.ml @@ -1,4 +1,5 @@ -open Atd.Import +open Atd.Stdlib_extra +open Atd.Ast type out_format = | Atd @@ -40,23 +41,23 @@ let format_html_comments ((section, (_, l)) as x) = | Some _ | None -> begin match List.assoc "text" l with | Some (loc, Some s) -> comment (html_of_doc loc s) - | Some _ | None -> Atd.Print.default_annot x + | Some _ | None -> Atd.Print.default_format_annot x end end - | _ -> Atd.Print.default_annot x + | _ -> Atd.Print.default_format_annot x let print_atd ~html_doc oc ast = - let annot = + let format_annot = if html_doc then Some format_html_comments else None in - let pp = Atd.Print.format ?annot ast in + let pp = Atd.Print.format ?format_annot ast in Easy_format.Pretty.to_channel oc pp; output_string oc "\n" let print_ml ~name oc ast = let buf = Buffer.create 1000 in - Atd.Reflect.print_full_module_def buf name ast; + Atd.Reflect.print_module_def buf name ast; output_string oc (Buffer.contents buf); output_string oc "\n" @@ -73,44 +74,42 @@ let parse ~annot_schema ~expand ~keep_poly ~xdebug ~inherit_fields ~inherit_variants ~strip_all ~strip_sections files = - let l = + let modules = List.map ( - fun file -> - fst ( - Atd.Util.load_file ~annot_schema ~expand ~keep_poly ~xdebug - ~inherit_fields ~inherit_variants file - ) + Atd.Util.load_file ~annot_schema ~expand ~keep_poly ~xdebug + ~inherit_fields ~inherit_variants ) files in - let heads, bodies = List.split l in let first_head = (* heads in other files than the first one are tolerated but ignored *) - match heads with - x :: _ -> x + match modules with + { module_head; _ } :: _ -> module_head | [] -> (Atd.Ast.dummy_loc, []) in - let m = first_head, List.flatten bodies in - strip strip_all strip_sections m + let module_ = { + module_head = first_head; + imports = List.map (fun x -> x.imports) modules |> List.flatten; + type_defs = List.map (fun x -> x.type_defs) modules |> List.flatten; + } in + strip strip_all strip_sections module_ let print ~xprop ~jsonschema_version - ~src_name ~html_doc ~out_format ~out_channel:oc ast = - let f = - match out_format with - | Atd -> print_atd ~html_doc - | Ocaml name -> print_ml ~name - | Jsonschema root_type -> - Atd.Jsonschema.print - ~xprop - ~version:jsonschema_version - ~src_name ~root_type - in - f oc ast + ~src_name ~html_doc ~out_format ~out_channel:oc module_ = + match out_format with + | Atd -> print_atd ~html_doc oc (Module module_) + | Ocaml name -> print_ml ~name oc module_ + | Jsonschema root_type -> + Atd.Jsonschema.print + ~xprop + ~version:jsonschema_version + ~src_name ~root_type + oc module_ let split_on_comma = Re.Str.split_delim (Re.Str.regexp ",") -let () = +let run () = let expand = ref false in let keep_poly = ref false in let xdebug = ref false in @@ -210,6 +209,7 @@ let () = in let msg = sprintf "Usage: %s FILE" Sys.argv.(0) in Arg.parse options (fun file -> input_files := file :: !input_files) msg; + Printexc.record_backtrace true; try let force_inherit, annot_schema = match !out_format with @@ -255,4 +255,12 @@ let () = flush stdout; eprintf "%s\n%!" msg; exit 1 - | e -> raise e + | e -> + let trace = Printexc.get_backtrace () in + flush stdout; + eprintf "Exception %s:\n%s%!" + (Printexc.to_string e) + trace; + exit 1 + +let () = run () diff --git a/atdcat/test/test.atd b/atdcat/test/test.atd index d425af70..f377f72c 100644 --- a/atdcat/test/test.atd +++ b/atdcat/test/test.atd @@ -3,6 +3,13 @@ +import datetime +import fiz.buz.fleeb +import fiz.buz.floob +import floob as floob2 + +type with_external_types = (datetime.date * floob.t * floob2.t) + (* Double-quotes "\"" in comments must be matched. *) (* Don't worry about unmatched single quotes in comments. *) type test_string_syntax = int diff --git a/atdgen/bin/ag_main.ml b/atdgen/bin/ag_main.ml index 612ac411..3909cfcb 100644 --- a/atdgen/bin/ag_main.ml +++ b/atdgen/bin/ag_main.ml @@ -1,4 +1,4 @@ -open Atd.Import +open Atd.Stdlib_extra open Atdgen_emit let append l1 l2 = @@ -71,10 +71,10 @@ let main () = let l = Re.Str.split (Re.Str.regexp " *, *\\| +") s in opens := List.rev_append l !opens in - let pp_convs : Ocaml.pp_convs ref = ref (Ocaml.Ppx_deriving []) in + let pp_convs : Ocaml_repr.pp_convs ref = ref (Ocaml_repr.Ppx_deriving []) in let set_pp_convs arg = match !pp_convs with - | Ocaml.Camlp4 [] | Ppx_deriving [] | Ppx [] -> + | Camlp4 [] | Ppx_deriving [] | Ppx [] -> pp_convs := arg | _ -> match !pp_convs, arg with @@ -92,13 +92,14 @@ let main () = type-conv preprocessor "; "-deriving-conv", Arg.String (fun s -> - set_pp_convs (Ocaml.Ppx_deriving (Re.Str.split (Re.Str.regexp ",") s))), + set_pp_convs (Ocaml_repr.Ppx_deriving + (Re.Str.split (Re.Str.regexp ",") s))), " GEN1,GEN2,... Insert '[@@deriving GEN1,GEN2,...]' after OCaml type definitions for the ppx_deriving preprocessor "; - "-type-attr", Arg.String (fun s -> set_pp_convs (Ocaml.Ppx [ s ])), + "-type-attr", Arg.String (fun s -> set_pp_convs (Ocaml_repr.Ppx [ s ])), " ATTR Insert '[@@ATTR]' after OCaml type definitions. diff --git a/atdgen/src/mapping.ml b/atdgen/src/mapping.ml index fdae797b..41422dcf 100644 --- a/atdgen/src/mapping.ml +++ b/atdgen/src/mapping.ml @@ -1,11 +1,11 @@ -open Atd.Import +open Atd.Stdlib_extra type loc = Atd.Ast.loc (* Generic mapping, based on the core ATD types *) -type ('a, 'b) mapping = +type ('a, 'b) t = | Unit of loc * 'a * 'b | Bool of loc * 'a * 'b | Int of loc * 'a * 'b @@ -15,17 +15,20 @@ type ('a, 'b) mapping = | Sum of loc * ('a, 'b) variant_mapping array * 'a * 'b | Record of loc * ('a, 'b) field_mapping array * 'a * 'b | Tuple of loc * ('a, 'b) cell_mapping array * 'a * 'b - | List of loc * ('a, 'b) mapping * 'a * 'b - | Option of loc * ('a, 'b) mapping * 'a * 'b - | Nullable of loc * ('a, 'b) mapping * 'a * 'b - | Wrap of loc * ('a, 'b) mapping * 'a * 'b - | Name of loc * string * ('a, 'b) mapping list * 'a option * 'b option - | External of loc * string * ('a, 'b) mapping list * 'a * 'b + | List of loc * ('a, 'b) t * 'a * 'b + | Option of loc * ('a, 'b) t * 'a * 'b + | Nullable of loc * ('a, 'b) t * 'a * 'b + | Wrap of loc * ('a, 'b) t * 'a * 'b + | Name of loc + * Atd.Ast.type_name + * ('a, 'b) t list + * 'a * 'b + | External of loc * string * ('a, 'b) t list * 'a * 'b | Tvar of loc * string and ('a, 'b) cell_mapping = { cel_loc : loc; - cel_value : ('a, 'b) mapping; + cel_value : ('a, 'b) t; cel_arepr : 'a; cel_brepr : 'b } @@ -34,7 +37,7 @@ and ('a, 'b) field_mapping = { f_loc : loc; f_name : string; f_kind : Atd.Ast.field_kind; - f_value : ('a, 'b) mapping; + f_value : ('a, 'b) t; f_arepr : 'a; f_brepr : 'b } @@ -42,7 +45,7 @@ and ('a, 'b) field_mapping = { and ('a, 'b) variant_mapping = { var_loc : loc; var_cons : string; - var_arg : ('a, 'b) mapping option; + var_arg : ('a, 'b) t option; var_arepr : 'a; var_brepr : 'b } @@ -51,13 +54,17 @@ type ('a, 'b) def = { def_loc : loc; def_name : string; def_param : string list; - def_value : ('a, 'b) mapping option; + def_value : ('a, 'b) t option; def_arepr : 'a; def_brepr : 'b; + def_orig : Atd.Ast.type_def; } +module Type_param_map = Map.Make (String) +module Type_name_map = Map.Make (String) + let as_abstract = function - Atd.Ast.Name (_, (loc, "abstract", l), a) -> + Atd.Ast.Name (_, (loc, TN ["abstract"], l), a) -> if l <> [] then Error.error loc "\"abstract\" takes no type parameters"; Some (loc, a) @@ -67,7 +74,7 @@ let as_abstract = function let is_abstract x = as_abstract x <> None let loc_of_mapping x = - match (x : (_, _) mapping) with + match (x : (_, _) t) with | Unit (loc, _, _) | Bool (loc, _, _) | Int (loc, _, _) @@ -85,10 +92,7 @@ let loc_of_mapping x = | External (loc, _, _, _, _) | Tvar (loc, _) -> loc - -module Env = Map.Make (String) - -let rec subst env (x : (_, _) mapping) = +let rec subst env (x : (_, _) t) = match x with Unit (_, _, _) | Bool (_, _, _) @@ -115,7 +119,7 @@ let rec subst env (x : (_, _) mapping) = | External (loc, name, args, a, b) -> External (loc, name, List.map (subst env) args, a, b) | Tvar (_, s) -> - try Env.find s env + try Type_param_map.find s env with Not_found -> invalid_arg (sprintf "Mapping.subst_var: '%s" s) @@ -138,8 +142,8 @@ let apply param x args = invalid_arg "Mapping.apply"; let env = List.fold_left2 - (fun env var value -> Env.add var value env) - Env.empty param args + (fun env var value -> Type_param_map.add var value env) + Type_param_map.empty param args in subst env x @@ -148,29 +152,36 @@ let rec find_name loc env visited name = if List.mem name visited then Error.error loc "Cyclic type definition" else - let param, x = Env.find name env in - (param, deref_expr env (name :: visited) x) + match Type_name_map.find_opt name env with + | Some (param, x) -> + Some (param, deref_expr env (name :: visited) x) + | None -> + None and deref_expr env visited x = match x with - Name (loc, name, args, _, _) -> - (try - let param, x = find_name loc env visited name in - apply param x args - with Not_found -> x) + | Name (loc, name, args, _, _) -> + (match name with + | TN [simple_name] -> + (match find_name loc env visited simple_name with + | Some (param, x) -> + apply param x args + | None -> + x) + | TN _ -> x) | _ -> x let make_deref (l : (bool * ('a, 'b) def list) list) : - (('a, 'b) mapping -> ('a, 'b) mapping) = + (('a, 'b) t -> ('a, 'b) t) = let defs = List.fold_left (fun env d -> match d.def_value with None -> env - | Some v -> Env.add d.def_name (d.def_param, v) env) - Env.empty (List.concat_map snd l) in + | Some v -> Type_name_map.add d.def_name (d.def_param, v) env) + Type_name_map.empty (List.concat_map snd l) in fun x -> deref_expr defs [] x @@ -178,7 +189,7 @@ let make_deref Resolve names and unwrap `wrap` constructs (discarding annotations along the way) *) -let rec unwrap (deref: ('a, 'b) mapping -> ('a, 'b) mapping) x = +let rec unwrap (deref: ('a, 'b) t -> ('a, 'b) t) x = match deref x with | Wrap (_, x, _, _) -> unwrap deref x | x -> x diff --git a/atdgen/src/mapping.mli b/atdgen/src/mapping.mli index 46b99b4a..99be3870 100644 --- a/atdgen/src/mapping.mli +++ b/atdgen/src/mapping.mli @@ -11,7 +11,7 @@ type loc = Atd.Ast.loc -type ('a, 'b) mapping = +type ('a, 'b) t = | Unit of loc * 'a * 'b | Bool of loc * 'a * 'b | Int of loc * 'a * 'b @@ -21,17 +21,20 @@ type ('a, 'b) mapping = | Sum of loc * ('a, 'b) variant_mapping array * 'a * 'b | Record of loc * ('a, 'b) field_mapping array * 'a * 'b | Tuple of loc * ('a, 'b) cell_mapping array * 'a * 'b - | List of loc * ('a, 'b) mapping * 'a * 'b - | Option of loc * ('a, 'b) mapping * 'a * 'b - | Nullable of loc * ('a, 'b) mapping * 'a * 'b - | Wrap of loc * ('a, 'b) mapping * 'a * 'b - | Name of loc * string * ('a, 'b) mapping list * 'a option * 'b option - | External of loc * string * ('a, 'b) mapping list * 'a * 'b + | List of loc * ('a, 'b) t * 'a * 'b + | Option of loc * ('a, 'b) t * 'a * 'b + | Nullable of loc * ('a, 'b) t * 'a * 'b + | Wrap of loc * ('a, 'b) t * 'a * 'b + | Name of loc + * Atd.Ast.type_name + * ('a, 'b) t list + * 'a * 'b + | External of loc * string * ('a, 'b) t list * 'a * 'b | Tvar of loc * string and ('a, 'b) cell_mapping = { cel_loc : loc; - cel_value : ('a, 'b) mapping; + cel_value : ('a, 'b) t; cel_arepr : 'a; cel_brepr : 'b } @@ -40,7 +43,7 @@ and ('a, 'b) field_mapping = { f_loc : loc; f_name : string; f_kind : Atd.Ast.field_kind; - f_value : ('a, 'b) mapping; + f_value : ('a, 'b) t; f_arepr : 'a; f_brepr : 'b } @@ -48,7 +51,7 @@ and ('a, 'b) field_mapping = { and ('a, 'b) variant_mapping = { var_loc : loc; var_cons : string; - var_arg : ('a, 'b) mapping option; + var_arg : ('a, 'b) t option; var_arepr : 'a; var_brepr : 'b } @@ -57,23 +60,26 @@ type ('a, 'b) def = { def_loc : loc; def_name : string; def_param : string list; - def_value : ('a, 'b) mapping option; + def_value : ('a, 'b) t option; def_arepr : 'a; def_brepr : 'b; + + (* Original (source) type definition before any specialization *) + def_orig: Atd.Ast.type_def; } val as_abstract : Atd.Ast.type_expr -> (loc * Atd.Ast.annot) option val is_abstract : Atd.Ast.type_expr -> bool -val loc_of_mapping : ('a, 'b) mapping -> loc +val loc_of_mapping : ('a, 'b) t -> loc val make_deref : (bool * ('a, 'b) def list) list - -> ('a, 'b) mapping - -> ('a, 'b) mapping + -> ('a, 'b) t + -> ('a, 'b) t val unwrap - : (('a, 'b) mapping -> ('a, 'b) mapping) - -> ('a, 'b) mapping - -> ('a, 'b) mapping + : (('a, 'b) t -> ('a, 'b) t) + -> ('a, 'b) t + -> ('a, 'b) t diff --git a/atdgen/src/ob_emit.ml b/atdgen/src/ob_emit.ml index ed68b823..2106de65 100644 --- a/atdgen/src/ob_emit.ml +++ b/atdgen/src/ob_emit.ml @@ -3,15 +3,15 @@ *) -open Atd.Import +open Atd.Stdlib_extra open Indent open Atd.Ast open Mapping open Ob_mapping -let target : Ocaml.target = Biniou -let annot_schema = Ocaml.annot_schema_of_target target +let target : Ocaml_repr.target = Biniou +let annot_schema = Ocaml_annot.annot_schema_of_target target (* OCaml code generator (biniou readers and writers) @@ -1201,10 +1201,10 @@ and make_table_reader deref ~ocaml_version loc list_kind x = ] ] -let make_ocaml_biniou_writer ~original_types deref is_rec let1 let2 def = +let make_ocaml_biniou_writer deref is_rec let1 let2 def = let x = Option.value_exn def.def_value in let name = def.def_name in - let type_constraint = Ox_emit.get_type_constraint ~original_types def in + let type_constraint = Ox_emit.get_type_constraint def in let param = def.def_param in let tag = get_biniou_tag (deref x) in let write_untagged = get_left_writer_name ~tagged:false name param in @@ -1246,11 +1246,11 @@ let make_ocaml_biniou_writer ~original_types deref is_rec let1 let2 def = ] ] -let make_ocaml_biniou_reader ~original_types ~ocaml_version +let make_ocaml_biniou_reader ~ocaml_version deref is_rec let1 let2 def = let x = Option.value_exn def.def_value in let name = def.def_name in - let type_constraint = Ox_emit.get_type_constraint ~original_types def in + let type_constraint = Ox_emit.get_type_constraint def in let param = def.def_param in let get_reader = get_left_reader_name ~tagged:false name param in let read = get_left_reader_name ~tagged:true name param in @@ -1286,7 +1286,7 @@ let make_ocaml_biniou_reader ~original_types ~ocaml_version ] ] -let make_ocaml_biniou_impl ~with_create ~original_types ~ocaml_version +let make_ocaml_biniou_impl ~with_create ~ocaml_version buf deref defs = defs |> List.concat_map (fun (is_rec, l) -> @@ -1295,14 +1295,14 @@ let make_ocaml_biniou_impl ~with_create ~original_types ~ocaml_version List.map_first (fun ~is_first def -> let let1, let2 = Ox_emit.get_let ~is_rec ~is_first in make_ocaml_biniou_writer - ~original_types deref is_rec let1 let2 def + deref is_rec let1 let2 def ) l in let readers = List.map_first (fun ~is_first def -> let let1, let2 = Ox_emit.get_let ~is_rec ~is_first in make_ocaml_biniou_reader ~ocaml_version - ~original_types deref is_rec let1 let2 def + deref is_rec let1 let2 def ) l in List.flatten (writers @ readers)) @@ -1329,7 +1329,7 @@ let make_mli Buffer.contents buf let make_ml - ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~original_types + ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~ocaml_version ocaml_typedefs deref defs = let buf = Buffer.create 1000 in @@ -1341,7 +1341,7 @@ let make_ml bprintf buf "\n"; if with_fundefs then make_ocaml_biniou_impl - ~with_create ~original_types ~ocaml_version + ~with_create ~ocaml_version buf deref defs; Buffer.contents buf @@ -1358,7 +1358,7 @@ let make_ocaml_files ~ocaml_version ~pp_convs atd_file out = - let ((head, m0), _) = + let module_ = match atd_file with Some file -> Atd.Util.load_file @@ -1373,25 +1373,20 @@ let make_ocaml_files ?pos_fname ?pos_lnum stdin in - let tsort = - if all_rec then - function m -> [ (true, m) ] - else - Atd.Util.tsort - in - let m1 = tsort m0 in - let defs1 = defs_of_atd_modules m1 in + let def_groups1 = Atd.Util.tsort ~all_rec module_.type_defs in + let defs1 = Ob_mapping.defs_of_def_groups def_groups1 in Xb_emit.check defs1; - let (m1', original_types) = - Atd.Expand.expand_module_body ~keep_poly:true m0 + let def_groups2 = + Atd.Expand.expand_type_defs ~keep_poly:true module_.type_defs + |> Atd.Util.tsort ~all_rec in - let m2 = tsort m1' in - (* m0 = original type definitions - m1 = original type definitions after dependency analysis - m2 = monomorphic type definitions after dependency analysis *) + (* module.type_defs = original type definitions + def_groups1 = original type definitions after dependency analysis + def_groups2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = - Ocaml.ocaml_of_atd ~pp_convs ~target ~type_aliases (head, m1) in - let defs = defs_of_atd_modules m2 in + Ocaml.ocaml_of_atd ~pp_convs ~target ~type_aliases + (module_.module_head, module_.imports, def_groups1) in + let defs = Ob_mapping.defs_of_def_groups def_groups2 in let header = let src = match atd_file with @@ -1407,7 +1402,7 @@ let make_ocaml_files in let ml = make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs - ~original_types ~ocaml_version ocaml_typedefs + ~ocaml_version ocaml_typedefs (Mapping.make_deref defs) defs in Ox_emit.write_ocaml out mli ml diff --git a/atdgen/src/ob_emit.mli b/atdgen/src/ob_emit.mli index eabcd213..3834e0d9 100644 --- a/atdgen/src/ob_emit.mli +++ b/atdgen/src/ob_emit.mli @@ -11,5 +11,5 @@ val make_ocaml_files -> type_aliases:string option -> force_defaults:_ (* not used *) -> ocaml_version:(int * int) option - -> pp_convs:Ocaml.pp_convs + -> pp_convs:Ocaml_repr.pp_convs -> string option -> Ox_emit.target -> unit diff --git a/atdgen/src/ob_mapping.ml b/atdgen/src/ob_mapping.ml index 12ac1238..291ba3d9 100644 --- a/atdgen/src/ob_mapping.ml +++ b/atdgen/src/ob_mapping.ml @@ -1,9 +1,11 @@ -open Atd.Import +open Atd.Stdlib_extra open Atd.Ast open Mapping +module An = Ocaml_annot +module R = Ocaml_repr type ob_mapping = - (Ocaml.Repr.t, Biniou.biniou_repr) Mapping.mapping + (Ocaml_repr.t, Biniou.biniou_repr) Mapping.t (* Translation of the types into the ocaml/biniou mapping. @@ -12,14 +14,14 @@ type ob_mapping = let rec mapping_of_expr (x : type_expr) : ob_mapping = match x with Sum (loc, l, an) -> - let ocaml_t = Ocaml.Repr.Sum (Ocaml.get_ocaml_sum Biniou an) in + let ocaml_t : R.t = Sum (An.get_ocaml_sum Biniou an) in let biniou_t = Biniou.Sum in Sum (loc, Array.of_list (List.map mapping_of_variant l), ocaml_t, biniou_t) | Record (loc, l, an) -> - let ocaml_t = Ocaml.Repr.Record (Ocaml.get_ocaml_record Biniou an) in - let ocaml_field_prefix = Ocaml.get_ocaml_field_prefix Biniou an in + let ocaml_t = R.Record (An.get_ocaml_record Biniou an) in + let ocaml_field_prefix = An.get_ocaml_field_prefix Biniou an in let biniou_t = Biniou.Record in Record (loc, Array.of_list @@ -27,23 +29,23 @@ let rec mapping_of_expr (x : type_expr) : ob_mapping = ocaml_t, biniou_t) | Tuple (loc, l, _) -> - let ocaml_t = Ocaml.Repr.Tuple in + let ocaml_t = R.Tuple in let biniou_t = Biniou.Tuple in Tuple (loc, Array.of_list (List.map mapping_of_cell l), ocaml_t, biniou_t) | List (loc, x, an) -> - let ocaml_t = Ocaml.Repr.List (Ocaml.get_ocaml_list Biniou an) in + let ocaml_t = R.List (Ocaml.get_ocaml_list Biniou an) in let biniou_t = Biniou.List (Biniou.get_biniou_list an) in List (loc, mapping_of_expr x, ocaml_t, biniou_t) | Option (loc, x, _) -> - let ocaml_t = Ocaml.Repr.Option in + let ocaml_t = R.Option in let biniou_t = Biniou.Option in Option (loc, mapping_of_expr x, ocaml_t, biniou_t) | Nullable (loc, x, _) -> - let ocaml_t = Ocaml.Repr.Nullable in + let ocaml_t = R.Nullable in let biniou_t = Biniou.Nullable in Nullable (loc, mapping_of_expr x, ocaml_t, biniou_t) @@ -52,27 +54,27 @@ let rec mapping_of_expr (x : type_expr) : ob_mapping = | Wrap (loc, x, a) -> let ocaml_t = - Ocaml.Repr.Wrap (Ocaml.get_ocaml_wrap ~type_param:[] Biniou loc a) in + R.Wrap (Ocaml.get_ocaml_wrap ~type_param:[] Biniou loc a) in let json_t = Biniou.Wrap in Wrap (loc, mapping_of_expr x, ocaml_t, json_t) - | Name (loc, (_, s, l), an) -> - (match s with - "unit" -> + | Name (loc, (_, name, l), an) -> + (match name with + | TN ["unit"] -> Unit (loc, Unit, Biniou.Unit) - | "bool" -> + | TN ["bool"] -> Bool (loc, Bool, Biniou.Bool) - | "int" -> + | TN ["int"] -> let o = Ocaml.get_ocaml_int Biniou an in let b = Biniou.get_biniou_int an in Int (loc, Int o, Biniou.Int b) - | "float" -> + | TN ["float"] -> let b = Biniou.get_biniou_float an in Float (loc, Float, Biniou.Float b) - | "string" -> + | TN ["string"] -> String (loc, String, Biniou.String) - | s -> - Name (loc, s, List.map mapping_of_expr l, None, None) + | name -> + Name (loc, name, List.map mapping_of_expr l, None, None) ) | Tvar (loc, s) -> Tvar (loc, s) @@ -80,7 +82,7 @@ let rec mapping_of_expr (x : type_expr) : ob_mapping = and mapping_of_cell (cel_loc, x, an) = { cel_loc ; cel_value = mapping_of_expr x - ; cel_arepr = Ocaml.Repr.Cell + ; cel_arepr = R.Cell { Ocaml.ocaml_default = Ocaml.get_ocaml_default Biniou an ; ocaml_fname = "" ; ocaml_mutable = false @@ -95,7 +97,7 @@ and mapping_of_variant = function { var_loc ; var_cons ; var_arg = Option.map mapping_of_expr o - ; var_arepr = Ocaml.Repr.Variant + ; var_arepr = R.Variant { Ocaml.ocaml_cons = Ocaml.get_ocaml_cons Biniou var_cons an ; ocaml_vdoc = Atd.Doc.get_doc var_loc an } @@ -103,15 +105,15 @@ and mapping_of_variant = function } and mapping_of_field ocaml_field_prefix = function - | `Inherit _ -> assert false - | `Field (f_loc, (f_name, f_kind, an), x) -> + | Inherit _ -> assert false + | Field (f_loc, (f_name, f_kind, an), x) -> let { Ox_mapping.ocaml_default; unwrapped } = Ox_mapping.analyze_field Biniou f_loc f_kind an in { f_loc ; f_name ; f_kind ; f_value = mapping_of_expr x - ; f_arepr = Ocaml.Repr.Field + ; f_arepr = R.Field { Ocaml.ocaml_default ; ocaml_fname = Ocaml.get_ocaml_fname Biniou (ocaml_field_prefix ^ f_name) an @@ -127,8 +129,8 @@ let def_of_atd atd = Ox_emit.def_of_atd atd ~target:Biniou ~external_:Biniou.External ~mapping_of_expr ~def:Biniou.Def -let defs_of_atd_module l = - List.map (function Atd.Ast.Type def -> def_of_atd def) l - -let defs_of_atd_modules l = - List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module l)) l +let defs_of_def_groups l = + List.map (fun (is_rec, defs) -> + let defs = List.map def_of_atd defs in + (is_rec, defs) + ) l diff --git a/atdgen/src/ob_mapping.mli b/atdgen/src/ob_mapping.mli index 30436ff4..892aa872 100644 --- a/atdgen/src/ob_mapping.mli +++ b/atdgen/src/ob_mapping.mli @@ -1,8 +1,8 @@ (** OCaml-Biniou decorated ATD AST. *) type ob_mapping = - (Ocaml.Repr.t, Biniou.biniou_repr) Mapping.mapping + (Ocaml_repr.t, Biniou.biniou_repr) Mapping.t -val defs_of_atd_modules - : ('a * Atd.Ast.module_body) list - -> ('a * (Ocaml.Repr.t, Biniou.biniou_repr) Mapping.def list) list +val defs_of_def_groups + : (bool * Atd.Ast.type_def list) list + -> (bool * (Ocaml_repr.t, Biniou.biniou_repr) Mapping.def list) list diff --git a/atdgen/src/obuckle_emit.ml b/atdgen/src/obuckle_emit.ml index 6c15bb2d..a1944b13 100644 --- a/atdgen/src/obuckle_emit.ml +++ b/atdgen/src/obuckle_emit.ml @@ -1,15 +1,16 @@ -open Atd.Import +open Atd.Stdlib_extra open Indent module Json = Atd.Json +module R = Ocaml_repr type param = { deref - : (Ocaml.Repr.t, Json.json_repr) Mapping.mapping - -> (Ocaml.Repr.t, Json.json_repr) Mapping.mapping; + : (Ocaml_repr.t, Json.json_repr) Mapping.t + -> (Ocaml_repr.t, Json.json_repr) Mapping.t; } -let target : Ocaml.target = Bucklescript -let annot_schema = Ocaml.annot_schema_of_target target +let target : Ocaml_repr.target = Bucklescript +let annot_schema = Ocaml_annot.annot_schema_of_target target let open_enum_not_supported () = failwith "open_enum is not supported in bucklescript mode" @@ -186,7 +187,7 @@ let rec make_reader ?type_annot p (x : Oj_mapping.t) : Indent.t list = let cases = Array.to_list a |> List.map - (fun (r : (Ocaml.Repr.t, Json.json_repr) Mapping.variant_mapping) -> + (fun (r : (Ocaml_repr.t, Json.json_repr) Mapping.variant_mapping) -> let (o, j) = match r.var_arepr, r.var_brepr with | Ocaml.Repr.Variant o, Json.Variant j -> o, j @@ -259,7 +260,7 @@ let rec make_reader ?type_annot p (x : Oj_mapping.t) : Indent.t list = and make_record_reader ?type_annot (p : param) _loc - (a : (Ocaml.Repr.t, Json.json_repr) Mapping.field_mapping array) + (a : (Ocaml_repr.t, Json.json_repr) Mapping.field_mapping array) _json_options = let create_record = @@ -323,7 +324,7 @@ let get_left_reader_name p name param = let args = List.map (fun s -> Mapping.Tvar (Atd.Ast.dummy_loc, s)) param in get_reader_name p (Mapping.Name (Atd.Ast.dummy_loc, name, args, None, None)) -let make_ocaml_bs_reader p ~original_types is_rec let1 _let2 +let make_ocaml_bs_reader p is_rec let1 _let2 (def : (_, _) Mapping.def) = let x = Option.value_exn def.def_value in let name = def.def_name in @@ -331,7 +332,7 @@ let make_ocaml_bs_reader p ~original_types is_rec let1 _let2 let read = get_left_reader_name p name param in let type_annot = if Ox_emit.needs_type_annot x then ( - Some (Ox_emit.get_type_constraint ~original_types def) + Some (Ox_emit.get_type_constraint def) ) else ( None ) @@ -558,12 +559,12 @@ and make_record_writer p a _record_kind = ] and make_sum_writer ?type_annot (p : param) - (sum : (Ocaml.Repr.t, Json.json_repr) Mapping.mapping) = + (sum : (Ocaml_repr.t, Json.json_repr) Mapping.t) = let tick, a = destruct_sum (p.deref sum) in let cases = a |> Array.map ( - fun (x : (Ocaml.Repr.t, Json.json_repr) Mapping.variant_mapping) -> + fun (x : (Ocaml_repr.t, Json.json_repr) Mapping.variant_mapping) -> let o, j = match x.var_arepr, x.var_brepr with | Ocaml.Repr.Variant o, Json.Variant j -> o, j @@ -593,13 +594,13 @@ and make_sum_writer ?type_annot (p : param) ; Block cases ; Line ")"] -let make_ocaml_bs_writer p ~original_types is_rec let1 _let2 +let make_ocaml_bs_writer p is_rec let1 _let2 (def : (_, _) Mapping.def) = let x = Option.value_exn def.def_value in let name = def.def_name in let type_annot = if Ox_emit.needs_type_annot x then ( - Some (Ox_emit.get_type_constraint ~original_types def) + Some (Ox_emit.get_type_constraint def) ) else ( None ) @@ -620,23 +621,22 @@ let make_ocaml_bs_writer p ~original_types is_rec let1 _let2 let make_ocaml_bs_impl ~with_create - ~original_types buf deref defs = let p = {deref = deref;} in defs |> List.concat_map (fun (is_rec, l) -> let l = List.filter - (fun (x : (Ocaml.Repr.t, Json.json_repr) Mapping.def) -> + (fun (x : (Ocaml_repr.t, Json.json_repr) Mapping.def) -> x.def_value <> None) l in let writers = List.map_first (fun ~is_first def -> let let1, let2 = Ox_emit.get_let ~is_rec ~is_first in - make_ocaml_bs_writer p ~original_types is_rec let1 let2 def + make_ocaml_bs_writer p is_rec let1 let2 def ) l in let readers = List.map_first (fun ~is_first def -> let let1, let2 = Ox_emit.get_let ~is_rec ~is_first in - make_ocaml_bs_reader p ~original_types is_rec let1 let2 def + make_ocaml_bs_reader p is_rec let1 let2 def ) l in List.flatten (writers @ readers)) @@ -649,7 +649,6 @@ let make_ml ~with_typedefs ~with_create ~with_fundefs - ~original_types ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; @@ -659,7 +658,7 @@ let make_ml if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then - make_ocaml_bs_impl ~with_create ~original_types buf deref defs; + make_ocaml_bs_impl ~with_create buf deref defs; Buffer.contents buf let make_mli @@ -668,7 +667,6 @@ let make_mli ~with_typedefs ~with_create ~with_fundefs - ~original_types:_ ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; @@ -694,7 +692,7 @@ let make_ocaml_files ~ocaml_version ~pp_convs:_ atd_file out = - let ((head, m0), _) = + let module_ = match atd_file with Some file -> Atd.Util.load_file @@ -710,25 +708,20 @@ let make_ocaml_files stdin in - let tsort = - if all_rec then - function m -> [ (true, m) ] - else - Atd.Util.tsort + let def_groups1 = Atd.Util.tsort ~all_rec module_.type_defs in + let defs1 = Oj_mapping.defs_of_def_groups def_groups1 ~target in + let def_groups2 = + Atd.Expand.expand_type_defs ~keep_poly:true module_.type_defs + |> Atd.Util.tsort ~all_rec in - let m1 = tsort m0 in - let defs1 = Oj_mapping.defs_of_atd_modules m1 ~target in - let (m1', original_types) = - Atd.Expand.expand_module_body ~keep_poly:true m0 - in - let m2 = tsort m1' in - (* m0 = original type definitions - m1 = original type definitions after dependency analysis - m2 = monomorphic type definitions after dependency analysis *) + (* module_.type_defs = original type definitions + def_groups1 = original type definitions after dependency analysis + def_groups2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = Ocaml.ocaml_of_atd ~pp_convs:(Ppx_deriving []) ~target - ~type_aliases (head, m1) in - let defs = Oj_mapping.defs_of_atd_modules m2 ~target in + ~type_aliases + (module_.module_head, module_.imports, def_groups1) in + let defs = Oj_mapping.defs_of_def_groups def_groups2 ~target in let header = let src = match atd_file with @@ -739,11 +732,11 @@ let make_ocaml_files [@@@ocaml.warning "-27-32-33-35-39"]|} src in let ml = - make_ml ~opens ~header ~with_typedefs ~with_create ~with_fundefs ~original_types + make_ml ~opens ~header ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs (Mapping.make_deref defs) defs in let mli = - make_mli ~opens ~header ~with_typedefs ~with_create ~with_fundefs ~original_types + make_mli ~opens ~header ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs (Mapping.make_deref defs1) defs1 in Ox_emit.write_ocaml out mli ml diff --git a/atdgen/src/ocaml.ml b/atdgen/src/ocaml.ml deleted file mode 100644 index 4cf01ccc..00000000 --- a/atdgen/src/ocaml.ml +++ /dev/null @@ -1,1090 +0,0 @@ - -(* - Translation from ATD types into OCaml types and pretty-printing. - - This is derived from the ATD pretty-printer (atd_print.ml). -*) - -open Atd.Import - -open Easy_format -open Atd.Ast -open Mapping -module Json = Atd.Json - -type pp_convs = - | Camlp4 of string list - | Ppx_deriving of string list - | Ppx of string list - -(* Type mapping from ATD to OCaml *) - -type atd_ocaml_sum = Classic | Poly -type atd_ocaml_record = Record | Object - -type atd_ocaml_int = Int | Char | Int32 | Int64 | Float -type atd_ocaml_list = List | Array - -type atd_ocaml_wrap = { - ocaml_wrap_t : string; - ocaml_wrap : string; - ocaml_unwrap : string; -} - -type atd_ocaml_field = { - ocaml_default : string option; - ocaml_fname : string; - ocaml_mutable : bool; - ocaml_fdoc : Atd.Doc.doc option; -} - -type atd_ocaml_variant = { - ocaml_cons : string; - ocaml_vdoc : Atd.Doc.doc option; -} - -type atd_ocaml_def = { - ocaml_predef : bool; - ocaml_ddoc : Atd.Doc.doc option; -} - -let tick = function - | Poly -> "`" - | Classic -> "" - -let dot = function - | Record -> "." - | Object -> "#" - -module Repr = struct - type t = - | Unit - | Bool - | Int of atd_ocaml_int - | Float - | String - | Abstract - | Sum of atd_ocaml_sum - | Record of atd_ocaml_record - | Tuple - | List of atd_ocaml_list - | Option - | Nullable - | Wrap of atd_ocaml_wrap option - | Name of string - | External of (string * string * string) - (* - (module providing the type, - module providing everything else, - type name) - *) - - | Cell of atd_ocaml_field - | Field of atd_ocaml_field - | Variant of atd_ocaml_variant - | Def of atd_ocaml_def -end - -type target = Default | Biniou | Json | Validate | Bucklescript - -let all_targets = [ Default; Biniou; Json; Validate; Bucklescript ] - -let ocaml_int_of_string s : atd_ocaml_int option = - match s with - "int" -> Some Int - | "char" -> Some Char - | "int32" -> Some Int32 - | "int64" -> Some Int64 - | "float" -> Some Float - | _ -> None - -let string_of_ocaml_int (x : atd_ocaml_int) = - match x with - Int -> "int" - | Char -> "Char.t" - | Int32 -> "Int32.t" - | Int64 -> "Int64.t" - | Float -> "float" - -let ocaml_sum_of_string s : atd_ocaml_sum option = - match s with - "classic" -> Some Classic - | "poly" -> Some Poly - | _ -> None - -let ocaml_record_of_string s : atd_ocaml_record option = - match s with - "record" -> Some Record - | "object" -> Some Object - | _ -> None - -let ocaml_list_of_string s : atd_ocaml_list option = - match s with - "list" -> Some List - | "array" -> Some Array - | _ -> None - -let string_of_ocaml_list (x : atd_ocaml_list) = - match x with - List -> "list" - | Array -> "Atdgen_runtime.Util.ocaml_array" - -let path_of_target (target : target) = - match target with - | Default -> [ "ocaml" ] - | Biniou -> [ "ocaml_biniou"; "ocaml" ] - | Json -> [ "ocaml_json"; "ocaml" ] - | Bucklescript -> ["ocaml_bs"; "ocaml"] - | Validate -> [ "ocaml_validate"; "ocaml" ] - -(* - This must hold all the valid annotations of the form - '' or '' (see above for the target names). -*) -let annot_schema_ocaml : Atd.Annot.schema_section = - { - section = "ocaml"; - fields = [ - Type_def, "attr"; - Type_def, "from"; - Type_def, "module"; - Type_def, "predef"; - Type_def, "t"; - Type_expr, "field_prefix"; - Type_expr, "module"; - Type_expr, "repr"; - Type_expr, "t"; - Type_expr, "unwrap"; - Type_expr, "valid"; - Type_expr, "validator"; - Type_expr, "wrap"; - Variant, "name"; - Cell, "default"; - Field, "default"; - Field, "mutable"; - Field, "name"; - Field, "repr"; - ] - } - -let annot_schema_of_target (target : target) : Atd.Annot.schema = - let section_names = path_of_target target in - let ocaml_sections = - List.map - (fun section -> { annot_schema_ocaml with section }) section_names - in - let other_section = - match target with - | Default -> [] - | Biniou -> Biniou.annot_schema_biniou - | Json -> Json.annot_schema_json - | Bucklescript -> Json.annot_schema_json - | Validate -> [] - in - ocaml_sections @ other_section - -let get_ocaml_int target an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:ocaml_int_of_string - ~default:Int - ~sections:path - ~field:"repr" - an - -let get_ocaml_type_path target atd_name an = - let x = - match atd_name with - "unit" -> `Unit - | "bool" -> `Bool - | "int" -> `Int (get_ocaml_int target an) - | "float" -> `Float - | "string" -> `String - | "abstract" -> `Abstract - | s -> `Name s - in - match x with - `Unit -> "unit" - | `Bool -> "bool" - | `Int x -> string_of_ocaml_int x - | `Float -> "float" - | `String -> "string" - | `Abstract -> "Yojson.Safe.t" - | `Name s -> s - -let get_ocaml_sum target an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:ocaml_sum_of_string - ~default:Poly - ~sections:path - ~field:"repr" - an - -let get_ocaml_field_prefix target an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:(fun s -> Some s) - ~default:"" - ~sections:path - ~field:"field_prefix" - an - -let get_ocaml_record target an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:ocaml_record_of_string - ~default:Record - ~sections:path - ~field:"repr" - an - -let get_ocaml_list target an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:ocaml_list_of_string - ~default:List - ~sections:path - ~field:"repr" - an - -let get_ocaml_wrap ~type_param target loc an = - let path = path_of_target target in - let module_ = - Atd.Annot.get_opt_field - ~parse:(fun s -> Some s) - ~sections:path - ~field:"module" - an - in - let default field = - Option.map (fun s -> - sprintf "%s.%s" s field) module_ - in - let default_t field = - Option.map (fun s -> - let type_param = - match List.map (sprintf "'%s") type_param with - | [] -> "" - | x::[] -> sprintf "%s " x - | param -> sprintf "(%s) " (String.concat ", " type_param) in - sprintf "%s%s.%s" type_param s field) module_ - in - let t = - Atd.Annot.get_field - ~parse:(fun s -> Some (Some s)) - ~default:(default_t "t") - ~sections:path - ~field:"t" - an - in - let wrap = - Atd.Annot.get_field - ~parse:(fun s -> Some (Some s)) - ~default:(default "wrap") - ~sections:path - ~field:"wrap" - an - in - let unwrap = - Atd.Annot.get_field - ~parse:(fun s -> Some (Some s)) - ~default:(default "unwrap") - ~sections:path - ~field:"unwrap" - an - in - match t, wrap, unwrap with - None, None, None -> None - | Some t, Some wrap, Some unwrap -> - Some { ocaml_wrap_t = t; ocaml_wrap = wrap; ocaml_unwrap = unwrap } - | _ -> - Error.error loc "Incomplete annotation. Missing t, wrap or unwrap" - -let get_ocaml_cons target default an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:(fun s -> Some s) - ~default - ~sections:path - ~field:"name" - an - -let get_ocaml_fname target default an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:(fun s -> Some s) - ~default:default - ~sections:path - ~field:"name" - an - -let get_ocaml_default target an = - let path = path_of_target target in - Atd.Annot.get_opt_field - ~parse:(fun s -> Some s) - ~sections:path - ~field:"default" - an - -let get_ocaml_mutable target an = - let path = path_of_target target in - Atd.Annot.get_flag - ~sections:path - ~field:"mutable" - an - -let get_ocaml_predef target an = - let path = path_of_target target in - Atd.Annot.get_flag - ~sections:path - ~field:"predef" - an - -let get_ocaml_module target an = - let path = path_of_target target in - let o = - Atd.Annot.get_opt_field - ~parse:(fun s -> Some s) - ~sections:path - ~field:"module" - an - in - match o with - Some s -> Some (s, s) - | None -> - Atd.Annot.get_opt_field - ~parse:(fun s -> Some s) - ~sections:path - ~field:"from" an - |> Option.map (fun s -> - let type_module = s ^ "_t" in - let main_module = - match target with - | Default -> type_module - | Biniou -> s ^ "_b" - | Json -> s ^ "_j" - | Bucklescript -> s ^ "_bs" - | Validate -> s ^ "_v" - in - (type_module, main_module)) - -let get_ocaml_t target default an = - let path = path_of_target target in - Atd.Annot.get_field - ~parse:(fun s -> Some s) - ~default:default - ~sections:path - ~field:"t" - an - -let get_ocaml_module_and_t target default_name an = - get_ocaml_module target an - |> Option.map (fun (type_module, main_module) -> - (type_module, main_module, get_ocaml_t target default_name an)) - -let get_type_attrs an = - Atd.Annot.get_fields - ~parse:(fun s -> Some s) - ~sections:["ocaml"] - ~field:"attr" - an - -(* - OCaml syntax tree -*) -type ocaml_type_param = string list - -type ocaml_expr = - [ `Sum of (atd_ocaml_sum * ocaml_variant list) - | `Record of (atd_ocaml_record * ocaml_field list) - | `Tuple of ocaml_expr list - | `Name of (string * ocaml_expr list) - | `Tvar of string - ] - -and ocaml_variant = - string * ocaml_expr option * Atd.Doc.doc option - -and ocaml_field = - (string * bool (* is mutable? *)) * ocaml_expr * Atd.Doc.doc option - -(* - OCaml type definition: - - type foo = Baz_t.foo = bar list [@@what ever] - ^^^ ^^^^^^^^^ ^^^^^^^^ ^^^^^^^^^^^^^ - name alias expr ppx attrs - - A useful definition in the context of ATD would have at least an expr - or an alias. -*) -type ocaml_def = { - o_def_name : (string * ocaml_type_param); - o_def_alias : (string * ocaml_type_param) option; - o_def_expr : ocaml_expr option; - o_def_doc : Atd.Doc.doc option; - o_def_attrs : string list; -} - -type ocaml_module_item = - [ `Type of ocaml_def ] - -type ocaml_module_body = ocaml_module_item list - -(* https://ocaml.org/manual/lex.html#sss:keywords *) -let is_ocaml_keyword = function - | "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" - | "do" | "done" | "downto" | "else" | "end" | "exception" | "external" - | "false" | "for" | "fun" | "function" | "functor" | "if" | "in" | "include" - | "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl" - | "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new" - | "nonrec" | "object" | "of" | "open" | "or" | "private" | "rec" | "sig" - | "struct" | "then" | "to" | "true" | "try" | "type" | "val" | "virtual" - | "when" | "while" | "with" -> true - | _ -> false - -(* - Mapping from ATD to OCaml -*) - -let rec map_expr target - (type_param: type_param) (x : type_expr) : ocaml_expr = - match x with - Atd.Ast.Sum (_, l, an) -> - let kind = get_ocaml_sum target an in - `Sum (kind, List.map (map_variant ~kind target) l) - | Record (loc, l, an) -> - let kind = get_ocaml_record target an in - let field_prefix = get_ocaml_field_prefix target an in - if l = [] then - Error.error loc "Empty record (not valid in OCaml)" - else - `Record (kind, List.map (map_field target field_prefix) l) - | Tuple (_, l, _) -> - `Tuple (List.map (fun (_, x, _) -> (map_expr target []) x) l) - | List (_, x, an) -> - let s = string_of_ocaml_list (get_ocaml_list target an) in - `Name (s, [map_expr target [] x]) - | Option (_, x, _) -> - `Name ("option", [map_expr target [] x]) - | Nullable (_, x, _) -> - `Name ("option", [map_expr target [] x]) - | Shared (_, _, _) -> - failwith "Sharing is not supported" - | Wrap (loc, x, a) -> - (match get_ocaml_wrap ~type_param target loc a with - None -> map_expr target [] x - | Some { ocaml_wrap_t ; _ } -> `Name (ocaml_wrap_t, []) - ) - | Name (_, (_2, s, l), an) -> - let s = get_ocaml_type_path target s an in - `Name (s, List.map (map_expr target []) l) - | Tvar (_, s) -> - `Tvar s - -and map_variant ~kind target (x : variant) : ocaml_variant = - match kind, x with - | _, Inherit _ -> assert false - | Poly, Variant (loc, _, Some (Record _)) -> - Error.error loc - "Inline records are not allowed in polymorphic variants (not valid in OCaml)" - | _, Variant (loc, (s, an), o) -> - let s = get_ocaml_cons target s an in - (s, Option.map (map_expr target []) o, Atd.Doc.get_doc loc an) - -and map_field target ocaml_field_prefix (x : field) : ocaml_field = - match x with - `Inherit _ -> assert false - | `Field (loc, (atd_fname, _, an), x) -> - let ocaml_fname = - get_ocaml_fname target (ocaml_field_prefix ^ atd_fname) an in - if is_ocaml_keyword ocaml_fname then - Error.error loc - ("\"" ^ ocaml_fname ^ - "\" cannot be used as field name (reserved OCaml keyword)"); - let fname = - if ocaml_fname = atd_fname then ocaml_fname - else sprintf "%s (*atd %s *)" ocaml_fname atd_fname - in - let is_mutable = get_ocaml_mutable target an in - ((fname, is_mutable), map_expr target [] x, Atd.Doc.get_doc loc an) - - -(* hack to deal with legacy behavior *) -let lhs_has_possibly_relevant_annotation - ((loc, (name, param, an1), x) : type_def) = - List.exists - (fun target -> get_ocaml_module_and_t target name an1 <> None) - all_targets - -(* hack to deal with legacy behavior *) -let rhs_is_just_abstract ((loc, (name, param, an1), x) : type_def) = - match x with - | Atd.Ast.Name (_, (loc, "abstract", type_params), an2) -> - if type_params <> [] then - Error.error loc "\"abstract\" takes no type parameters"; - true - | _ -> - false - -(* - This is an ATD definition of the form - - type foo <...> = abstract - - e.g. - - type foo = abstract - - where the right-hand side is exactly 'abstract' and is ignored. - This is weird and will be deprecated as soon as we implement - a clean module system allowing us to import whole modules without - special annotations. - - The annotation <...> on the left-hand side specifies the type name and - readers/writers to be used. They are placed there rather than - directly on 'abstract' for "historical reasons". We preserve the legacy - behavior unless there's no suitable left-hand side annotation. - - The following is valid and follows the more recent convention that - 'abstract' means "untyped data". It is NOT considered an abstract - definition: - - type foo = abstract - ^^^^^^^^ - JSON or biniou AST representing raw data -*) -let is_abstract_def (x : type_def) = - lhs_has_possibly_relevant_annotation x - && rhs_is_just_abstract x - -let map_def - ~(target : target) - ~(type_aliases : string option) - ((loc, (s, param, an1), x) as def : type_def) : ocaml_def option = - if is_ocaml_keyword s then - Error.error loc - ("\"" ^ s ^ "\" cannot be used as type name (reserved OCaml keyword)"); - let is_predef = get_ocaml_predef target an1 in - let is_abstract = is_abstract_def def in - let define_alias = - if is_predef || is_abstract || type_aliases <> None then - match get_ocaml_module_and_t target s an1, type_aliases with - Some (types_module, _, s), _ -> Some (types_module, s) - | None, Some types_module -> Some (types_module, s) - - | None, None -> None - else - None - in - if is_predef && define_alias = None then - None - else - let an2 = Atd.Ast.annot_of_type_expr x in - let an = an1 @ an2 in - let doc = Atd.Doc.get_doc loc an in - let alias, x = - match define_alias with - None -> - (* Ordinary type definitions or aliases: - type foo = string * int - type foo = bar - type foo = { hello: string } - *) - if is_abstract then (None, None) - else (None, Some (map_expr target param x)) - | Some (module_path, ext_name) -> - (* - type foo = Bar_t.foo = { hello: string } - or - type foo = Bar_t.foo = Alpha | Beta of int - *) - let alias = Some (module_path ^ "." ^ ext_name, param) in - let x = - match map_expr target param x with - `Sum (Classic, _) - | `Record (Record, _) as x -> Some x - | _ -> None - in - (alias, x) - in - if x = None && alias = None then - None - else - Some { - o_def_name = (s, param); - o_def_alias = alias; - o_def_expr = x; - o_def_doc = doc; - o_def_attrs = get_type_attrs an1; - } - - -let map_module ~target ~type_aliases (l : module_body) : ocaml_module_body = - List.filter_map ( - fun (Atd.Ast.Type td) -> - Option.map (fun x -> `Type x) (map_def ~target ~type_aliases td) - ) l - - -(* - Mapping from Mapping to OCaml -*) - - -let rec ocaml_of_expr_mapping (x : (Repr.t, _) mapping) : ocaml_expr = - match x with - Unit (_, Unit, _) -> `Name ("unit", []) - | Bool (_, Bool, _) -> `Name ("bool", []) - | Int (_, Int x, _) -> `Name (string_of_ocaml_int x, []) - | Float (_, Float, _) -> `Name ("float", []) - | String (_, String, _) -> `Name ("string", []) - | Sum (_, a, Sum kind, _) -> - let l = Array.to_list a in - `Sum (kind, List.map ocaml_of_variant_mapping l) - | Record (_, a, Record _, _) -> - let l = Array.to_list a in - `Record (Record, List.map ocaml_of_field_mapping l) - | Tuple (_, a, _, _) -> - let l = Array.to_list a in - `Tuple (List.map (fun x -> ocaml_of_expr_mapping x.cel_value) l) - | List (_, x, List kind, _) -> - `Name (string_of_ocaml_list kind, [ocaml_of_expr_mapping x]) - | Option (_, x, Option, _) -> - `Name ("option", [ocaml_of_expr_mapping x]) - | Nullable (_, x, Nullable, _) -> - `Name ("option", [ocaml_of_expr_mapping x]) - | Wrap _ -> - assert false - | Name (_, s, l, _, _) -> - `Name (s, List.map ocaml_of_expr_mapping l) - | Tvar (_, s) -> - `Tvar s - | Abstract _ -> `Name ("Yojson.Safe.t", []) - | _ -> assert false - -and ocaml_of_variant_mapping x = - let o = - match x.var_arepr with - Variant o -> o - | _ -> assert false - in - (o.ocaml_cons, Option.map ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc) - -and ocaml_of_field_mapping x = - let o = - match x.f_arepr with - Field o -> o - | _ -> assert false - in - let v = ocaml_of_expr_mapping x.f_value in - ((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc) - - -(* - Pretty-printing -*) - - - -let rlist = { list with - wrap_body = `Force_breaks; - indent_body = 0; - align_closing = false; - space_after_opening = false; - space_before_closing = false - } - -let plist = { list with - align_closing = false; - space_after_opening = false; - space_before_closing = false } - -let hlist = { list with wrap_body = `No_breaks } -let shlist = { hlist with - stick_to_label = false; - space_after_opening = false; - space_before_closing = false } - -let llist = { - list with - separators_stick_left = false; - space_before_separator = true; - space_after_separator = true -} - -let lplist = { - llist with - space_after_opening = false; - space_before_closing = false -} - -let vlist1 = { list with stick_to_label = false } - -let vlist = { - vlist1 with - wrap_body = `Force_breaks; -} - - -let make_atom s = Atom (s, atom) - -let horizontal_sequence l = Easy_format.List (("", "", "", shlist), l) - -let vertical_sequence ?(skip_lines = 0) l = - let l = - if skip_lines = 0 then l - else - let sep = List.init skip_lines (fun _ -> (Atom ("", atom))) in - List.insert_sep l ~sep - in - Easy_format.List (("", "", "", rlist), l) - -let escape f s = - let buf = Buffer.create (2 * String.length s) in - for i = 0 to String.length s - 1 do - let c = s.[i] in - match f c with - None -> Buffer.add_char buf c - | Some s -> Buffer.add_string buf s - done; - Buffer.contents buf - -let ocamldoc_escape s = - let esc = function - '{' | '}' | '[' | ']' | '@' | '\\' as c -> Some (sprintf "\\%c" c) - | _ -> None - in - escape esc s - -let ocamldoc_verbatim_escape s = - let esc = function - '{' | '}' | '\\' as c -> Some (sprintf "\\%c" c) - | _ -> None - in - escape esc s - -let split = Re.Str.split (Re.Str.regexp " ") - - -let make_ocamldoc_block = function - | Atd.Doc.Pre s -> Atom ("\n{v\n" ^ ocamldoc_verbatim_escape s ^ "\nv}", atom) - | Paragraph l -> - let l = List.map (function - | Atd.Doc.Text s -> ocamldoc_escape s - | Code s -> "[" ^ ocamldoc_escape s ^ "]" - ) l - in - let words = split (String.concat "" l) in - let atoms = List.map (fun s -> Atom (s, atom)) words in - List (("", "", "", plist), atoms) - -let rec make_ocamldoc_blocks = function - | [] - | [_] as l -> List.map make_ocamldoc_block l - | x :: (y :: _ as xs) -> - let rest = make_ocamldoc_blocks xs in - let rest = - match y with - | Atd.Doc.Paragraph _ -> Atom ("", atom) :: rest - | Pre _ -> rest in - make_ocamldoc_block x :: rest - -let make_ocamldoc_comment l = - let blocks = make_ocamldoc_blocks l in - let xlist = - match l with - [] | [_] -> vlist1 - | _ -> vlist - in - Easy_format.List (("(**", "", "*)", xlist), blocks) - -let prepend_ocamldoc_comment doc x = - match doc with - None -> x - | Some y -> - let comment = make_ocamldoc_comment y in - Easy_format.List (("", "", "", rlist), [comment;x]) - -let append_ocamldoc_comment x doc = - match doc with - None -> x - | Some y -> - let comment = make_ocamldoc_comment y in - Label ((x, label), comment) - -let format_pp_conv_node node = function - | Camlp4 [] - | Ppx_deriving [] - | Ppx [] -> node - | converters -> - let attr value = "[@@" ^ value ^ "]" in - let converters = - match converters with - | Ppx_deriving cs -> attr ("deriving " ^ (String.concat ", " cs)) - | Camlp4 cs -> "with " ^ (String.concat ", " cs) - | Ppx cs -> List.map attr cs |> String.concat "" in - Label ((node, label), make_atom converters) - -let rec format_module_item pp_convs - is_first (`Type def : ocaml_module_item) = - let type_ = if is_first then "type" else "and" in - let s, param = def.o_def_name in - let alias = def.o_def_alias in - let expr = def.o_def_expr in - let doc = def.o_def_doc in - (* TODO: currently replacing, globally set pp_convs, maybe should merge? *) - let pp_convs = - match def.o_def_attrs with - | [] -> pp_convs - | attrs -> Ppx attrs - in - let append_if b s1 s2 = - if b then s1 ^ s2 - else s1 - in - let part1 = - horizontal_sequence ( - make_atom type_ :: - prepend_type_param param - [ make_atom (append_if (alias <> None || expr <> None) s " =") ] - ) - in - let part12 = - match alias with - None -> part1 - | Some (name, param) -> - let right = - horizontal_sequence ( - prepend_type_param param - [ make_atom (append_if (expr <> None) name " =") ] - ) - in - Label ( - (part1, label), - right - ) - in - let part123 = - match expr with - None -> part12 - - | Some t -> - Label ( - (part12, label), - format_type_expr t - ) - in - format_pp_conv_node (prepend_ocamldoc_comment doc part123) pp_convs - - -and prepend_type_param l tl = - match l with - [] -> tl - | _ -> - let make_var s = make_atom ("'" ^ s) in - let x = - match l with - [s] -> make_var s - | l -> List (("(", ",", ")", plist), List.map make_var l) - in - x :: tl - -and prepend_type_args l tl = - match l with - [] -> tl - | _ -> - let x = - match l with - [t] -> format_type_expr t - | l -> List (("(", ",", ")", plist), List.map format_type_expr l) - in - x :: tl - -and format_type_expr x = - match x with - `Sum (kind, l) -> - let op, cl = - match kind with - Classic -> "", "" - | Poly -> "[", "]" - in - List ( - (op, "|", cl, llist), - List.map (format_variant kind) l - ) - | `Record (kind, l) -> - let op, cl = - match kind with - Record -> "{", "}" - | Object -> "<", ">" - in - List ( - (op, ";", cl, list), - List.map format_field l - ) - | `Tuple l -> - List ( - ("(", "*", ")", lplist), - List.map format_type_expr l - ) - | `Name (name, args) -> - format_type_name name args - - | `Tvar name -> - make_atom ("'" ^ name) - -and format_type_name name args = - horizontal_sequence (prepend_type_args args [ make_atom name ]) - -and format_field ((s, is_mutable), t, doc) = - let l = - let l = [make_atom (s ^ ":")] in - if is_mutable then - make_atom "mutable" :: l - else l - in - let field = - Label ( - (horizontal_sequence l, label), - format_type_expr t - ) - in - append_ocamldoc_comment field doc - -and format_variant kind (s, o, doc) = - let s = tick kind ^ s in - let cons = make_atom s in - let variant = - match o with - None -> cons - | Some t -> - Label ( - (cons, label), - Label ( - (make_atom "of", label), - format_type_expr t - ) - ) - in - append_ocamldoc_comment variant doc - -let format_module_items pp_convs (l : ocaml_module_body) = - match l with - x :: l -> - format_module_item pp_convs true x :: - List.map (fun x -> format_module_item pp_convs false x) l - | [] -> [] - -let format_module_bodies pp_conv (l : (bool * ocaml_module_body) list) = - List.concat_map (fun (_, x) -> format_module_items pp_conv x) l - -let format_head (loc, an) = - match Atd.Doc.get_doc loc an with - None -> [] - | Some doc -> [make_ocamldoc_comment doc] - -let format_all l = - vertical_sequence ~skip_lines:1 l - - -let ocaml_of_expr x : string = - Easy_format.Pretty.to_string (format_type_expr x) - -let ocaml_of_atd ?(pp_convs=Ppx_deriving []) ~target ~type_aliases - (head, (l : (bool * module_body) list)) : string = - let head = format_head head in - let bodies = - List.map (fun (is_rec, m) -> - (is_rec, map_module ~target ~type_aliases m)) l - in - let body = format_module_bodies pp_convs bodies in - let x = format_all (head @ body) in - Easy_format.Pretty.to_string x - -let unwrap_option = function - | Option (_, x, _, _) - | Nullable (_, x, _, _) -> x - | Name (loc, s, _, _, _) -> - Error.error loc ("Not an option type: " ^ s) - | x -> - Error.error (loc_of_mapping x) "Not an option type" - - -let get_implicit_ocaml_default = function - | Unit (_, Repr.Unit, _) -> Some "()" - | Bool (_, Bool, _) -> Some "false" - | Int (_, Int o, _) -> - Some (match o with - Int -> "0" - | Char -> "'\000'" - | Int32 -> "0l" - | Int64 -> "0L" - | Float -> "0.") - | Float (_, Float, _) -> Some "0.0" - | String (_, String, _) -> Some "\"\"" - | List (_, _, List List, _) -> Some "[]" - | List (_, _, List Array, _) -> Some "[||]" - | Option (_, _, Option, _) -> Some "None" - | Nullable (_, _, Nullable, _) -> Some "None" - | _ -> None - -type create_fields = - { intf_params: string - ; impl_params: string - ; impl_fields: string - } - -let map_record_creator_field deref x = - let o = - match x.f_arepr with - Repr.Field o -> o - | _ -> assert false - in - let fname = o.ocaml_fname in - let impl2 = sprintf "\n %s = %s;" fname fname in - match x.f_kind with - Required -> - let t = ocaml_of_expr (ocaml_of_expr_mapping x.f_value) in - let intf = sprintf "\n %s: %s ->" fname t in - let impl1 = sprintf "\n ~%s" fname in - { intf_params = intf - ; impl_params = impl1 - ; impl_fields = impl2 - } - - | Optional -> - let x = unwrap_option (deref x.f_value) in - let t = ocaml_of_expr (ocaml_of_expr_mapping x) in - let intf = sprintf "\n ?%s: %s ->" fname t in - let impl1 = sprintf "\n ?%s" fname in - { intf_params = intf - ; impl_params = impl1 - ; impl_fields = impl2 - } - - | With_default -> - let t = ocaml_of_expr (ocaml_of_expr_mapping x.f_value) in - let intf = sprintf "\n ?%s: %s ->" fname t in - let impl1 = - let default = - match o.ocaml_default with - None -> - (match get_implicit_ocaml_default (deref x.f_value) with - None -> - Error.error x.f_loc "Missing default field value" - | Some s -> s - ) - | Some s -> s - in - sprintf "\n ?(%s = %s)" fname default - in - { intf_params = intf - ; impl_params = impl1 - ; impl_fields = impl2 - } - -let obj_unimplemented loc = function - | Record -> () - | Object -> Error.error loc "Sorry, OCaml objects are not supported" diff --git a/atdgen/src/ocaml.mli b/atdgen/src/ocaml.mli deleted file mode 100644 index 565f9d78..00000000 --- a/atdgen/src/ocaml.mli +++ /dev/null @@ -1,120 +0,0 @@ -(** OCaml-specific options derived from ATD annotations. *) - -type pp_convs = - | Camlp4 of string list - | Ppx_deriving of string list - | Ppx of string list - -type atd_ocaml_sum = Classic | Poly -type atd_ocaml_record = Record | Object -type atd_ocaml_int = Int | Char | Int32 | Int64 | Float -type atd_ocaml_list = List | Array -type target = Default | Biniou | Json | Validate | Bucklescript - -type atd_ocaml_wrap = { - ocaml_wrap_t : string; - ocaml_wrap : string; - ocaml_unwrap : string; -} - -type atd_ocaml_field = { - ocaml_default : string option; - ocaml_fname : string; - ocaml_mutable : bool; - ocaml_fdoc : Atd.Doc.doc option; -} - -type atd_ocaml_variant = { - ocaml_cons : string; - ocaml_vdoc : Atd.Doc.doc option; -} - -type atd_ocaml_def = { - ocaml_predef : bool; - ocaml_ddoc : Atd.Doc.doc option; -} - -module Repr : sig - (** OCaml-specific options that decorate each kind of ATD AST node. *) - type t = - | Unit - | Bool - | Int of atd_ocaml_int - | Float - | String - | Abstract - | Sum of atd_ocaml_sum - | Record of atd_ocaml_record - | Tuple - | List of atd_ocaml_list - | Option - | Nullable - | Wrap of atd_ocaml_wrap option - | Name of string - | External of (string * string * string) - (* - (module providing the type, - module providing everything else, - type name) - *) - - | Cell of atd_ocaml_field - | Field of atd_ocaml_field - | Variant of atd_ocaml_variant - | Def of atd_ocaml_def -end - -val annot_schema_of_target : target -> Atd.Annot.schema - -val get_ocaml_sum : target -> Atd.Annot.t -> atd_ocaml_sum -val get_ocaml_record : target -> Atd.Annot.t -> atd_ocaml_record -val get_ocaml_field_prefix : target -> Atd.Annot.t -> string -val get_ocaml_list : target -> Atd.Annot.t -> atd_ocaml_list -val get_ocaml_wrap : type_param:string list -> target -> Atd.Ast.loc -> - Atd.Annot.t -> atd_ocaml_wrap option -val get_ocaml_int : target -> Atd.Annot.t -> atd_ocaml_int -val get_ocaml_default : target -> Atd.Annot.t -> string option -val get_ocaml_cons : target -> string -> Atd.Annot.t -> string -val get_ocaml_fname : target -> string -> Atd.Annot.t -> string -val get_ocaml_mutable : target -> Atd.Annot.t -> bool -val get_ocaml_predef : target -> Atd.Annot.t -> bool - -val get_ocaml_module_and_t - : target - -> string - -> Atd.Annot.t - -> (string * string * string) option - - -val get_implicit_ocaml_default - : (Repr.t, 'b) Mapping.mapping - -> string option - -val unwrap_option - : ('b, 'c) Mapping.mapping - -> ('b, 'c) Mapping.mapping - -val ocaml_of_atd - : ?pp_convs:pp_convs - -> target:target - -> type_aliases:string option - -> (Atd.Ast.loc * Atd.Ast.annot) * (bool * Atd.Ast.module_body) list - -> string - -type create_fields = - { intf_params: string - ; impl_params: string - ; impl_fields: string - } - -val map_record_creator_field - : ((Repr.t, 'a) Mapping.mapping - -> (Repr.t, 'b) Mapping.mapping) - -> (Repr.t, 'a) Mapping.field_mapping - -> create_fields - -val tick : atd_ocaml_sum -> string - -val dot : atd_ocaml_record -> string - -val obj_unimplemented : Atd.Ast.loc -> atd_ocaml_record -> unit diff --git a/atdgen/src/ocaml_annot.ml b/atdgen/src/ocaml_annot.ml new file mode 100644 index 00000000..c8329f94 --- /dev/null +++ b/atdgen/src/ocaml_annot.ml @@ -0,0 +1,280 @@ +(* + Read ATD annotations relating to OCaml. +*) + +open Printf +module R = Ocaml_repr + +let path_of_target (target : R.target) = + match target with + | Default -> [ "ocaml" ] + | Biniou -> [ "ocaml_biniou"; "ocaml" ] + | Json -> [ "ocaml_json"; "ocaml" ] + | Bucklescript -> ["ocaml_bs"; "ocaml"] + | Validate -> [ "ocaml_validate"; "ocaml" ] + +(* + This must hold all the valid annotations of the form + '' or '' (see above for the target names). +*) +let annot_schema_ocaml : Atd.Annot.schema_section = + { + section = "ocaml"; + fields = [ + Type_def, "attr"; + Type_def, "from"; + Type_def, "module"; + Type_def, "predef"; + Type_def, "t"; + Type_expr, "field_prefix"; + Type_expr, "module"; + Type_expr, "repr"; + Type_expr, "t"; + Type_expr, "unwrap"; + Type_expr, "valid"; + Type_expr, "validator"; + Type_expr, "wrap"; + Variant, "name"; + Cell, "default"; + Field, "default"; + Field, "mutable"; + Field, "name"; + Field, "repr"; + ] + } + +let annot_schema_of_target (target : R.target) : Atd.Annot.schema = + let section_names = path_of_target target in + let ocaml_sections = + List.map + (fun section -> { annot_schema_ocaml with section }) section_names + in + let other_section = + match target with + | Default -> [] + | Biniou -> Biniou.annot_schema_biniou + | Json -> Atd.Json.annot_schema_json + | Bucklescript -> Atd.Json.annot_schema_json + | Validate -> [] + in + ocaml_sections @ other_section + +let get_ocaml_int target an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:R.ocaml_int_of_string + ~default:Int + ~sections:path + ~field:"repr" + an + +let get_ocaml_type_name + (env : R.env) loc (atd_name : Atd.Ast.type_name) an : R.t = + match atd_name with + | TN ["unit"] -> Unit + | TN ["bool"] -> Bool + | TN ["int"] -> Int (get_ocaml_int env.target an) + | TN ["float"] -> Float + | TN ["string"] -> String + | TN ["abstract"] -> Abstract + | TN _ -> Name (R.name env loc atd_name) + +(* +let get_ocaml_type_path + (env : R.env) loc (atd_name : Atd.Ast.type_name) an : R.name = + let = + match atd_name with + | TN ["unit"] -> `Unit + | TN ["bool"] -> `Bool + | TN ["int"] -> `Int (get_ocaml_int env.target an) + | TN ["float"] -> `Float + | TN ["string"] -> `String + | TN ["abstract"] -> `Abstract + | TN _ -> + let import, base_name = + Atd.Imports.resolve env.imports loc atd_name + in + match import with + | None -> `Name base_name + | Some x -> `Name (R.ocaml_type_module_name x.name) + in + match x with + | `Unit -> "unit" + | `Bool -> "bool" + | `Int x -> R.string_of_ocaml_int x + | `Float -> "float" + | `String -> "string" + | `Abstract -> "Yojson.Safe.t" + | `Name s -> s +*) + +let get_ocaml_sum target an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:R.ocaml_sum_of_string + ~default:Poly + ~sections:path + ~field:"repr" + an + +let get_ocaml_field_prefix target an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:(fun s -> Some s) + ~default:"" + ~sections:path + ~field:"field_prefix" + an + +let get_ocaml_record target an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:R.ocaml_record_of_string + ~default:Record + ~sections:path + ~field:"repr" + an + +let get_ocaml_list target an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:R.ocaml_list_of_string + ~default:List + ~sections:path + ~field:"repr" + an + +let get_ocaml_wrap ~type_param target loc an : R.atd_ocaml_wrap option = + let path = path_of_target target in + let module_ = + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:path + ~field:"module" + an + in + let default field = + Option.map (fun s -> + sprintf "%s.%s" s field) module_ + in + let default_t field = + Option.map (fun s -> + let type_param = + match List.map (sprintf "'%s") type_param with + | [] -> "" + | x::[] -> sprintf "%s " x + | param -> sprintf "(%s) " (String.concat ", " type_param) in + sprintf "%s%s.%s" type_param s field) module_ + in + let t = + Atd.Annot.get_field + ~parse:(fun s -> Some (Some s)) + ~default:(default_t "t") + ~sections:path + ~field:"t" + an + in + let wrap = + Atd.Annot.get_field + ~parse:(fun s -> Some (Some s)) + ~default:(default "wrap") + ~sections:path + ~field:"wrap" + an + in + let unwrap = + Atd.Annot.get_field + ~parse:(fun s -> Some (Some s)) + ~default:(default "unwrap") + ~sections:path + ~field:"unwrap" + an + in + match t, wrap, unwrap with + None, None, None -> None + | Some t, Some wrap, Some unwrap -> + Some { ocaml_wrap_t = t; ocaml_wrap = wrap; ocaml_unwrap = unwrap } + | _ -> + Error.error loc "Incomplete annotation. Missing t, wrap or unwrap" + +let get_ocaml_cons target default an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:(fun s -> Some s) + ~default + ~sections:path + ~field:"name" + an + +let get_ocaml_fname target default an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:(fun s -> Some s) + ~default:default + ~sections:path + ~field:"name" + an + +let get_ocaml_default target an = + let path = path_of_target target in + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:path + ~field:"default" + an + +let get_ocaml_mutable target an = + let path = path_of_target target in + Atd.Annot.get_flag + ~sections:path + ~field:"mutable" + an + +let get_ocaml_predef target an = + let path = path_of_target target in + Atd.Annot.get_flag + ~sections:path + ~field:"predef" + an + +let get_ocaml_module target an = + let path = path_of_target target in + let o = + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:path + ~field:"module" + an + in + match o with + Some s -> Some (s, s) + | None -> + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:path + ~field:"from" an + |> Option.map (fun s -> + let type_module = R.ocaml_type_module_name s in + let main_module = R.ocaml_module_name target s in + (type_module, main_module)) + +let get_ocaml_t target default an = + let path = path_of_target target in + Atd.Annot.get_field + ~parse:(fun s -> Some s) + ~default:default + ~sections:path + ~field:"t" + an + +let get_ocaml_module_and_t target default_name an = + get_ocaml_module target an + |> Option.map (fun (type_module, main_module) -> + (type_module, main_module, get_ocaml_t target default_name an)) + +let get_type_attrs an = + Atd.Annot.get_fields + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + an diff --git a/atdgen/src/ocaml_annot.mli b/atdgen/src/ocaml_annot.mli new file mode 100644 index 00000000..17c1e074 --- /dev/null +++ b/atdgen/src/ocaml_annot.mli @@ -0,0 +1,35 @@ +(* + Read ATD annotations relating to OCaml. +*) + +val annot_schema_of_target : Ocaml_repr.target -> Atd.Annot.schema + +val get_ocaml_sum : + Ocaml_repr.target -> Atd.Annot.t -> Ocaml_repr.atd_ocaml_sum +val get_ocaml_record : + Ocaml_repr.target -> Atd.Annot.t -> Ocaml_repr.atd_ocaml_record +val get_ocaml_field_prefix : Ocaml_repr.target -> Atd.Annot.t -> string +val get_ocaml_list : + Ocaml_repr.target -> Atd.Annot.t -> Ocaml_repr.atd_ocaml_list +val get_ocaml_wrap : + type_param:string list -> Ocaml_repr.target -> Atd.Ast.loc -> + Atd.Annot.t -> Ocaml_repr.atd_ocaml_wrap option +val get_ocaml_int : + Ocaml_repr.target -> Atd.Annot.t -> Ocaml_repr.atd_ocaml_int +val get_ocaml_cons : Ocaml_repr.target -> string -> Atd.Annot.t -> string +val get_ocaml_fname : Ocaml_repr.target -> string -> Atd.Annot.t -> string +val get_ocaml_mutable : Ocaml_repr.target -> Atd.Annot.t -> bool +val get_ocaml_predef : Ocaml_repr.target -> Atd.Annot.t -> bool +val get_ocaml_default : Ocaml_repr.target -> Atd.Annot.t -> string option + +val get_ocaml_type_name : + Ocaml_repr.env -> Atd.Ast.loc -> Atd.Ast.type_name -> + Atd.Annot.t -> Ocaml_repr.t + +val get_ocaml_module_and_t : + Ocaml_repr.target -> + string -> + Atd.Annot.t -> + (string * string * string) option + +val get_type_attrs : Atd.Annot.t -> string list diff --git a/atdgen/src/ocaml_format_types.ml b/atdgen/src/ocaml_format_types.ml new file mode 100644 index 00000000..fe25b1ed --- /dev/null +++ b/atdgen/src/ocaml_format_types.ml @@ -0,0 +1,734 @@ +(* + A minimal OCaml AST used to pretty-print OCaml type definitions. + + It used to be a confusing part of ocaml.ml. + Perhaps it should be removed completely because it's complicated and + doesn't add much value. +*) + +open Atd.Stdlib_extra +module A = Atd.Ast +module An = Ocaml_annot +module R = Ocaml_repr + +(* + OCaml syntax tree used to represent type expressions before + pretty-printing. +*) +type ocaml_type_param = string list + +type ocaml_expr = + | Sum of (R.atd_ocaml_sum * ocaml_variant list) + | Record of (R.atd_ocaml_record * ocaml_field list) + | Tuple of ocaml_expr list + | Name of ((* OCaml type name Foo.bar or bar *) string * ocaml_expr list) + | Tvar of string + +and ocaml_variant = + string * ocaml_expr option * Atd.Doc.doc option + +and ocaml_field = + (string * bool (* is mutable? *)) * ocaml_expr * Atd.Doc.doc option + +(* + OCaml type definition: + + type foo = Baz_t.foo = bar list [@@what ever] + ^^^ ^^^^^^^^^ ^^^^^^^^ ^^^^^^^^^^^^^ + name alias expr ppx attrs + + A useful definition in the context of ATD would have at least an expr + or an alias. +*) +type ocaml_def = { + o_def_name : (string * ocaml_type_param); + o_def_alias : (string * ocaml_type_param) option; + o_def_expr : ocaml_expr option; + o_def_doc : Atd.Doc.doc option; + o_def_attrs : string list; +} + +type ocaml_module_body = ocaml_def list + +(* https://ocaml.org/manual/lex.html#sss:keywords *) +let is_ocaml_keyword = function + | "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" + | "do" | "done" | "downto" | "else" | "end" | "exception" | "external" + | "false" | "for" | "fun" | "function" | "functor" | "if" | "in" | "include" + | "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl" + | "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new" + | "nonrec" | "object" | "of" | "open" | "or" | "private" | "rec" | "sig" + | "struct" | "then" | "to" | "true" | "try" | "type" | "val" | "virtual" + | "when" | "while" | "with" -> true + | _ -> false + +(* + Mapping from ATD to OCaml +*) + + +let string_of_ocaml_list (x : R.atd_ocaml_list) = + match x with + | List -> "list" + | Array -> "Atdgen_runtime.Util.ocaml_array" + +let string_of_ocaml_int (x : R.atd_ocaml_int) = + match x with + | Int -> "int" + | Char -> "Char.t" + | Int32 -> "Int32.t" + | Int64 -> "Int64.t" + | Float -> "float" + +let rec map_expr (env : R.env) + (type_param: A.type_param) (x : A.type_expr) : ocaml_expr = + let target = env.target in + match x with + Atd.Ast.Sum (_, l, an) -> + let kind = An.get_ocaml_sum target an in + Sum (kind, List.map (map_variant env ~kind) l) + | Record (loc, l, an) -> + let kind = An.get_ocaml_record target an in + let field_prefix = An.get_ocaml_field_prefix target an in + if l = [] then + Error.error loc "Empty record (not valid in OCaml)" + else + Record (kind, List.map (map_field env field_prefix) l) + | Tuple (_, l, _) -> + Tuple (List.map (fun (_, x, _) -> (map_expr env []) x) l) + | List (_, x, an) -> + let s = string_of_ocaml_list (An.get_ocaml_list target an) in + Name (s, [map_expr env [] x]) + | Option (_, x, _) -> + Name ("option", [map_expr env [] x]) + | Nullable (_, x, _) -> + Name ("option", [map_expr env [] x]) + | Shared (_, _, _) -> + failwith "Sharing is not supported" + | Wrap (loc, x, a) -> + (match An.get_ocaml_wrap ~type_param target loc a with + | None -> map_expr env [] x + | Some { ocaml_wrap_t ; _ } -> Name (ocaml_wrap_t, []) + ) + | Name (_, (loc2, name, l), an) -> + let name = Ocaml_repr.name env loc2 name in + Name (name.full_type_name, List.map (map_expr env []) l) + | Tvar (_, s) -> + Tvar s + +and map_variant (env : R.env) ~kind (x : A.variant) : ocaml_variant = + match kind, x with + | _, Inherit _ -> assert false + | Poly, Variant (loc, _, Some (Record _)) -> + Error.error loc + "Inline records are not allowed in polymorphic variants \ + (not valid in OCaml)" + | _, Variant (loc, (s, an), o) -> + let s = An.get_ocaml_cons env.target s an in + (s, Option.map (map_expr env []) o, Atd.Doc.get_doc loc an) + +and map_field (env : R.env) ocaml_field_prefix (x : A.field) : ocaml_field = + let target = env.target in + match x with + Inherit _ -> assert false + | Field (loc, (atd_fname, _, an), x) -> + let ocaml_fname = + An.get_ocaml_fname target (ocaml_field_prefix ^ atd_fname) an in + if is_ocaml_keyword ocaml_fname then + Error.error loc + ("\"" ^ ocaml_fname ^ + "\" cannot be used as field name (reserved OCaml keyword)"); + let fname = + if ocaml_fname = atd_fname then ocaml_fname + else sprintf "%s (*atd %s *)" ocaml_fname atd_fname + in + let is_mutable = An.get_ocaml_mutable target an in + ((fname, is_mutable), map_expr env [] x, Atd.Doc.get_doc loc an) + +(* hack to deal with legacy behavior *) +let lhs_has_possibly_relevant_annotation + (x : A.type_def) = + List.exists + (fun target -> + let name = + match x.name with + | TN [x] -> x + | TN _ -> assert false + in + Ocaml_annot.get_ocaml_module_and_t target name x.annot <> None) + R.all_targets + +(* hack to deal with legacy behavior *) +let rhs_is_just_abstract (x : A.type_def) = + match x.value with + | Atd.Ast.Name (_, (loc, TN ["abstract"], type_params), an2) -> + if type_params <> [] then + Error.error loc "\"abstract\" takes no type parameters"; + true + | _ -> + false + +(* + This is an ATD definition of the form + + type foo <...> = abstract + + e.g. + + type foo = abstract + + where the right-hand side is exactly 'abstract' and is ignored. + This is weird and will be deprecated as soon as we implement + a clean module system allowing us to import whole modules without + special annotations. + + The annotation <...> on the left-hand side specifies the type name and + readers/writers to be used. They are placed there rather than + directly on 'abstract' for "historical reasons". We preserve the legacy + behavior unless there's no suitable left-hand side annotation. + + The following is valid and follows the more recent convention that + 'abstract' means "untyped data". It is NOT considered an abstract + definition: + + type foo = abstract + ^^^^^^^^ + JSON or biniou AST representing raw data +*) +let is_abstract_def (x : A.type_def) = + lhs_has_possibly_relevant_annotation x + && rhs_is_just_abstract x + +let map_def + ~(env : R.env) + ~(type_aliases : string option) + (td : A.type_def) : ocaml_def option = + let name = + match td.name with + | TN [x] -> x + | _ -> assert false + in + let an1 = td.annot in + let loc = td.loc in + if is_ocaml_keyword name then + Error.error loc + (sprintf {|"%s" cannot be used as type name (reserved OCaml keyword)|} + name); + let is_predef = An.get_ocaml_predef env.target an1 in + let is_abstract = is_abstract_def td in + let define_alias = + if is_predef || is_abstract || type_aliases <> None then + match An.get_ocaml_module_and_t env.target name an1, type_aliases with + Some (types_module, _, s), _ -> Some (types_module, s) + | None, Some types_module -> Some (types_module, name) + + | None, None -> None + else + None + in + if is_predef && define_alias = None then + None + else + let an2 = Atd.Ast.annot_of_type_expr td.value in + let an = an1 @ an2 in + let doc = Atd.Doc.get_doc loc an in + let alias, x = + match define_alias with + None -> + (* Ordinary type definitions or aliases: + type foo = string * int + type foo = bar + type foo = { hello: string } + *) + if is_abstract then (None, None) + else (None, Some (map_expr env td.param td.value)) + | Some (module_path, ext_name) -> + (* + type foo = Bar_t.foo = { hello: string } + or + type foo = Bar_t.foo = Alpha | Beta of int + *) + let alias = Some (module_path ^ "." ^ ext_name, td.param) in + let x = + match map_expr env td.param td.value with + | Sum (Classic, _) + | Record (Record, _) as x -> Some x + | _ -> None + in + (alias, x) + in + if x = None && alias = None then + None + else + Some { + o_def_name = (name, td.param); + o_def_alias = alias; + o_def_expr = x; + o_def_doc = doc; + o_def_attrs = An.get_type_attrs an1; + } + +(* + Mapping from Mapping to OCaml +*) + +let rec ocaml_of_expr_mapping + (env : R.env) (x : (R.t, _) Mapping.t) : ocaml_expr = + match x with + | Unit (_, Unit, _) -> Name ("unit", []) + | Bool (_, Bool, _) -> Name ("bool", []) + | Int (_, Int x, _) -> Name (R.string_of_ocaml_int x, []) + | Float (_, Float, _) -> Name ("float", []) + | String (_, String, _) -> Name ("string", []) + | Sum (_, a, Sum kind, _) -> + let l = Array.to_list a in + Sum (kind, List.map (ocaml_of_variant_mapping env) l) + | Record (_, a, Record _, _) -> + let l = Array.to_list a in + Record (Record, List.map (ocaml_of_field_mapping env) l) + | Tuple (_, a, _, _) -> + let l = Array.to_list a in + Tuple (List.map (fun (x : _ Mapping.cell_mapping) -> + ocaml_of_expr_mapping env x.cel_value) l) + | List (_, x, List kind, _) -> + Name (R.string_of_ocaml_list kind, [ocaml_of_expr_mapping env x]) + | Option (_, x, Option, _) -> + Name ("option", [ocaml_of_expr_mapping env x]) + | Nullable (_, x, Nullable, _) -> + Name ("option", [ocaml_of_expr_mapping env x]) + | Wrap _ -> + assert false + | Name (_, _, l, Name x, _) -> + Name (x.full_type_name, + List.map (ocaml_of_expr_mapping env) l) + | Tvar (_, s) -> + Tvar s + | Abstract _ -> Name ("Yojson.Safe.t", []) + | _ -> assert false + +and ocaml_of_variant_mapping env x : ocaml_variant = + let o = + match x.var_arepr with + Variant o -> o + | _ -> assert false + in + (o.ocaml_cons, + Option.map (ocaml_of_expr_mapping env) x.var_arg, + o.ocaml_vdoc) + +and ocaml_of_field_mapping env x : ocaml_field = + let o = + match x.f_arepr with + Field o -> o + | _ -> assert false + in + let v = ocaml_of_expr_mapping env x.f_value in + ((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc) + + +(* + Pretty-printing +*) + +open Easy_format + +let rlist = { list with + wrap_body = `Force_breaks; + indent_body = 0; + align_closing = false; + space_after_opening = false; + space_before_closing = false + } + +let plist = { list with + align_closing = false; + space_after_opening = false; + space_before_closing = false } + +let hlist = { list with wrap_body = `No_breaks } +let shlist = { hlist with + stick_to_label = false; + space_after_opening = false; + space_before_closing = false } + +let llist = { + list with + separators_stick_left = false; + space_before_separator = true; + space_after_separator = true +} + +let lplist = { + llist with + space_after_opening = false; + space_before_closing = false +} + +let vlist1 = { list with stick_to_label = false } + +let vlist = { + vlist1 with + wrap_body = `Force_breaks; +} + +let make_atom s = Atom (s, atom) + +let horizontal_sequence l = Easy_format.List (("", "", "", shlist), l) + +let vertical_sequence ?(skip_lines = 0) l = + let l = + if skip_lines = 0 then l + else + let sep = List.init skip_lines (fun _ -> (Atom ("", atom))) in + List.insert_sep l ~sep + in + Easy_format.List (("", "", "", rlist), l) + +let escape f s = + let buf = Buffer.create (2 * String.length s) in + for i = 0 to String.length s - 1 do + let c = s.[i] in + match f c with + None -> Buffer.add_char buf c + | Some s -> Buffer.add_string buf s + done; + Buffer.contents buf + +let ocamldoc_escape s = + let esc = function + '{' | '}' | '[' | ']' | '@' | '\\' as c -> Some (sprintf "\\%c" c) + | _ -> None + in + escape esc s + +let ocamldoc_verbatim_escape s = + let esc = function + '{' | '}' | '\\' as c -> Some (sprintf "\\%c" c) + | _ -> None + in + escape esc s + +let split = Re.Str.split (Re.Str.regexp " ") + + +let make_ocamldoc_block = function + | Atd.Doc.Pre s -> Atom ("\n{v\n" ^ ocamldoc_verbatim_escape s ^ "\nv}", atom) + | Paragraph l -> + let l = List.map (function + | Atd.Doc.Text s -> ocamldoc_escape s + | Code s -> "[" ^ ocamldoc_escape s ^ "]" + ) l + in + let words = split (String.concat "" l) in + let atoms = List.map (fun s -> Atom (s, atom)) words in + List (("", "", "", plist), atoms) + +let rec make_ocamldoc_blocks = function + | [] + | [_] as l -> List.map make_ocamldoc_block l + | x :: (y :: _ as xs) -> + let rest = make_ocamldoc_blocks xs in + let rest = + match y with + | Atd.Doc.Paragraph _ -> Atom ("", atom) :: rest + | Pre _ -> rest in + make_ocamldoc_block x :: rest + +let make_ocamldoc_comment l = + let blocks = make_ocamldoc_blocks l in + let xlist = + match l with + [] | [_] -> vlist1 + | _ -> vlist + in + Easy_format.List (("(**", "", "*)", xlist), blocks) + +let prepend_ocamldoc_comment doc x = + match doc with + None -> x + | Some y -> + let comment = make_ocamldoc_comment y in + Easy_format.List (("", "", "", rlist), [comment;x]) + +let append_ocamldoc_comment x doc = + match doc with + None -> x + | Some y -> + let comment = make_ocamldoc_comment y in + Label ((x, label), comment) + +let format_pp_conv_node node x = + match (x : R.pp_convs) with + | Camlp4 [] + | Ppx_deriving [] + | Ppx [] -> node + | converters -> + let attr value = "[@@" ^ value ^ "]" in + let converters = + match converters with + | Ppx_deriving cs -> attr ("deriving " ^ (String.concat ", " cs)) + | Camlp4 cs -> "with " ^ (String.concat ", " cs) + | Ppx cs -> List.map attr cs |> String.concat "" in + Label ((node, label), make_atom converters) + +let tick (x : R.atd_ocaml_sum) = + match x with + | Poly -> "`" + | Classic -> "" + +let dot (x : R.atd_ocaml_record) = + match x with + | Record -> "." + | Object -> "#" + +let rec format_module_item pp_convs + is_first (def : ocaml_def) = + let type_ = if is_first then "type" else "and" in + let s, param = def.o_def_name in + let alias = def.o_def_alias in + let expr = def.o_def_expr in + let doc = def.o_def_doc in + (* TODO: currently replacing, globally set pp_convs, maybe should merge? *) + let pp_convs : R.pp_convs = + match def.o_def_attrs with + | [] -> pp_convs + | attrs -> Ppx attrs + in + let append_if b s1 s2 = + if b then s1 ^ s2 + else s1 + in + let part1 = + horizontal_sequence ( + make_atom type_ :: + prepend_type_param param + [ make_atom (append_if (alias <> None || expr <> None) s " =") ] + ) + in + let part12 = + match alias with + None -> part1 + | Some (name, param) -> + let right = + horizontal_sequence ( + prepend_type_param param + [ make_atom (append_if (expr <> None) name " =") ] + ) + in + Label ( + (part1, label), + right + ) + in + let part123 = + match expr with + None -> part12 + + | Some t -> + Label ( + (part12, label), + format_type_expr t + ) + in + format_pp_conv_node (prepend_ocamldoc_comment doc part123) pp_convs + + +and prepend_type_param l tl = + match l with + [] -> tl + | _ -> + let make_var s = make_atom ("'" ^ s) in + let x = + match l with + [s] -> make_var s + | l -> List (("(", ",", ")", plist), List.map make_var l) + in + x :: tl + +and prepend_type_args l tl = + match l with + [] -> tl + | _ -> + let x = + match l with + [t] -> format_type_expr t + | l -> List (("(", ",", ")", plist), List.map format_type_expr l) + in + x :: tl + +and format_type_expr x = + match x with + | Sum (kind, l) -> + let op, cl = + match kind with + | Classic -> "", "" + | Poly -> "[", "]" + in + List ( + (op, "|", cl, llist), + List.map (format_variant kind) l + ) + | Record (kind, l) -> + let op, cl = + match kind with + Record -> "{", "}" + | Object -> "<", ">" + in + List ( + (op, ";", cl, list), + List.map format_field l + ) + | Tuple l -> + List ( + ("(", "*", ")", lplist), + List.map format_type_expr l + ) + | Name (name, args) -> + format_type_name name args + | Tvar name -> + make_atom ("'" ^ name) + +and format_type_name name args = + horizontal_sequence (prepend_type_args args [ make_atom name ]) + +and format_field ((s, is_mutable), t, doc) = + let l = + let l = [make_atom (s ^ ":")] in + if is_mutable then + make_atom "mutable" :: l + else l + in + let field = + Label ( + (horizontal_sequence l, label), + format_type_expr t + ) + in + append_ocamldoc_comment field doc + +and format_variant kind (s, o, doc) = + let s = tick kind ^ s in + let cons = make_atom s in + let variant = + match o with + None -> cons + | Some t -> + Label ( + (cons, label), + Label ( + (make_atom "of", label), + format_type_expr t + ) + ) + in + append_ocamldoc_comment variant doc + +let format_module_items pp_convs (l : ocaml_module_body) = + match l with + x :: l -> + format_module_item pp_convs true x :: + List.map (fun x -> format_module_item pp_convs false x) l + | [] -> [] + +let format_module_bodies pp_conv (l : (bool * ocaml_module_body) list) = + List.concat_map (fun (_, x) -> format_module_items pp_conv x) l + +let format_head (loc, an) = + match Atd.Doc.get_doc loc an with + None -> [] + | Some doc -> [make_ocamldoc_comment doc] + +let format_all l = + vertical_sequence ~skip_lines:1 l + +let ocaml_of_expr x : string = + Easy_format.Pretty.to_string (format_type_expr x) + +let ocaml_of_atd ?(pp_convs=R.Ppx_deriving []) ~target ~type_aliases + (head, imports, (defs : (bool * A.type_def list) list)) : string = + let env = R.init_env imports target in + let head = format_head head in + (* TODO: figure out what to do with the imports. Add them to a table + and check that all references to external modules were imported. *) +(* + let imports = check_imports imports in +*) + let bodies = + List.map (fun (is_rec, type_defs) -> + let type_defs = + List.filter_map (map_def ~env ~type_aliases) type_defs + in + (is_rec,type_defs) + ) defs + in + let body = format_module_bodies pp_convs bodies in + let x = format_all (head @ body) in + Easy_format.Pretty.to_string x + +(* + Record field defaults +*) + +type create_fields = + { intf_params: string + ; impl_params: string + ; impl_fields: string + } + +let unwrap_option (x : (_, _) Mapping.t) = + match x with + | Option (_, x, _, _) + | Nullable (_, x, _, _) -> x + | Name (loc, s, _, _, _) -> + Error.error loc ("Not an option type: " ^ s) + | x -> + Error.error (Mapping.loc_of_mapping x) "Not an option type" + +let map_record_creator_field env deref (x : (_, _) Mapping.field_mapping) = + let o = + match (x.f_arepr : R.t) with + | Field o -> o + | _ -> assert false + in + let fname = o.ocaml_fname in + let impl2 = sprintf "\n %s = %s;" fname fname in + match x.f_kind with + Required -> + let t = ocaml_of_expr (ocaml_of_expr_mapping env x.f_value) in + let intf = sprintf "\n %s: %s ->" fname t in + let impl1 = sprintf "\n ~%s" fname in + { intf_params = intf + ; impl_params = impl1 + ; impl_fields = impl2 + } + + | Optional -> + let x = unwrap_option (deref x.f_value) in + let t = ocaml_of_expr (ocaml_of_expr_mapping env x) in + let intf = sprintf "\n ?%s: %s ->" fname t in + let impl1 = sprintf "\n ?%s" fname in + { intf_params = intf + ; impl_params = impl1 + ; impl_fields = impl2 + } + + | With_default -> + let t = ocaml_of_expr (ocaml_of_expr_mapping env x.f_value) in + let intf = sprintf "\n ?%s: %s ->" fname t in + let impl1 = + let default = + match o.ocaml_default with + None -> + (match get_implicit_ocaml_default (deref x.f_value) with + None -> + Error.error x.f_loc "Missing default field value" + | Some s -> s + ) + | Some s -> s + in + sprintf "\n ?(%s = %s)" fname default + in + { intf_params = intf + ; impl_params = impl1 + ; impl_fields = impl2 + } diff --git a/atdgen/src/ocaml_format_types.mli b/atdgen/src/ocaml_format_types.mli new file mode 100644 index 00000000..f4a182e6 --- /dev/null +++ b/atdgen/src/ocaml_format_types.mli @@ -0,0 +1,34 @@ +(* + A minimal OCaml AST used to pretty-print OCaml type definitions. +*) + +type create_fields = { + intf_params: string; + impl_params: string; + impl_fields: string; +} + +val ocaml_of_atd : + ?pp_convs:Ocaml_repr.pp_convs -> + target:Ocaml_repr.target -> + type_aliases:string option -> + ((Atd.Ast.loc * Atd.Ast.annot) + * Atd.Ast.import list + * (bool * Atd.Ast.type_def list) list) -> + string + +val string_of_ocaml_int : Ocaml_repr.atd_ocaml_int -> string + +val tick : Ocaml_repr.atd_ocaml_sum -> string + +val dot : Ocaml_repr.atd_ocaml_record -> string + +val map_record_creator_field : + ((Ocaml_repr.t, 'a) Mapping.t -> + (Ocaml_repr.t, 'b) Mapping.t) -> + (Ocaml_repr.t, 'a) Mapping.field_mapping -> + create_fields + +val unwrap_option : + ('b, 'c) Mapping.t -> + ('b, 'c) Mapping.t diff --git a/atdgen/src/ocaml_format_values.ml b/atdgen/src/ocaml_format_values.ml new file mode 100644 index 00000000..edd8fdb9 --- /dev/null +++ b/atdgen/src/ocaml_format_values.ml @@ -0,0 +1,25 @@ +(* + Helper functions for translating ATD types into OCaml expressions. + For conversions to OCaml types, see Ocaml_format_types. +*) + +module R = Ocaml_repr + +let get_implicit_ocaml_default (x : (R.t, _) Mapping.t) = + match x with + | Unit (_, Unit, _) -> Some "()" + | Bool (_, Bool, _) -> Some "false" + | Int (_, Int o, _) -> + Some (match o with + Int -> "0" + | Char -> "'\000'" + | Int32 -> "0l" + | Int64 -> "0L" + | Float -> "0.") + | Float (_, Float, _) -> Some "0.0" + | String (_, String, _) -> Some "\"\"" + | List (_, _, List List, _) -> Some "[]" + | List (_, _, List Array, _) -> Some "[||]" + | Option (_, _, Option, _) -> Some "None" + | Nullable (_, _, Nullable, _) -> Some "None" + | _ -> None diff --git a/atdgen/src/ocaml_format_values.mli b/atdgen/src/ocaml_format_values.mli new file mode 100644 index 00000000..00f5912f --- /dev/null +++ b/atdgen/src/ocaml_format_values.mli @@ -0,0 +1,6 @@ +(* + Helper functions for translating ATD types into OCaml expressions. + For conversions to OCaml types, see Ocaml_format_types. +*) + +val get_implicit_ocaml_default : (Ocaml_repr.t, 'b) Mapping.t -> string option diff --git a/atdgen/src/ocaml_repr.ml b/atdgen/src/ocaml_repr.ml new file mode 100644 index 00000000..bf2d368b --- /dev/null +++ b/atdgen/src/ocaml_repr.ml @@ -0,0 +1,160 @@ +(* + The translation of ATD type annotations into a typed representation. + This was meant to clarify what a given ATD type can map to in OCaml. +*) + +type target = Default | Biniou | Json | Validate | Bucklescript + +type env = { + target: target; + imports: Atd.Imports.t; +} + +let all_targets = [ Default; Biniou; Json; Validate; Bucklescript ] + +type pp_convs = + | Camlp4 of string list + | Ppx_deriving of string list + | Ppx of string list + +(* Type mapping from ATD to OCaml *) + +type atd_ocaml_sum = Classic | Poly +type atd_ocaml_record = Record | Object + +type atd_ocaml_int = Int | Char | Int32 | Int64 | Float +type atd_ocaml_list = List | Array + +type atd_ocaml_wrap = { + ocaml_wrap_t : string; + ocaml_wrap : string; + ocaml_unwrap : string; +} + +type atd_ocaml_field = { + ocaml_default : string option; + ocaml_fname : string; + ocaml_mutable : bool; + ocaml_fdoc : Atd.Doc.doc option; +} + +type atd_ocaml_variant = { + ocaml_cons : string; + ocaml_vdoc : Atd.Doc.doc option; +} + +type atd_ocaml_def = { + ocaml_predef : bool; + ocaml_ddoc : Atd.Doc.doc option; +} + +type name = { + (* Foo_t: OCaml module providing types *) + type_module_name: string option; + (* Foo_j or other suffix: OCaml module providing conversion functions. *) + main_module_name: string option; + (* Simple type name without parameters e.g. 'bar' *) + base_type_name: string; + (* Full type name with module, without parameters e.g. 'Foo_t.bar' *) + full_type_name: string +} + +type t = + | Unit + | Bool + | Int of atd_ocaml_int + | Float + | String + | Abstract + | Sum of atd_ocaml_sum + | Record of atd_ocaml_record + | Tuple + | List of atd_ocaml_list + | Option + | Nullable + | Wrap of atd_ocaml_wrap option + | Name of name + | External of name + | Cell of atd_ocaml_field + | Field of atd_ocaml_field + | Variant of atd_ocaml_variant + | Def of atd_ocaml_def + +let ocaml_int_of_string s : atd_ocaml_int option = + match s with + | "int" -> Some Int + | "char" -> Some Char + | "int32" -> Some Int32 + | "int64" -> Some Int64 + | "float" -> Some Float + | _ -> None + +let ocaml_sum_of_string s : atd_ocaml_sum option = + match s with + | "classic" -> Some Classic + | "poly" -> Some Poly + | _ -> None + +let ocaml_record_of_string s : atd_ocaml_record option = + match s with + | "record" -> Some Record + | "object" -> Some Object + | _ -> None + +let ocaml_list_of_string s : atd_ocaml_list option = + match s with + | "list" -> Some List + | "array" -> Some Array + | _ -> None + +let ocaml_module_suffix (target : target) = + match target with + | Default -> "_t" + | Biniou -> "_b" + | Json -> "_j" + | Bucklescript -> "_bs" + | Validate -> "_v" + +let init_env (imports : Atd.Ast.import list) (target : target) = + let imports = Atd.Imports.load imports in + { + target; + imports; + } + +let ocaml_module_name target atd_name = + String.capitalize_ascii atd_name ^ ocaml_module_suffix target + +let ocaml_type_module_name atd_name = + ocaml_module_name Default atd_name + +let ocaml_modules_of_import env (x : Atd.Ast.import) = + let type_module_name = ocaml_type_module_name x.name in + let main_module_name = ocaml_module_name env.target x.name in + type_module_name, main_module_name + +let name (env : env) loc (name : Atd.Ast.type_name) : name = + let opt_module, base_type_name = + Atd.Imports.resolve env.imports loc name + in + let type_module_name, main_module_name, full_type_name = + match opt_module with + | Some x -> + let type_module_name, main_module_name = + ocaml_modules_of_import env x + in + let full_type_name = type_module_name ^ "." ^ base_type_name in + Some type_module_name, Some main_module_name, full_type_name + | None -> None, None, base_type_name + in + { + type_module_name; + main_module_name; + base_type_name; + full_type_name; + } + +let obj_unimplemented loc (x : atd_ocaml_record) = + match x with + | Record -> () + | Object -> Error.error loc "Sorry, OCaml objects are not supported" diff --git a/atdgen/src/ocaml_repr.mli b/atdgen/src/ocaml_repr.mli new file mode 100644 index 00000000..cc1a9fd9 --- /dev/null +++ b/atdgen/src/ocaml_repr.mli @@ -0,0 +1,102 @@ +(* + OCaml-side describing how ATD types are represented in OCaml. + + Due to options specified via ATD annotations, the same ATD type + can have multiple representations of OCaml. The types here contain + the OCaml representation after the ATD annotations have been processed. +*) + +type target = Default | Biniou | Json | Validate | Bucklescript + +val all_targets : target list + +type env = { + target: target; + imports: Atd.Imports.t; +} + +type pp_convs = + | Camlp4 of string list + | Ppx_deriving of string list + | Ppx of string list + +type atd_ocaml_sum = Classic | Poly +type atd_ocaml_record = Record | Object + +type atd_ocaml_int = Int | Char | Int32 | Int64 | Float +type atd_ocaml_list = List | Array + +type atd_ocaml_wrap = { + ocaml_wrap_t : string; + ocaml_wrap : string; + ocaml_unwrap : string; +} + +type atd_ocaml_field = { + ocaml_default : string option; + ocaml_fname : string; + ocaml_mutable : bool; + ocaml_fdoc : Atd.Doc.doc option; +} + +type atd_ocaml_variant = { + ocaml_cons : string; + ocaml_vdoc : Atd.Doc.doc option; +} + +type atd_ocaml_def = { + ocaml_predef : bool; + ocaml_ddoc : Atd.Doc.doc option; +} + +type name = { + (* Foo_t: OCaml module providing types *) + type_module_name: string option; + (* Foo_j or other suffix: OCaml module providing conversion functions. *) + main_module_name: string option; + (* Simple type name without parameters e.g. 'bar' *) + base_type_name: string; + (* Full type name with module, without parameters e.g. 'Foo_t.bar' *) + full_type_name: string +} + +(** OCaml-specific options that decorate each kind of ATD AST node. *) +type t = + | Unit + | Bool + | Int of atd_ocaml_int + | Float + | String + | Abstract + | Sum of atd_ocaml_sum + | Record of atd_ocaml_record + | Tuple + | List of atd_ocaml_list + | Option + | Nullable + | Wrap of atd_ocaml_wrap option + | Name of name + | External of name + | Cell of atd_ocaml_field + | Field of atd_ocaml_field + | Variant of atd_ocaml_variant + | Def of atd_ocaml_def + +val ocaml_int_of_string : string -> atd_ocaml_int option +val ocaml_sum_of_string : string -> atd_ocaml_sum option +val ocaml_record_of_string : string -> atd_ocaml_record option +val ocaml_list_of_string : string -> atd_ocaml_list option + +(* "foo" -> "Foo_j" *) +val ocaml_module_name : target -> string -> string + +(* "foo" -> "Foo_t" *) +val ocaml_type_module_name : string -> string + +(** Convert an ATD type name possibly depending on an import into + OCaml module and type names. *) +val name : env -> Atd.Ast.loc -> Atd.Ast.type_name -> name + +val init_env : Atd.Ast.import list -> target -> env + +val obj_unimplemented : Atd.Ast.loc -> atd_ocaml_record -> unit diff --git a/atdgen/src/oj_emit.ml b/atdgen/src/oj_emit.ml index 0dc1c95a..e3944ebf 100644 --- a/atdgen/src/oj_emit.ml +++ b/atdgen/src/oj_emit.ml @@ -3,23 +3,20 @@ *) -open Atd.Import +open Atd.Stdlib_extra open Indent open Atd.Ast open Mapping module Json = Atd.Json +module R = Ocaml_repr -let target : Ocaml.target = Json -let annot_schema = Ocaml.annot_schema_of_target target - -(* - OCaml code generator (json readers and writers) -*) +let target : Ocaml_repr.target = Json +let annot_schema = Ocaml_annot.annot_schema_of_target target type param = { - deref : (Ocaml.Repr.t, Json.json_repr) Mapping.mapping -> - (Ocaml.Repr.t, Json.json_repr) Mapping.mapping; + deref : (R.t, Json.json_repr) Mapping.t -> + (R.t, Json.json_repr) Mapping.t; std : bool; unknown_field_handler : string option; (* Optional handler that takes a field name as argument @@ -120,10 +117,10 @@ let make_json_string s = Yojson.Safe.to_string (`String s) *) let rec get_writer_name ?(paren = false) - ?(name_f = fun s -> "write_" ^ s) + ?(name_f = fun (x : string) -> "write_" ^ x) p (x : Oj_mapping.t) : string = match x with - Unit (_, Ocaml.Repr.Unit, Unit) -> + Unit (_, R.Unit, Unit) -> "Yojson.Safe.write_null" | Bool (_, Bool, Bool) -> "Yojson.Safe.write_bool" @@ -158,18 +155,29 @@ let rec get_writer_name | Tvar (_, s) -> "write_" ^ (Ox_emit.name_of_var s) - | Name (_, s, args, None, None) -> + | Name (_, _, args, Name x, Name) -> let l = List.map (get_writer_name ~paren:true p) args in - let s = String.concat " " (name_f s :: l) in + let module_prefix = + match x.main_module_name with + | None -> "" + | Some x -> x ^ "." + in + let name = module_prefix ^ name_f x.base_type_name in + let s = String.concat " " (name :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | External (_, _, args, - External (_, main_module, ext_name), + External x, External) -> - let f = main_module ^ "." ^ name_f ext_name in + let module_prefix = + match x.main_module_name with + | None -> "" + | Some x -> x ^ "." + in + let name = module_prefix ^ name_f x.base_type_name in let l = List.map (get_writer_name ~paren:true p) args in - let s = String.concat " " (f :: l) in + let s = String.concat " " (name :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s @@ -730,7 +738,7 @@ let rec make_reader p type_annot (x : Oj_mapping.t) : Indent.t list = var_loc = loc; var_cons = "None"; var_arg = None; - var_arepr = Ocaml.Repr.Variant { Ocaml.ocaml_cons = "None"; + var_arepr = R.Variant { Ocaml.ocaml_cons = "None"; ocaml_vdoc = None }; var_brepr = Json.Variant { Json.json_cons = "None" }; }; @@ -738,7 +746,7 @@ let rec make_reader p type_annot (x : Oj_mapping.t) : Indent.t list = var_loc = loc; var_cons = "Some"; var_arg = Some x; - var_arepr = Ocaml.Repr.Variant { Ocaml.ocaml_cons = "Some"; + var_arepr = R.Variant { Ocaml.ocaml_cons = "Some"; ocaml_vdoc = None }; var_brepr = Json.Variant { Json.json_cons = "Some" }; }; @@ -1019,7 +1027,7 @@ and make_tuple_reader p a = Array.map ( fun x -> match x.cel_arepr with - Ocaml.Repr.Cell f -> x, f.Ocaml.ocaml_default + R.Cell f -> x, f.Ocaml.ocaml_default | _ -> assert false ) a in @@ -1172,10 +1180,10 @@ and make_tuple_reader p a = ]; ] -let make_ocaml_json_writer p ~original_types is_rec let1 let2 def = +let make_ocaml_json_writer p is_rec let1 let2 def = let x = Option.value_exn def.def_value in let name = def.def_name in - let type_constraint = Ox_emit.get_type_constraint ~original_types def in + let type_constraint = Ox_emit.get_type_constraint def in let param = def.def_param in let write = get_left_writer_name p name param in let to_string = get_left_to_string_name p name param in @@ -1206,10 +1214,10 @@ let make_ocaml_json_writer p ~original_types is_rec let1 let2 def = ] ] -let make_ocaml_json_reader p ~original_types is_rec let1 let2 def = +let make_ocaml_json_reader p is_rec let1 let2 def = let x = Option.value_exn def.def_value in let name = def.def_name in - let type_constraint = Ox_emit.get_type_constraint ~original_types def in + let type_constraint = Ox_emit.get_type_constraint def in let param = def.def_param in let read = get_left_reader_name p name param in let of_string = get_left_of_string_name p name param in @@ -1245,7 +1253,7 @@ let make_ocaml_json_reader p ~original_types is_rec let1 let2 def = let make_ocaml_json_impl ~std ~unknown_field_handler - ~with_create ~force_defaults ~preprocess_input ~original_types + ~with_create ~force_defaults ~preprocess_input ~ocaml_version buf deref defs = let p = @@ -1262,13 +1270,13 @@ let make_ocaml_json_impl let writers = List.map_first (fun ~is_first def -> let let1, let2 = Ox_emit.get_let ~is_rec ~is_first in - make_ocaml_json_writer p ~original_types is_rec let1 let2 def + make_ocaml_json_writer p is_rec let1 let2 def ) l in let readers = List.map_first (fun ~is_first def -> let let1, let2 = Ox_emit.get_let ~is_rec ~is_first in - make_ocaml_json_reader p ~original_types is_rec let1 let2 def + make_ocaml_json_reader p is_rec let1 let2 def ) l in List.flatten (writers @ readers)) @@ -1296,7 +1304,7 @@ let make_mli let make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~std ~unknown_field_handler - ~force_defaults ~preprocess_input ~original_types + ~force_defaults ~preprocess_input ~ocaml_version ocaml_typedefs deref defs = let buf = Buffer.create 1000 in @@ -1309,7 +1317,7 @@ let make_ml if with_fundefs then make_ocaml_json_impl ~std ~unknown_field_handler - ~with_create ~force_defaults ~preprocess_input ~original_types + ~with_create ~force_defaults ~preprocess_input ~ocaml_version buf deref defs; Buffer.contents buf @@ -1330,7 +1338,7 @@ let make_ocaml_files ~ocaml_version ~pp_convs atd_file out = - let ((head, m0), _) = + let module_ = match atd_file with Some file -> Atd.Util.load_file @@ -1345,25 +1353,20 @@ let make_ocaml_files ?pos_fname ?pos_lnum stdin in - - let tsort = - if all_rec then - function m -> [ (true, m) ] - else - Atd.Util.tsort - in - let m1 = tsort m0 in - let defs1 = Oj_mapping.defs_of_atd_modules m1 ~target in - let (m1', original_types) = - Atd.Expand.expand_module_body ~keep_builtins:false ~keep_poly:true m0 + let def_groups1 = Atd.Util.tsort ~all_rec module_.type_defs in + let defs1 = Oj_mapping.defs_of_def_groups def_groups1 ~target in + let def_groups2 = + Atd.Expand.expand_type_defs ~keep_builtins:false ~keep_poly:true + module_.type_defs + |> Atd.Util.tsort ~all_rec in - let m2 = tsort m1' in - (* m0 = original type definitions - m1 = original type definitions after dependency analysis - m2 = monomorphic type definitions after dependency analysis *) + (* module.type_defs = original type definitions + def_groups1 = original type definitions after dependency analysis + def_groups2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = - Ocaml.ocaml_of_atd ~pp_convs ~target:Json ~type_aliases (head, m1) in - let defs = Oj_mapping.defs_of_atd_modules m2 ~target in + Ocaml.ocaml_of_atd ~pp_convs ~target:Json ~type_aliases + (module_.module_head, module_.imports, def_groups1) in + let defs = Oj_mapping.defs_of_def_groups def_groups2 ~target in let header = let src = match atd_file with @@ -1381,7 +1384,7 @@ let make_ocaml_files let ml = make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~std ~unknown_field_handler - ~force_defaults ~preprocess_input ~original_types + ~force_defaults ~preprocess_input ~ocaml_version ocaml_typedefs (Mapping.make_deref defs) defs in diff --git a/atdgen/src/oj_emit.mli b/atdgen/src/oj_emit.mli index 29384958..ae8dcfee 100644 --- a/atdgen/src/oj_emit.mli +++ b/atdgen/src/oj_emit.mli @@ -14,7 +14,7 @@ val make_ocaml_files -> force_defaults:bool -> preprocess_input:string option -> ocaml_version:(int * int) option - -> pp_convs:Ocaml.pp_convs + -> pp_convs:Ocaml_repr.pp_convs -> string option -> Ox_emit.target -> unit diff --git a/atdgen/src/oj_mapping.ml b/atdgen/src/oj_mapping.ml index ccbb2edb..7abdb42a 100644 --- a/atdgen/src/oj_mapping.ml +++ b/atdgen/src/oj_mapping.ml @@ -1,15 +1,17 @@ -open Atd.Import -open Atd.Ast -open Mapping -module Json = Atd.Json - -type t = (Ocaml.Repr.t, Json.json_repr) Mapping.mapping -type variant_mapping = (Ocaml.Repr.t, Json.json_repr) Mapping.variant_mapping - (* Translation of the types into the ocaml/json mapping. *) +open Atd.Stdlib_extra +open Mapping +module A = Atd.Ast +module Json = Atd.Json +module R = Ocaml_repr +module An = Ocaml_annot + +type t = (R.t, Json.json_repr) Mapping.t +type variant_mapping = (R.t, Json.json_repr) Mapping.variant_mapping + let check_json_sum loc json_sum_param variants = if json_sum_param.Json.json_open_enum then ( let variants_with_arg = @@ -36,139 +38,148 @@ let check_json_sum loc json_sum_param variants = when combined with ." ) -let rec mapping_of_expr (x : type_expr) = +let rec mapping_of_expr (env : R.env) (x : A.type_expr) = match x with | Sum (loc, l, an) -> - let ocaml_t = Ocaml.Repr.Sum (Ocaml.get_ocaml_sum Json an) in + let ocaml_t = R.Sum (An.get_ocaml_sum Json an) in let json_sum_param = Json.get_json_sum an in let json_t = Json.Sum (Json.get_json_sum an) in - let variants = List.map mapping_of_variant l in + let variants = List.map (mapping_of_variant env) l in check_json_sum loc json_sum_param variants; Sum (loc, Array.of_list variants, ocaml_t, json_t) | Record (loc, l, an) -> - let ocaml_t = Ocaml.Repr.Record (Ocaml.get_ocaml_record Json an) in - let ocaml_field_prefix = Ocaml.get_ocaml_field_prefix Json an in + let ocaml_t = R.Record (An.get_ocaml_record Json an) in + let ocaml_field_prefix = An.get_ocaml_field_prefix Json an in let json_t = Json.Record (Json.get_json_record an) in Record (loc, Array.of_list - (List.map (mapping_of_field ocaml_field_prefix) l), + (List.map (mapping_of_field env ocaml_field_prefix) l), ocaml_t, json_t) | Tuple (loc, l, _) -> - let ocaml_t = Ocaml.Repr.Tuple in + let ocaml_t = R.Tuple in let json_t = Json.Tuple in - Tuple (loc, Array.of_list (List.map mapping_of_cell l), + Tuple (loc, Array.of_list (List.map (mapping_of_cell env) l), ocaml_t, json_t) | List (loc, x, an) -> - let ocaml_t = Ocaml.Repr.List (Ocaml.get_ocaml_list Json an) in + let ocaml_t = R.List (An.get_ocaml_list Json an) in let json_t = Json.List (Json.get_json_list an) in - List (loc, mapping_of_expr x, ocaml_t, json_t) + List (loc, mapping_of_expr env x, ocaml_t, json_t) | Option (loc, x, _) -> - let ocaml_t = Ocaml.Repr.Option in + let ocaml_t = R.Option in let json_t = Json.Option in - Option (loc, mapping_of_expr x, ocaml_t, json_t) + Option (loc, mapping_of_expr env x, ocaml_t, json_t) | Nullable (loc, x, _) -> - let ocaml_t = Ocaml.Repr.Nullable in + let ocaml_t = R.Nullable in let json_t = Json.Nullable in - Nullable (loc, mapping_of_expr x, ocaml_t, json_t) + Nullable (loc, mapping_of_expr env x, ocaml_t, json_t) | Shared (loc, _, _) -> Error.error loc "Sharing is not supported by the JSON interface" | Wrap (loc, x, an) -> let ocaml_t = - Ocaml.Repr.Wrap (Ocaml.get_ocaml_wrap ~type_param:[] Json loc an) in + R.Wrap (An.get_ocaml_wrap ~type_param:[] Json loc an) in let json_t = Json.Wrap in - Wrap (loc, mapping_of_expr x, ocaml_t, json_t) + Wrap (loc, mapping_of_expr env x, ocaml_t, json_t) - | Name (loc, (_, s, l), an) -> + | Name (loc, (loc2, s, l), an) -> (match s with - "unit" -> + | TN ["unit"] -> Unit (loc, Unit, Unit) - | "bool" -> + | TN ["bool"] -> Bool (loc, Bool, Bool) - | "int" -> - let o = Ocaml.get_ocaml_int Json an in + | TN ["int"] -> + let o = An.get_ocaml_int Json an in Int (loc, Int o, Int) - | "float" -> + | TN ["float"] -> let j = Json.get_json_float an in Float (loc, Float, Float j) - | "string" -> + | TN ["string"] -> String (loc, String, String) - | "abstract" -> + | TN ["abstract"] -> Abstract (loc, Abstract, Abstract) - | s -> - Name (loc, s, List.map mapping_of_expr l, None, None) + | name -> + let name = R.name env loc2 name in + Name (loc, s, List.map (mapping_of_expr env) l, Name name, Name) ) | Tvar (loc, s) -> Tvar (loc, s) -and mapping_of_cell (cel_loc, x, an) = - { cel_loc - ; cel_value = mapping_of_expr x - ; cel_arepr = - Ocaml.Repr.Cell - { Ocaml.ocaml_default = Ocaml.get_ocaml_default Json an - ; ocaml_fname = "" - ; ocaml_mutable = false - ; ocaml_fdoc = Atd.Doc.get_doc cel_loc an - } - ; cel_brepr = Json.Cell +and mapping_of_cell env (cel_loc, x, an) = + { + cel_loc; + cel_value = mapping_of_expr env x; + cel_arepr = + R.Cell { + ocaml_default = An.get_ocaml_default Json an; + ocaml_fname = ""; + ocaml_mutable = false; + ocaml_fdoc = Atd.Doc.get_doc cel_loc an; + }; + cel_brepr = Json.Cell } -and mapping_of_variant = function +and mapping_of_variant env (x : A.variant) = + match x with | Inherit _ -> assert false | Variant (var_loc, (var_cons, an), o) -> - { var_loc - ; var_cons - ; var_arg = Option.map mapping_of_expr o - ; var_arepr = Ocaml.Repr.Variant - { Ocaml.ocaml_cons = Ocaml.get_ocaml_cons Json var_cons an - ; ocaml_vdoc = Atd.Doc.get_doc var_loc an - } - ; var_brepr = - Json.Variant - { Json.json_cons = Json.get_json_cons var_cons an - } + { + var_loc; + var_cons; + var_arg = Option.map (mapping_of_expr env) o; + var_arepr = Variant { + ocaml_cons = An.get_ocaml_cons Json var_cons an; + ocaml_vdoc = Atd.Doc.get_doc var_loc an + }; + var_brepr = + Json.Variant { + Json.json_cons = Json.get_json_cons var_cons an + } } -and mapping_of_field ocaml_field_prefix = function - | `Inherit _ -> assert false - | `Field (f_loc, (f_name, f_kind, an), x) -> +and mapping_of_field env ocaml_field_prefix (x : A.field) = + match x with + | Inherit _ -> assert false + | Field (f_loc, (f_name, f_kind, an), x) -> let { Ox_mapping.ocaml_default; unwrapped } = Ox_mapping.analyze_field Json f_loc f_kind an in - { f_loc - ; f_name - ; f_kind - ; f_value = mapping_of_expr x - ; f_arepr = Ocaml.Repr.Field - { Ocaml.ocaml_default - ; ocaml_fname = - Ocaml.get_ocaml_fname Json (ocaml_field_prefix ^ f_name) an - ; ocaml_mutable = Ocaml.get_ocaml_mutable Json an - ; ocaml_fdoc = Atd.Doc.get_doc f_loc an - } - ; f_brepr = Json.Field - { Json.json_fname = Json.get_json_fname f_name an - ; json_unwrapped = unwrapped - } + { + f_loc; + f_name; + f_kind; + f_value = mapping_of_expr env x; + f_arepr = R.Field { + ocaml_default; + ocaml_fname = + An.get_ocaml_fname Json (ocaml_field_prefix ^ f_name) an; + ocaml_mutable = An.get_ocaml_mutable Json an; + ocaml_fdoc = Atd.Doc.get_doc f_loc an; + }; + f_brepr = Json.Field { + Json.json_fname = Json.get_json_fname f_name an; + json_unwrapped = unwrapped; + } } -let defs_of_atd_modules l ~(target : Ocaml.target)= - (match target with +let defs_of_def_groups def_groups (env : R.env) = + (match env.target with | Json | Bucklescript -> () | t -> invalid_arg "target must be json or bucklescript"); - List.map (fun (is_rec, l) -> - ( is_rec - , List.map (function Atd.Ast.Type atd -> - Ox_emit.def_of_atd atd ~target ~external_:Json.External - ~mapping_of_expr ~def:Json.Def - ) l + List.map (fun (is_rec, defs) -> + (is_rec, + List.map (function (def : A.type_def) -> + Ox_emit.def_of_atd def + ~env + ~external_:Json.External + ~mapping_of_expr:(mapping_of_expr env) + ~def:Json.Def + ) defs ) - ) l + ) def_groups diff --git a/atdgen/src/oj_mapping.mli b/atdgen/src/oj_mapping.mli index 7c98e3d4..84b54e46 100644 --- a/atdgen/src/oj_mapping.mli +++ b/atdgen/src/oj_mapping.mli @@ -1,10 +1,10 @@ (** OCaml-Json decorated ATD AST. *) -type t = (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping +type t = (Ocaml_repr.t, Atd.Json.json_repr) Mapping.t type variant_mapping = - (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.variant_mapping + (Ocaml_repr.t, Atd.Json.json_repr) Mapping.variant_mapping -val defs_of_atd_modules - : ('a * Atd.Ast.module_body) list - -> target:Ocaml.target - -> ('a * (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.def list) list +val defs_of_def_groups + : (bool * Atd.Ast.type_def list) list + -> Ocaml_repr.env + -> (bool * (Ocaml_repr.t, Atd.Json.json_repr) Mapping.def list) list diff --git a/atdgen/src/ov_emit.ml b/atdgen/src/ov_emit.ml index 68374e74..b8ca92ab 100644 --- a/atdgen/src/ov_emit.ml +++ b/atdgen/src/ov_emit.ml @@ -2,15 +2,16 @@ Validators of OCaml data whose types are defined using ATD. *) -open Atd.Import +open Atd.Stdlib_extra open Indent open Atd.Ast open Mapping open Ov_mapping +module R = Ocaml_repr -let target : Ocaml.target = Validate -let annot_schema = Ocaml.annot_schema_of_target target +let target : R.target = Validate +let annot_schema = Ocaml_annot.annot_schema_of_target target let make_ocaml_validate_intf ~with_create buf deref defs = List.concat_map snd defs @@ -50,8 +51,8 @@ let get_fields a = let all = List.map ( fun x -> - match x.f_arepr with - Ocaml.Repr.Field o -> (x, o.Ocaml.ocaml_fname) + match (x.f_arepr : R.t) with + | Field o -> (x, o.ocaml_fname) | _ -> assert false ) (Array.to_list a) @@ -339,10 +340,10 @@ and make_record_validator a record_kind = in forall validate_fields -let make_ocaml_validator ~original_types is_rec let1 def = +let make_ocaml_validator is_rec let1 def = let x = Option.value_exn def.def_value in let name = def.def_name in - let type_constraint = Ox_emit.get_type_constraint ~original_types def in + let type_constraint = Ox_emit.get_type_constraint def in let param = def.def_param in let validate = get_left_validator_name name param in let validator_expr = make_validator x in @@ -364,14 +365,14 @@ let make_ocaml_validator ~original_types is_rec let1 def = ] -let make_ocaml_validate_impl ~with_create ~original_types buf deref defs = +let make_ocaml_validate_impl ~with_create buf deref defs = defs |> List.concat_map (fun (is_rec, l) -> let l = List.filter (fun x -> x.def_value <> None) l in let validators = List.map_first (fun ~is_first def -> let let1, _ = Ox_emit.get_let ~is_rec ~is_first in - make_ocaml_validator ~original_types is_rec let1 def + make_ocaml_validator is_rec let1 def ) l in List.flatten validators) @@ -399,7 +400,7 @@ let make_mli let make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs - ~original_types ocaml_typedefs deref defs = + ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; Ox_emit.write_opens buf opens; @@ -408,7 +409,7 @@ let make_ml if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then - make_ocaml_validate_impl ~with_create ~original_types buf deref defs; + make_ocaml_validate_impl ~with_create buf deref defs; Buffer.contents buf let make_ocaml_files @@ -424,7 +425,7 @@ let make_ocaml_files ~ocaml_version:_ ~pp_convs atd_file out = - let ((head, m0), _) = + let module_ = match atd_file with Some file -> Atd.Util.load_file @@ -439,25 +440,20 @@ let make_ocaml_files ?pos_fname ?pos_lnum stdin in - let tsort = - if all_rec then - function m -> [ (true, m) ] - else - Atd.Util.tsort - in - let m1 = tsort m0 + let def_groups1 = Atd.Util.tsort ~all_rec module_.type_defs in + let defs1 = Ov_mapping.defs_of_def_groups def_groups1 in + let def_groups2 = + Atd.Expand.expand_type_defs ~keep_poly:true module_.type_defs + |> Atd.Util.tsort ~all_rec in - let defs1 = Ov_mapping.defs_of_atd_modules m1 in - let (m1', original_types) = - Atd.Expand.expand_module_body ~keep_poly:true m0 - in - let m2 = tsort m1' in - (* m0 = original type definitions - m1 = original type definitions after dependency analysis - m2 = monomorphic type definitions after dependency analysis *) + (* module_.type_defs = original type definitions + def_groups1 = original type definitions after dependency analysis + def_groups2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = - Ocaml.ocaml_of_atd ~pp_convs ~target ~type_aliases (head, m1) in - let defs = Ov_mapping.defs_of_atd_modules m2 in + Ocaml.ocaml_of_atd ~pp_convs ~target ~type_aliases + (module_.module_head, module_.imports, def_groups1) + in + let defs2 = Ov_mapping.defs_of_def_groups def_groups2 in let header = let src = match atd_file with @@ -473,6 +469,6 @@ let make_ocaml_files in let ml = make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs - ~original_types ocaml_typedefs (Mapping.make_deref defs) defs + ocaml_typedefs (Mapping.make_deref defs2) defs2 in Ox_emit.write_ocaml out mli ml diff --git a/atdgen/src/ov_emit.mli b/atdgen/src/ov_emit.mli index afc0295d..3adfff36 100644 --- a/atdgen/src/ov_emit.mli +++ b/atdgen/src/ov_emit.mli @@ -11,5 +11,5 @@ val make_ocaml_files -> type_aliases:string option -> force_defaults:_ (* TODO unused *) -> ocaml_version:_ (* TODO unused *) - -> pp_convs:Ocaml.pp_convs + -> pp_convs:Ocaml_repr.pp_convs -> string option -> Ox_emit.target -> unit diff --git a/atdgen/src/ov_mapping.ml b/atdgen/src/ov_mapping.ml index 198dccf2..f0c219a0 100644 --- a/atdgen/src/ov_mapping.ml +++ b/atdgen/src/ov_mapping.ml @@ -1,9 +1,9 @@ -open Atd.Import +open Atd.Stdlib_extra open Atd.Ast open Mapping type ov_mapping = - (Ocaml.Repr.t, Validate.validate_repr) Mapping.mapping + (Ocaml_repr.t, Validate.validate_repr) Mapping.t (* Determine whether a type expression does not need validation. @@ -269,7 +269,7 @@ and mapping_of_variant is_shallow = function | Inherit _ -> assert false and mapping_of_field is_shallow ocaml_field_prefix = function - `Field (loc, (s, fk, an), x) -> + | Field (loc, (s, fk, an), x) -> let fvalue = mapping_of_expr is_shallow x in let ocaml_default = match fk, Ocaml.get_ocaml_default Validate an with @@ -282,7 +282,8 @@ and mapping_of_field is_shallow ocaml_field_prefix = function (* will try to determine implicit default value later *) None in - let ocaml_fname = Ocaml.get_ocaml_fname Validate (ocaml_field_prefix ^ s) an in + let ocaml_fname = + Ocaml.get_ocaml_fname Validate (ocaml_field_prefix ^ s) an in let ocaml_mutable = Ocaml.get_ocaml_mutable Validate an in let doc = Atd.Doc.get_doc loc an in { f_loc = loc; @@ -300,25 +301,27 @@ and mapping_of_field is_shallow ocaml_field_prefix = function f_brepr = (None, noval x && is_shallow x); } - | `Inherit _ -> assert false + | Inherit _ -> assert false -let def_of_atd is_shallow (loc, (name, param, an), x) = - let ocaml_predef = Ocaml.get_ocaml_predef Validate an in - let doc = Atd.Doc.get_doc loc an in +let def_of_atd is_shallow (td : type_def) = + let { loc; name; param; annot; value; _ } = td in + let ocaml_predef = Ocaml.get_ocaml_predef Validate annot in + let doc = Atd.Doc.get_doc loc annot in let o = - match as_abstract x with + match as_abstract value with | Some (_, an2) -> - (match Ocaml.get_ocaml_module_and_t Validate name an with - | None -> Some (mapping_of_expr is_shallow x) + (match Ocaml.get_ocaml_module_and_t Validate name annot with + | None -> Some (mapping_of_expr is_shallow value) | Some (types_module, main_module, ext_name) -> let args = List.map (fun s -> Tvar (loc, s)) param in Some (External (loc, name, args, Ocaml.Repr.External (types_module, main_module, ext_name), (Validate.get_validator an2, false)))) - | None -> Some (mapping_of_expr is_shallow x) + | None -> Some (mapping_of_expr is_shallow value) in + let orig = match td.orig with None -> assert false | Some x -> x in { def_loc = loc; def_name = name; @@ -328,11 +331,12 @@ let def_of_atd is_shallow (loc, (name, param, an), x) = Ocaml.Repr.Def { Ocaml.ocaml_predef = ocaml_predef; ocaml_ddoc = doc; }; def_brepr = (None, false); + def_orig = orig; } let fill_def_tbl defs l = List.iter ( - function Atd.Ast.Type (_, (name, _, _), x) -> Hashtbl.add defs name x + fun (x : type_def) -> Hashtbl.add defs x.name x.value ) l let init_def_tbl () = @@ -343,10 +347,10 @@ let make_def_tbl2 l = List.iter (fun (_, l) -> fill_def_tbl defs l) l; defs -let defs_of_atd_module_gen is_shallow l = - List.map (function Atd.Ast.Type def -> def_of_atd is_shallow def) l - -let defs_of_atd_modules l = +let defs_of_def_groups l = let defs = make_def_tbl2 l in let is_shallow = make_is_shallow defs in - List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module_gen is_shallow l)) l + List.map (fun (is_rec, defs) -> + let defs = List.map (def_of_atd is_shallow) defs in + (is_rec, defs) + ) l diff --git a/atdgen/src/ov_mapping.mli b/atdgen/src/ov_mapping.mli index 2fe78dae..ace1f096 100644 --- a/atdgen/src/ov_mapping.mli +++ b/atdgen/src/ov_mapping.mli @@ -1,8 +1,8 @@ (** Decorated ATD AST for OCaml validators. *) type ov_mapping = - (Ocaml.Repr.t, Validate.validate_repr) Mapping.mapping + (Ocaml_repr.t, Validate.validate_repr) Mapping.t -val defs_of_atd_modules - : ('a * Atd.Ast.module_body) list - -> ('a * (Ocaml.Repr.t, Validate.validate_repr) Mapping.def list) list +val defs_of_def_groups + : (bool * Atd.Ast.type_def list) list + -> (bool * (Ocaml_repr.t, Validate.validate_repr) Mapping.def list) list diff --git a/atdgen/src/ox_emit.ml b/atdgen/src/ox_emit.ml index 7ae9948c..d39a7314 100644 --- a/atdgen/src/ox_emit.ml +++ b/atdgen/src/ox_emit.ml @@ -3,12 +3,12 @@ (ox means OCaml-X) *) -open Atd.Import +open Atd.Stdlib_extra open Mapping module Json = Atd.Json -type 'a expr = (Ocaml.Repr.t, 'a) Mapping.mapping -type 'a def = (Ocaml.Repr.t, 'a) Mapping.def +type 'a expr = (Ocaml_repr.t, 'a) Mapping.t +type 'a def = (Ocaml_repr.t, 'a) Mapping.def type 'a grouped_defs = (bool * 'a def list) list type name = (loc * loc * string) @@ -81,7 +81,7 @@ let rec extract_names_from_expr ?(is_root = false) root_loc acc (x : 'a expr) = and extract_names_from_variant root_loc (l, acc) x = let l = match x.var_arepr with - Variant v -> (root_loc, x.var_loc, v.Ocaml.ocaml_cons) :: l + | Variant v -> (root_loc, x.var_loc, v.ocaml_cons) :: l | _ -> assert false in match x.var_arg with @@ -92,7 +92,7 @@ and extract_names_from_variant root_loc (l, acc) x = and extract_names_from_field root_loc (l, acc) x = let l = match x.f_arepr with - Field f -> (root_loc, x.f_loc, f.Ocaml.ocaml_fname) :: l + | Field f -> (root_loc, x.f_loc, f.ocaml_fname) :: l | _ -> assert false in (l, extract_names_from_expr root_loc acc x.f_value) @@ -183,14 +183,11 @@ let anon_param_type_name s n_param = let params = String.concat ", " (Array.to_list underscores) in "(" ^ params ^ ") " ^ s -(* Get a type expression that uses the original user-given name (e.g. not _1) *) -let get_type_constraint ~original_types def = - try - let (poly_name, n_params) = Hashtbl.find original_types def.def_name in - anon_param_type_name poly_name n_params - with Not_found -> - get_full_type_name def - +(* Get a type expression that uses the original user-given name + (e.g. not _1) *) +let get_type_constraint def = + let x = def.def_orig in + anon_param_type_name x.name (List.length x.param) (* Classic variants and records need type annotations in order to allow constructor/field name disambiguation *) @@ -314,21 +311,30 @@ let write_opens buf l = List.iter (fun s -> bprintf buf "open %s\n" s) l; bprintf buf "\n" -let def_of_atd (loc, (name, param, an), x) ~target ~def ~external_ +let def_of_atd (td : Atd.Ast.type_def) ~target ~def ~external_ ~mapping_of_expr = + let name = td.name in + let param = td.param in + let loc = td.loc in + let an = td.annot in let ocaml_predef = Ocaml.get_ocaml_predef target an in let doc = Atd.Doc.get_doc loc an in let o = - match as_abstract x with + match as_abstract td.value with Some (_, _) -> Ocaml.get_ocaml_module_and_t target name an - |> Option.map (fun (types_module, main_module, ext_name) -> + |> Option.map (fun (type_module, main_module, ext_name) -> let args = List.map (fun s -> Tvar (loc, s)) param in External (loc, name, args, - Ocaml.Repr.External (types_module, main_module, ext_name), + Ocaml.Repr.External { type_module; main_module; type_name }, external_)) - | None -> Some (mapping_of_expr x) + | None -> Some (mapping_of_expr td.value) + in + let def_orig = + match td.orig with + | None -> assert false + | Some x -> x in { def_loc = loc; @@ -339,6 +345,7 @@ let def_of_atd (loc, (name, param, an), x) ~target ~def ~external_ Ocaml.Repr.Def { Ocaml.ocaml_predef = ocaml_predef; ocaml_ddoc = doc }; def_brepr = def; + def_orig; } let maybe_write_creator_impl ~with_create deref buf defs = @@ -375,11 +382,11 @@ let default_value x deref = | Optional, _ -> Some "None" | Required, _ -> None -let include_intf (x : (Ocaml.Repr.t, _) Mapping.def) = +let include_intf (x : (Ocaml_repr.t, _) Mapping.def) = x.def_name <> "" && x.def_name.[0] <> '_' && x.def_value <> None type field = - { mapping : (Ocaml.Repr.t, Json.json_repr) Mapping.field_mapping + { mapping : (Ocaml_repr.t, Json.json_repr) Mapping.field_mapping ; ocaml_fname : string ; json_fname : string ; ocaml_default : string option diff --git a/atdgen/src/ox_emit.mli b/atdgen/src/ox_emit.mli index 94efe28c..3819b3d7 100644 --- a/atdgen/src/ox_emit.mli +++ b/atdgen/src/ox_emit.mli @@ -1,7 +1,7 @@ (** Utilities for writing OCaml code generators from a decorated ATD AST. *) -type 'a expr = (Ocaml.Repr.t, 'a) Mapping.mapping -type 'a def = (Ocaml.Repr.t, 'a) Mapping.def +type 'a expr = (Ocaml_repr.t, 'a) Mapping.t +type 'a def = (Ocaml_repr.t, 'a) Mapping.def type 'a grouped_defs = (bool * 'a def list) list type target = @@ -13,9 +13,9 @@ val get_full_type_name : (_, _) Mapping.def -> string val is_exportable : (_, _) Mapping.def -> bool val make_record_creator - : ((Ocaml.Repr.t, 'a) Mapping.mapping - -> (Ocaml.Repr.t, 'b) Mapping.mapping) - -> (Ocaml.Repr.t, 'a) Mapping.def + : ((Ocaml_repr.t, 'a) Mapping.t + -> (Ocaml_repr.t, 'b) Mapping.t) + -> (Ocaml_repr.t, 'a) Mapping.def -> string * string val opt_annot : string option -> string -> string @@ -24,10 +24,7 @@ val opt_annot_def : string option -> string -> string val insert_annot : string option -> string -val get_type_constraint - : original_types:(string, string * int) Hashtbl.t - -> ('a, 'b) Mapping.def - -> string +val get_type_constraint : ('a, 'b) Mapping.def -> string (** Determine whether the start of the given block of code was annotated with the "fun" tag, indicating that it represents a lambda (anonymous @@ -52,40 +49,38 @@ val get_let : is_rec:bool -> is_first:bool -> string * string val write_opens : Buffer.t -> string list -> unit val def_of_atd - : Atd.Ast.loc - * (string * string list * Atd.Annot.t) - * Atd.Ast.type_expr - -> target:Ocaml.target + : Atd.Ast.type_def + -> env:Ocaml_repr.env -> def:'a -> external_:'a - -> mapping_of_expr:(Atd.Ast.type_expr -> (Ocaml.Repr.t, 'a) Mapping.mapping) - -> (Ocaml.Repr.t, 'a) Mapping.def + -> mapping_of_expr:(Atd.Ast.type_expr -> (Ocaml_repr.t, 'a) Mapping.t) + -> (Ocaml_repr.t, 'a) Mapping.def val maybe_write_creator_impl : with_create:bool - -> ((Ocaml.Repr.t, 'a) Mapping.mapping -> - (Ocaml.Repr.t, 'b) Mapping.mapping) + -> ((Ocaml_repr.t, 'a) Mapping.t -> + (Ocaml_repr.t, 'b) Mapping.t) -> Buffer.t - -> ('c * (Ocaml.Repr.t, 'a) Mapping.def list) list + -> ('c * (Ocaml_repr.t, 'a) Mapping.def list) list -> unit val maybe_write_creator_intf : with_create:bool - -> ((Ocaml.Repr.t, 'a) Mapping.mapping -> - (Ocaml.Repr.t, 'b) Mapping.mapping) + -> ((Ocaml_repr.t, 'a) Mapping.t -> + (Ocaml_repr.t, 'b) Mapping.t) -> Buffer.t - -> (Ocaml.Repr.t, 'a) Mapping.def + -> (Ocaml_repr.t, 'a) Mapping.def -> unit val default_value - : (Ocaml.Repr.t, 'a) Mapping.field_mapping - -> ((Ocaml.Repr.t, 'a) Mapping.mapping -> (Ocaml.Repr.t, 'b) Mapping.mapping) + : (Ocaml_repr.t, 'a) Mapping.field_mapping + -> ((Ocaml_repr.t, 'a) Mapping.t -> (Ocaml_repr.t, 'b) Mapping.t) -> string option -val include_intf : (Ocaml.Repr.t, 'a) Mapping.def -> bool +val include_intf : (Ocaml_repr.t, 'a) Mapping.def -> bool type field = - { mapping : (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.field_mapping + { mapping : (Ocaml_repr.t, Atd.Json.json_repr) Mapping.field_mapping ; ocaml_fname : string ; json_fname : string ; ocaml_default : string option @@ -94,19 +89,19 @@ type field = } val get_fields - : ((Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping - -> (Ocaml.Repr.t, 'a) Mapping.mapping) - -> (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.field_mapping array + : ((Ocaml_repr.t, Atd.Json.json_repr) Mapping.t + -> (Ocaml_repr.t, 'a) Mapping.t) + -> (Ocaml_repr.t, Atd.Json.json_repr) Mapping.field_mapping array -> field list val is_string : - (('a, 'b) Mapping.mapping -> ('a, 'b) Mapping.mapping) - -> ('a, 'b) Mapping.mapping + (('a, 'b) Mapping.t -> ('a, 'b) Mapping.t) + -> ('a, 'b) Mapping.t -> bool -val get_assoc_type : ((Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping -> - (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping) -> +val get_assoc_type : ((Ocaml_repr.t, Atd.Json.json_repr) Mapping.t -> + (Ocaml_repr.t, Atd.Json.json_repr) Mapping.t) -> Mapping.loc -> - (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping -> - (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping * - (Ocaml.Repr.t, Atd.Json.json_repr) Mapping.mapping + (Ocaml_repr.t, Atd.Json.json_repr) Mapping.t -> + (Ocaml_repr.t, Atd.Json.json_repr) Mapping.t * + (Ocaml_repr.t, Atd.Json.json_repr) Mapping.t diff --git a/atdgen/src/ox_mapping.ml b/atdgen/src/ox_mapping.ml index 86c234f0..488ae535 100644 --- a/atdgen/src/ox_mapping.ml +++ b/atdgen/src/ox_mapping.ml @@ -1,4 +1,4 @@ -open! Atd.Import +open! Atd.Stdlib_extra open Atd.Ast type analyze_field = @@ -8,7 +8,7 @@ type analyze_field = let analyze_field target loc (f_kind : field_kind) annot = let ocaml_default, unwrapped = - match f_kind, Ocaml.get_ocaml_default target annot with + match f_kind, Ocaml_annot.get_ocaml_default target annot with Required, None -> None, false | Optional, None -> Some "None", true | (Required | Optional), Some _ -> diff --git a/atdgen/src/ox_mapping.mli b/atdgen/src/ox_mapping.mli index 1e841fc9..c0adb006 100644 --- a/atdgen/src/ox_mapping.mli +++ b/atdgen/src/ox_mapping.mli @@ -1,8 +1,9 @@ open Atd.Ast -type analyze_field = - { ocaml_default : string option - ; unwrapped : bool - } +type analyze_field = { + ocaml_default : string option; + unwrapped : bool +} -val analyze_field : Ocaml.target -> loc -> field_kind -> annot -> analyze_field +val analyze_field : + Ocaml_repr.target -> loc -> field_kind -> annot -> analyze_field diff --git a/atdgen/src/validate.ml b/atdgen/src/validate.ml index fe815d86..a5f0227c 100644 --- a/atdgen/src/validate.ml +++ b/atdgen/src/validate.ml @@ -2,7 +2,7 @@ Mapping from ATD to "validate" *) -open Atd.Import +open Atd.Stdlib_extra type validate_repr = (string option * bool) (* (opt_v, b) diff --git a/atdgen/src/xb_emit.ml b/atdgen/src/xb_emit.ml index 9cabdfb3..24f2d71f 100644 --- a/atdgen/src/xb_emit.ml +++ b/atdgen/src/xb_emit.ml @@ -3,10 +3,10 @@ (xb means X-Biniou) *) -open Atd.Import +open Atd.Stdlib_extra open Mapping -type 'a expr = ('a, Biniou.biniou_repr) Mapping.mapping +type 'a expr = ('a, Biniou.biniou_repr) Mapping.t type 'a def = ('a, Biniou.biniou_repr) Mapping.def type 'a grouped_defs = (bool * 'a def list) list diff --git a/atdgen/test/bucklescript/bucklespec_bs.expected.ml b/atdgen/test/bucklescript/bucklespec_bs.expected.ml index 419deb35..152e22e7 100644 --- a/atdgen/test/bucklescript/bucklespec_bs.expected.ml +++ b/atdgen/test/bucklescript/bucklespec_bs.expected.ml @@ -603,7 +603,7 @@ let read_point = ( ) ) let write_param_similar write__a = ( - Atdgen_codec_runtime.Encode.make (fun (t : 'a param_similar) -> + Atdgen_codec_runtime.Encode.make (fun (t : _ param_similar) -> ( Atdgen_codec_runtime.Encode.obj [ @@ -640,12 +640,12 @@ let read_param_similar read__a = ( Atdgen_codec_runtime.Decode.int |> Atdgen_codec_runtime.Decode.field "something" ) json; - } : 'a param_similar) + } : _ param_similar) ) ) ) let write_param write__a = ( - Atdgen_codec_runtime.Encode.make (fun (t : 'a param) -> + Atdgen_codec_runtime.Encode.make (fun (t : _ param) -> ( Atdgen_codec_runtime.Encode.obj [ @@ -682,12 +682,12 @@ let read_param read__a = ( Atdgen_codec_runtime.Decode.unit |> Atdgen_codec_runtime.Decode.field "nothing" ) json; - } : 'a param) + } : _ param) ) ) ) let write_pair write__a write__b = ( - Atdgen_codec_runtime.Encode.make (fun (t : ('a, 'b) pair) -> + Atdgen_codec_runtime.Encode.make (fun (t : (_, _) pair) -> ( Atdgen_codec_runtime.Encode.obj [ @@ -724,7 +724,7 @@ let read_pair read__a read__b = ( read__b |> Atdgen_codec_runtime.Decode.field "right" ) json; - } : ('a, 'b) pair) + } : (_, _) pair) ) ) ) diff --git a/atdgen/test/bucklescript/bucklespec_j.expected.ml b/atdgen/test/bucklescript/bucklespec_j.expected.ml index 2dffdc70..ac60349f 100644 --- a/atdgen/test/bucklescript/bucklespec_j.expected.ml +++ b/atdgen/test/bucklescript/bucklespec_j.expected.ml @@ -1637,8 +1637,8 @@ let read_point = ( ) let point_of_string s = read_point (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let write_param_similar write__a : _ -> 'a param_similar -> _ = ( - fun ob (x : 'a param_similar) -> +let write_param_similar write__a : _ -> _ param_similar -> _ = ( + fun ob (x : _ param_similar) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -1785,13 +1785,13 @@ let read_param_similar read__a = ( data = (match !field_data with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "data"); something = (match !field_something with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "something"); } - : 'a param_similar) + : _ param_similar) ) ) let param_similar_of_string read__a s = read_param_similar read__a (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let write_param write__a : _ -> 'a param -> _ = ( - fun ob (x : 'a param) -> +let write_param write__a : _ -> _ param -> _ = ( + fun ob (x : _ param) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -1938,13 +1938,13 @@ let read_param read__a = ( data = (match !field_data with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "data"); nothing = (match !field_nothing with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "nothing"); } - : 'a param) + : _ param) ) ) let param_of_string read__a s = read_param read__a (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let write_pair write__a write__b : _ -> ('a, 'b) pair -> _ = ( - fun ob (x : ('a, 'b) pair) -> +let write_pair write__a write__b : _ -> (_, _) pair -> _ = ( + fun ob (x : (_, _) pair) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -2091,7 +2091,7 @@ let read_pair read__a read__b = ( left = (match !field_left with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "left"); right = (match !field_right with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "right"); } - : ('a, 'b) pair) + : (_, _) pair) ) ) let pair_of_string read__a read__b s = diff --git a/atdgen/test/test.expected.ml b/atdgen/test/test.expected.ml index 45a4a569..50e97ad0 100644 --- a/atdgen/test/test.expected.ml +++ b/atdgen/test/test.expected.ml @@ -194,7 +194,7 @@ let read__a_list get__a_reader read__a = ( let _a_list_of_string get__a_reader read__a ?pos s = read__a_list get__a_reader read__a (Bi_inbuf.from_string ?pos s) let rec p'_tag = Bi_io.variant_tag -and write_untagged_p' _a_tag write_untagged__a write__a : Bi_outbuf.t -> 'a p' -> unit = ( +and write_untagged_p' _a_tag write_untagged__a write__a : Bi_outbuf.t -> _ p' -> unit = ( fun ob x -> match x with | A -> Bi_outbuf.add_char4 ob '\000' '\000' '\000' 'A' @@ -222,17 +222,17 @@ let rec get_p'_reader get__a_reader read__a = ( fun ib -> Bi_io.read_hashtag ib (fun ib h has_arg -> match h, has_arg with - | 65, false -> (A : 'a p') + | 65, false -> (A : _ p') | 14816, true -> (Bb ( ( read_p' get__a_reader read__a ) ib - ) : 'a p') + ) : _ p') | -711691517, true -> (Ccccc ( ( read__a ) ib - ) : 'a p') + ) : _ p') | _ -> Atdgen_runtime.Ob_run.unsupported_variant h has_arg ) ) @@ -241,17 +241,17 @@ and read_p' get__a_reader read__a = ( if Bi_io.read_tag ib <> 23 then Atdgen_runtime.Ob_run.read_error_at ib; Bi_io.read_hashtag ib (fun ib h has_arg -> match h, has_arg with - | 65, false -> (A : 'a p') + | 65, false -> (A : _ p') | 14816, true -> (Bb ( ( read_p' get__a_reader read__a ) ib - ) : 'a p') + ) : _ p') | -711691517, true -> (Ccccc ( ( read__a ) ib - ) : 'a p') + ) : _ p') | _ -> Atdgen_runtime.Ob_run.unsupported_variant h has_arg ) ) @@ -604,7 +604,7 @@ and string_of__a_b_poly_option _a_tag write_untagged__a write__a _b_tag write_un write__a_b_poly_option _a_tag write_untagged__a write__a _b_tag write_untagged__b write__b ob x; Bi_outbuf.contents ob and poly_tag = Bi_io.record_tag -and write_untagged_poly _x_tag write_untagged__x write__x _y_tag write_untagged__y write__y : Bi_outbuf.t -> ('x, 'y) poly -> unit = ( +and write_untagged_poly _x_tag write_untagged__x write__x _y_tag write_untagged__y write__y : Bi_outbuf.t -> (_, _) poly -> unit = ( fun ob x -> Bi_vint.write_uvint ob 2; Bi_outbuf.add_char4 ob '\128' 'M' '\202' '\135'; @@ -686,7 +686,7 @@ and get_poly_reader get__x_reader read__x get__y_reader read__y = ( fst = !field_fst; snd = !field_snd; } - : ('x, 'y) poly) + : (_, _) poly) ) and read_poly get__x_reader read__x get__y_reader read__y = ( fun ib -> @@ -719,7 +719,7 @@ and read_poly get__x_reader read__x get__y_reader read__y = ( fst = !field_fst; snd = !field_snd; } - : ('x, 'y) poly) + : (_, _) poly) ) and poly_of_string get__x_reader read__x get__y_reader read__y ?pos s = read_poly get__x_reader read__x get__y_reader read__y (Bi_inbuf.from_string ?pos s) @@ -3906,7 +3906,7 @@ let read_hello = ( let hello_of_string ?pos s = read_hello (Bi_inbuf.from_string ?pos s) let generic_tag = Bi_io.record_tag -let write_untagged_generic _a_tag write_untagged__a write__a : Bi_outbuf.t -> 'a generic -> unit = ( +let write_untagged_generic _a_tag write_untagged__a write__a : Bi_outbuf.t -> _ generic -> unit = ( fun ob x -> Bi_vint.write_uvint ob 1; Bi_outbuf.add_char4 ob '\240' 'G' '\003' '\130'; @@ -3944,7 +3944,7 @@ let get_generic_reader get__a_reader read__a = ( { x294623 = !field_x294623; } - : 'a generic) + : _ generic) ) let read_generic get__a_reader read__a = ( fun ib -> @@ -3968,7 +3968,7 @@ let read_generic get__a_reader read__a = ( { x294623 = !field_x294623; } - : 'a generic) + : _ generic) ) let generic_of_string get__a_reader read__a ?pos s = read_generic get__a_reader read__a (Bi_inbuf.from_string ?pos s) diff --git a/atdgen/test/test_atdgen_main.ml b/atdgen/test/test_atdgen_main.ml index 53315991..88b994ec 100644 --- a/atdgen/test/test_atdgen_main.ml +++ b/atdgen/test/test_atdgen_main.ml @@ -2,7 +2,7 @@ Unit tests for atdgen *) -open Atd.Import +open Atd.Stdlib_extra (* deprecated. Use the type-aware functions from Alcotest for better error reporting, e.g. diff --git a/atdgen/test/testj.expected.ml b/atdgen/test/testj.expected.ml index 20ce229b..5a6d69ce 100644 --- a/atdgen/test/testj.expected.ml +++ b/atdgen/test/testj.expected.ml @@ -173,7 +173,7 @@ let read__a_list read__a = ( ) let _a_list_of_string read__a s = read__a_list read__a (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let rec write_p' write__a : _ -> 'a p' -> _ = ( +let rec write_p' write__a : _ -> _ p' -> _ = ( fun ob x -> match x with | A -> Buffer.add_string ob "<\"A\">" @@ -203,7 +203,7 @@ let rec read_p' read__a = ( | "A" -> Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (A : 'a p') + (A : _ p') | "Bb" -> Atdgen_runtime.Oj_run.read_until_field_value p lb; let x = ( @@ -212,7 +212,7 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (Bb x : 'a p') + (Bb x : _ p') | "Ccccc" -> Atdgen_runtime.Oj_run.read_until_field_value p lb; let x = ( @@ -221,14 +221,14 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (Ccccc x : 'a p') + (Ccccc x : _ p') | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) | `Double_quote -> ( match Yojson.Safe.finish_string p lb with | "A" -> - (A : 'a p') + (A : _ p') | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) @@ -244,7 +244,7 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_rbr p lb; - (Bb x : 'a p') + (Bb x : _ p') | "Ccccc" -> Yojson.Safe.read_space p lb; Yojson.Safe.read_comma p lb; @@ -255,7 +255,7 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_rbr p lb; - (Ccccc x : 'a p') + (Ccccc x : _ p') | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) @@ -741,8 +741,8 @@ and string_of__a_b_poly_option write__a write__b ?(len = 1024) x = let ob = Buffer.create len in write__a_b_poly_option write__a write__b ob x; Buffer.contents ob -and write_poly write__x write__y : _ -> ('x, 'y) poly -> _ = ( - fun ob (x : ('x, 'y) poly) -> +and write_poly write__x write__y : _ -> (_, _) poly -> _ = ( + fun ob (x : (_, _) poly) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -955,7 +955,7 @@ and read_poly read__x read__y = ( fst = (match !field_fst with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "fst"); snd = (match !field_snd with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "snd"); } - : ('x, 'y) poly) + : (_, _) poly) ) ) and poly_of_string read__x read__y s = @@ -4034,8 +4034,8 @@ let read_hello = ( ) let hello_of_string s = read_hello (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let write_generic write__a : _ -> 'a generic -> _ = ( - fun ob (x : 'a generic) -> +let write_generic write__a : _ -> _ generic -> _ = ( + fun ob (x : _ generic) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -4129,7 +4129,7 @@ let read_generic read__a = ( { x294623 = (match !field_x294623 with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x294623"); } - : 'a generic) + : _ generic) ) ) let generic_of_string read__a s = diff --git a/atdgen/test/testjstd.expected.ml b/atdgen/test/testjstd.expected.ml index 0045415c..c6393dfc 100644 --- a/atdgen/test/testjstd.expected.ml +++ b/atdgen/test/testjstd.expected.ml @@ -173,7 +173,7 @@ let read__a_list read__a = ( ) let _a_list_of_string read__a s = read__a_list read__a (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let rec write_p' write__a : _ -> 'a p' -> _ = ( +let rec write_p' write__a : _ -> _ p' -> _ = ( fun ob x -> match x with | A -> Buffer.add_string ob "\"A\"" @@ -203,7 +203,7 @@ let rec read_p' read__a = ( | "A" -> Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (A : 'a p') + (A : _ p') | "Bb" -> Atdgen_runtime.Oj_run.read_until_field_value p lb; let x = ( @@ -212,7 +212,7 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (Bb x : 'a p') + (Bb x : _ p') | "Ccccc" -> Atdgen_runtime.Oj_run.read_until_field_value p lb; let x = ( @@ -221,14 +221,14 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (Ccccc x : 'a p') + (Ccccc x : _ p') | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) | `Double_quote -> ( match Yojson.Safe.finish_string p lb with | "A" -> - (A : 'a p') + (A : _ p') | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) @@ -244,7 +244,7 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_rbr p lb; - (Bb x : 'a p') + (Bb x : _ p') | "Ccccc" -> Yojson.Safe.read_space p lb; Yojson.Safe.read_comma p lb; @@ -255,7 +255,7 @@ let rec read_p' read__a = ( in Yojson.Safe.read_space p lb; Yojson.Safe.read_rbr p lb; - (Ccccc x : 'a p') + (Ccccc x : _ p') | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) @@ -737,8 +737,8 @@ and string_of__a_b_poly_option write__a write__b ?(len = 1024) x = let ob = Buffer.create len in write__a_b_poly_option write__a write__b ob x; Buffer.contents ob -and write_poly write__x write__y : _ -> ('x, 'y) poly -> _ = ( - fun ob (x : ('x, 'y) poly) -> +and write_poly write__x write__y : _ -> (_, _) poly -> _ = ( + fun ob (x : (_, _) poly) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -943,7 +943,7 @@ and read_poly read__x read__y = ( fst = (match !field_fst with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "fst"); snd = (match !field_snd with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "snd"); } - : ('x, 'y) poly) + : (_, _) poly) ) ) and poly_of_string read__x read__y s = @@ -3978,8 +3978,8 @@ let read_hello = ( ) let hello_of_string s = read_hello (Yojson.Safe.init_lexer ()) (Lexing.from_string s) -let write_generic write__a : _ -> 'a generic -> _ = ( - fun ob (x : 'a generic) -> +let write_generic write__a : _ -> _ generic -> _ = ( + fun ob (x : _ generic) -> Buffer.add_char ob '{'; let is_first = ref true in if !is_first then @@ -4071,7 +4071,7 @@ let read_generic read__a = ( { x294623 = (match !field_x294623 with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x294623"); } - : 'a generic) + : _ generic) ) ) let generic_of_string read__a s = diff --git a/atdgen/test/testv.expected.ml b/atdgen/test/testv.expected.ml index fcddc462..f9579e82 100644 --- a/atdgen/test/testv.expected.ml +++ b/atdgen/test/testv.expected.ml @@ -162,7 +162,7 @@ let validate__a_list validate__a = ( validate__a ) ) -let rec validate_p' validate__a : _ -> 'a p' -> _ = ( +let rec validate_p' validate__a : _ -> _ p' -> _ = ( fun path x -> match x with | A -> None @@ -218,7 +218,7 @@ let rec validate__a_b_poly_option validate__a validate__b path x = ( validate_poly validate__a validate__b ) ) path x -and validate_poly validate__x validate__y : _ -> ('x, 'y) poly -> _ = ( +and validate_poly validate__x validate__y : _ -> (_, _) poly -> _ = ( fun path x -> match ( @@ -446,7 +446,7 @@ let validate_int32 = ( let validate_hello = ( fun _ _ -> None ) -let validate_generic validate__a : _ -> 'a generic -> _ = ( +let validate_generic validate__a : _ -> _ generic -> _ = ( fun _ _ -> None ) let validate_floats : _ -> floats -> _ = ( diff --git a/atdj/src/atdj_env.ml b/atdj/src/atdj_env.ml index 4f72c78b..4ba036b5 100644 --- a/atdj/src/atdj_env.ml +++ b/atdj/src/atdj_env.ml @@ -12,14 +12,14 @@ type ty = ] type env_t = { - module_items : (string * Atd.Ast.type_expr) list; + type_defs : (Atd.Ast.type_name * Atd.Ast.type_expr) list; package : string; package_dir : string; input_file : string option; } let default_env = { - module_items = []; + type_defs = []; package = "out"; package_dir = "out"; input_file = None; diff --git a/atdj/src/atdj_helper.ml b/atdj/src/atdj_helper.ml index aff66ad0..310da0d2 100644 --- a/atdj/src/atdj_helper.ml +++ b/atdj/src/atdj_helper.ml @@ -1,6 +1,6 @@ (* Helper classes *) -open Atd.Import +open Atd.Stdlib_extra open Atdj_env let output_atdj env = diff --git a/atdj/src/atdj_main.ml b/atdj/src/atdj_main.ml index 3b5a4923..bc4eca67 100644 --- a/atdj/src/atdj_main.ml +++ b/atdj/src/atdj_main.ml @@ -1,6 +1,6 @@ (* Main *) -open Atd.Import +open Atd.Stdlib_extra open Atdj_env let args_spec env = Arg.align @@ -62,29 +62,29 @@ let main () = ); (* Parse ATD file *) - let (atd_head, atd_module), _original_types = + let module_ = Atd.Util.load_file ~expand:false ~inherit_fields:true ~inherit_variants:true input_file in let env = { env with - module_items = + Atdj_env.type_defs = List.map - (function (Atd.Ast.Type (_, (name, _, _), atd_ty)) -> (name, atd_ty)) - atd_module + (fun (x : Atd.Ast.type_def) -> (x.name, x.value)) + module_.type_defs } in (* Create package directories *) let env = { env with package_dir = make_package_dirs env.package } in (* Generate classes from ATD definition *) - let env = Atdj_trans.trans_module env atd_module in + let env = Atdj_trans.trans_module env module_ in (* Output helper classes *) Atdj_helper.output_util env; Atdj_helper.output_atdj env; - Atdj_helper.output_package_javadoc env atd_head + Atdj_helper.output_package_javadoc env module_.module_head let () = diff --git a/atdj/src/atdj_names.ml b/atdj/src/atdj_names.ml index 186ab782..96cc0e02 100644 --- a/atdj/src/atdj_names.ml +++ b/atdj/src/atdj_names.ml @@ -1,4 +1,4 @@ -open Atd.Import +open Atd.Stdlib_extra (* Names *) let to_camel_case (s : string) = @@ -27,13 +27,14 @@ let to_camel_case (s : string) = * underscores and capitalise any character that is immediately following * an underscore or digit. We also capitalise the initial character * e.g. "foo_bar42baz" becomes "FooBar42Baz". *) -let to_class_name str = - match str with - | "string" -> "String" - | "int" -> "Integer" - | "bool" -> "Boolean" - | "float" -> "Double" - | _ -> to_camel_case str +let to_class_name (name : Atd.Ast.type_name) = + match name with + | TN ["string"] -> "String" + | TN ["int"] -> "Integer" + | TN ["bool"] -> "Boolean" + | TN ["float"] -> "Double" + | TN [str] -> to_camel_case str + | TN _ -> failwith ("imports are not supported: " ^ Atd.Print.tn name) let java_keywords = [ "abstract"; diff --git a/atdj/src/atdj_trans.ml b/atdj/src/atdj_trans.ml index 71652488..2163d80e 100644 --- a/atdj/src/atdj_trans.ml +++ b/atdj/src/atdj_trans.ml @@ -1,4 +1,4 @@ -open Atd.Import +open Atd.Stdlib_extra open Atdj_names open Atdj_env open Atdj_util @@ -24,10 +24,10 @@ let json_of_atd env atd_ty = | List _ -> "JSONArray" | Name (_, (_, ty, _), _) -> (match ty with - | "bool" -> "boolean" - | "int" -> "int" - | "float" -> "double" - | "string" -> "String" + | TN ["bool"] -> "boolean" + | TN ["int"] -> "int" + | TN ["float"] -> "double" + | TN ["string"] -> "String" | _ -> type_not_supported atd_ty ) | x -> type_not_supported x @@ -69,7 +69,7 @@ let rec assign env opt_dst src java_ty atd_ty indent = sprintf "new %s(%s)" java_ty src | Name (_, (_, ty, _), _) -> (match ty with - | "bool" | "int" | "float" | "string" -> src + | TN ["bool" | "int" | "float" | "string"] -> src | _ -> type_not_supported atd_ty ) | x -> type_not_supported x @@ -96,7 +96,7 @@ let rec assign env opt_dst src java_ty atd_ty indent = | Name (_, (_, ty, _), _) -> (match ty with - | "bool" | "int" | "float" | "string" -> + | TN ["bool" | "int" | "float" | "string"] -> sprintf "%s%s = %s;\n" indent dst src | _ -> type_not_supported atd_ty ) @@ -129,8 +129,7 @@ let rec assign env opt_dst src java_ty atd_ty indent = * check for the field and manually create a default. If the field is present, * then we wrap its values as necessary. *) -let assign_field env - (`Field (_, (atd_field_name, kind, annots), atd_ty)) java_ty = +let assign_field env (_, (atd_field_name, kind, annots), atd_ty) java_ty = let json_field_name = get_json_field_name atd_field_name annots in let field_name = get_java_field_name atd_field_name annots in (* Check whether the field is optional *) @@ -156,10 +155,10 @@ let assign_field env (match norm_ty ~unwrap_option:true env atd_ty with | Name (_, (_, name, _), _) -> (match name with - | "bool" -> mk_else (Some "false") - | "int" -> mk_else (Some "0") - | "float" -> mk_else (Some "0.0") - | "string" -> mk_else (Some "\"\"") + | TN ["bool"] -> mk_else (Some "false") + | TN ["int"] -> mk_else (Some "0") + | TN ["float"] -> mk_else (Some "0.0") + | TN ["string"] -> mk_else (Some "\"\"") | _ -> mk_else None (* TODO: fail if no default is provided *) ) | List _ -> @@ -189,7 +188,7 @@ let rec to_string env id atd_ty indent = ^ sprintf "%s _out.append(\",\");\n" indent ^ sprintf "%s}\n" indent ^ sprintf "%s_out.append(\"]\");\n" indent - | Name (_, (_, "string", _), _) -> + | Name (_, (_, TN ["string"], _), _) -> (* TODO Check that this is the correct behaviour *) sprintf "%sUtil.writeJsonString(_out, %s);\n" @@ -200,15 +199,15 @@ let rec to_string env id atd_ty indent = sprintf "%s%s.toJsonBuffer(_out);\n" indent id (* Generate a toJsonBuffer command for a record field. *) -let to_string_field env = function - | (`Field (_, (atd_field_name, kind, annots), atd_ty)) -> - let json_field_name = get_json_field_name atd_field_name annots in - let field_name = get_java_field_name atd_field_name annots in - let atd_ty = norm_ty ~unwrap_option:true env atd_ty in - (* In the case of an optional field, create a predicate to test whether - * the field has its default value. *) - let if_part = - sprintf " +let to_string_field env + ((_, (atd_field_name, kind, annots), atd_ty) : A.simple_field) = + let json_field_name = get_json_field_name atd_field_name annots in + let field_name = get_java_field_name atd_field_name annots in + let atd_ty = norm_ty ~unwrap_option:true env atd_ty in + (* In the case of an optional field, create a predicate to test whether + * the field has its default value. *) + let if_part = + sprintf " if (%s != null) { if (_isFirst) _isFirst = false; @@ -217,25 +216,25 @@ let to_string_field env = function _out.append(\"\\\"%s\\\":\"); %s } " - field_name - json_field_name - (to_string env field_name atd_ty " ") - in - let else_part = - let is_opt = - match kind with - | A.Optional | With_default -> true - | Required -> false in - if is_opt then - "" - else - sprintf " \ - else + field_name + json_field_name + (to_string env field_name atd_ty " ") + in + let else_part = + let is_opt = + match kind with + | A.Optional | With_default -> true + | Required -> false in + if is_opt then + "" + else + sprintf " \ + else throw new JSONException(\"Uninitialized field %s\"); " - field_name - in - if_part ^ else_part + field_name + in + if_part ^ else_part (* Generate a javadoc comment *) let javadoc loc annots indent = @@ -300,10 +299,17 @@ import org.json.*; env.package; out -let rec trans_module env items = List.fold_left trans_outer env items - -and trans_outer env (A.Type (_, (name, _, _), atd_ty)) = - match unwrap atd_ty with +let rec trans_module env (module_ : A.module_) = + (match module_.imports with + | x :: _ -> + A.error_at x.loc "unsupported: import" + | [] -> () + ); + List.fold_left trans_type_def env module_.type_defs + +and trans_type_def env (x : A.type_def) = + let name = x.name in + match unwrap x.value with | Sum (loc, v, a) -> trans_sum name env (loc, v, a) | Record (loc, v, a) -> @@ -359,7 +365,7 @@ public class %s { return t; } " - my_name + (Atd.Print.tn my_name) class_name class_name; @@ -371,7 +377,7 @@ public class %s { %s } " - my_name + (Atd.Print.tn my_name) (String.concat ", " tags); fprintf out " @@ -499,18 +505,18 @@ public class %s { and trans_record my_name env (loc, fields, annots) = (* Remove `Inherit values *) let fields = List.map - (function - | `Field _ as f -> f - | `Inherit _ -> assert false + (fun (x : A.field) -> + match x with + | Field f -> f + | Inherit _ -> assert false ) fields in (* Translate field types *) let (java_tys, env) = List.fold_left - (fun (java_tys, env) -> function - | `Field (_, (field_name, _, annots), atd_ty) -> - let field_name = get_java_field_name field_name annots in - let (java_ty, env) = trans_inner env (unwrap_option env atd_ty) in - ((field_name, java_ty) :: java_tys, env) + (fun (java_tys, env) (_, (field_name, _, annots), atd_ty) -> + let field_name = get_java_field_name field_name annots in + let (java_ty, env) = trans_inner env (unwrap_option env atd_ty) in + ((field_name, java_ty) :: java_tys, env) ) ([], env) fields in let java_tys = List.rev java_tys in @@ -542,7 +548,7 @@ public class %s implements Atdj { class_name; let env = List.fold_left - (fun env (`Field (_, (field_name, _, annots), _) as field) -> + (fun env ((_, (field_name, _, annots), _) as field) -> let field_name = get_java_field_name field_name annots in let cmd = assign_field env field (List.assoc_exn field_name java_tys) in @@ -572,7 +578,7 @@ public class %s implements Atdj { ) fields; List.iter - (function `Field (loc, (field_name, _, annots), _) -> + (function ((loc, (field_name, _, annots), _) : A.simple_field) -> let field_name = get_java_field_name field_name annots in let java_ty = List.assoc_exn field_name java_tys in output_string out (javadoc loc annots " "); diff --git a/atdj/src/atdj_util.ml b/atdj/src/atdj_util.ml index f367d21d..8e4e56e0 100644 --- a/atdj/src/atdj_util.ml +++ b/atdj/src/atdj_util.ml @@ -1,8 +1,12 @@ (* Utilities *) -open Atd.Import +open Atd.Stdlib_extra open Atdj_env +let type_not_supported x = + let loc = Atd.Ast.loc_of_type_expr x in + Atd.Ast.error_at loc "Type not supported by atdj." + (* Get rid of `wrap' constructors that we don't support on the Java side yet. They could be useful for timestamps, though. *) let rec unwrap atd_ty = @@ -20,28 +24,26 @@ let rec unwrap_option env atd_ty = let rec norm_ty ?(unwrap_option = false) env atd_ty = let atd_ty = unwrap atd_ty in match atd_ty with - | Atd.Ast.Name (_, (_, name, _), _) -> + | Atd.Ast.Name (_, (loc, name, _), _) -> (match name with - | "bool" | "int" | "float" | "string" | "abstract" -> atd_ty - | _ -> - (match List.assoc name env.module_items with + | TN ["bool" | "int" | "float" | "string" | "abstract"] -> atd_ty + | TN [_] -> + (match List.assoc name env.type_defs with | Some x -> norm_ty env x | None -> - eprintf "Warning: unknown type %s\n%!" name; + eprintf "Warning: unknown type %s\n%!" + (Atd.Print.tn name); atd_ty) + | TN _ -> + Atd.Ast.error_at loc + (sprintf "Imports aren't supported: %s" + (Atd.Print.tn name)) ) | Option (_, atd_ty, _) when unwrap_option -> norm_ty env atd_ty | _ -> atd_ty -let not_supported loc = - Atd.Ast.error_at loc "Construct not yet supported by atdj." - -let type_not_supported x = - let loc = Atd.Ast.loc_of_type_expr x in - Atd.Ast.error_at loc "Type not supported by atdj." - let warning loc msg = let loc_s = Atd.Ast.string_of_loc loc in eprintf "\ diff --git a/atdpy/src/lib/Codegen.ml b/atdpy/src/lib/Codegen.ml index bd226531..6deedc52 100644 --- a/atdpy/src/lib/Codegen.ml +++ b/atdpy/src/lib/Codegen.ml @@ -31,6 +31,7 @@ module B = Indent naming conflicts. *) type env = { (* Global *) + imports: Atd.Imports.t; create_variable: string -> string; translate_variable: string -> string; (* Local to a class: instance variables, including method names *) @@ -83,9 +84,25 @@ let to_camel_case s = | 'A'..'Z' | 'a'..'z' | '_' -> name | _ -> "X" ^ name -(* Use CamelCase as recommended by PEP 8. *) -let class_name env id = - trans env (to_camel_case id) +(* Use CamelCase as recommended by PEP 8. + + foo_bar -> FooBar + fiz.foo_bar -> fiz.FooBar +*) +let class_name (env : env) loc (name : type_name) = + let import, base_name = Atd.Imports.resolve env.imports loc name in + match import with + | None -> trans env (to_camel_case base_name) + | Some import -> + (* Don't translate the base name 'bar' if it's fully qualified + as in 'foo.bar' because it would not conflict with the definition + of a new class 'bar'. + We do however perform the camel-case conversion from the ATD + name to the idiomatic Python name. + TODO: allow overriding the imported module and the class name via + ATD annotations. + *) + import.name ^ "." ^ (to_camel_case base_name) (* Create a class identifier that hasn't been seen yet. @@ -97,7 +114,9 @@ let create_class_name env name = let preferred_id = to_camel_case name in env.create_variable preferred_id -let init_env () : env = +let init_env (imports : import list) (defs : type_def list) : env = + let local_module_names = List.map (fun (x : import) -> x.name) imports in + let imports = Atd.Imports.load imports in let keywords = [ (* Keywords https://docs.python.org/3/reference/lexical_analysis.html#keywords @@ -139,7 +158,9 @@ let init_env () : env = ] in let variables = Atd.Unique_name.init - ~reserved_identifiers:(reserved_variables @ keywords) + ~reserved_identifiers:(reserved_variables + @ keywords + @ local_module_names) ~reserved_prefixes:["atd_"; "_atd_"] ~safe_prefix:"x_" in @@ -164,6 +185,7 @@ let init_env () : env = fun id -> Atd.Unique_name.translate u id in { + imports; create_variable; translate_variable; translate_inst_variable; @@ -192,7 +214,7 @@ let single_esc s = let _double_esc s = escape_string_content Double s -let fixed_size_preamble atd_filename = +let make_preamble ~atd_filename ~atd_imports = sprintf {|"""Generated by atdpy from type definitions in %s. This implements classes for the types defined in '%s', providing @@ -209,6 +231,8 @@ from typing import Any, Callable, Dict, List, NoReturn, Optional, Tuple, Union import json +# ATD modules +%s ############################################################################ # Private functions ############################################################################ @@ -432,6 +456,7 @@ def _atd_write_nullable(write_elt: Callable[[Any], Any]) \ ############################################################################|} atd_filename atd_filename + atd_imports let not_implemented loc msg = A.error_at loc ("not implemented in atdpy: " ^ msg) @@ -469,26 +494,26 @@ let assoc_kind loc (e : type_expr) an : assoc_kind = | Tuple (loc, [(_, key, _); (_, value, _)], an2), Array, Dict -> Array_dict (key, value) | Tuple (loc, - [(_, Name (_, (_, "string", _), _), _); (_, value, _)], an2), + [(_, Name (_, (_, TN ["string"], _), _), _); (_, value, _)], an2), Object, Dict -> Object_dict value | Tuple (loc, - [(_, Name (_, (_, "string", _), _), _); (_, value, _)], an2), + [(_, Name (_, (_, TN ["string"], _), _), _); (_, value, _)], an2), Object, List -> Object_list value | _, Array, List -> Array_list | _, Object, _ -> error_at loc "not a (string * _) list" | _, Array, _ -> error_at loc "not a (_ * _) list" (* Map ATD built-in types to built-in mypy types *) -let py_type_name env (name : string) = +let py_type_name (env : env) loc (name : type_name) = match name with - | "unit" -> "None" - | "bool" -> "bool" - | "int" -> "int" - | "float" -> "float" - | "string" -> "str" - | "abstract" -> "Any" - | user_defined -> class_name env user_defined + | TN ["unit"] -> "None" + | TN ["bool"] -> "bool" + | TN ["int"] -> "int" + | TN ["float"] -> "float" + | TN ["string"] -> "str" + | TN ["abstract"] -> "Any" + | user_defined -> class_name env loc name let rec type_name_of_expr env (e : type_expr) : string = match e with @@ -517,12 +542,12 @@ let rec type_name_of_expr env (e : type_expr) : string = | Nullable (loc, e, an) -> sprintf "Optional[%s]" (type_name_of_expr env e) | Shared (loc, e, an) -> not_implemented loc "shared" | Wrap (loc, e, an) -> todo "wrap" - | Name (loc, (loc2, name, []), an) -> py_type_name env name + | Name (loc, (loc2, name, []), an) -> py_type_name env loc2 name | Name (loc, (_, name, _::_), _) -> assert false | Tvar (loc, _) -> not_implemented loc "type variables" let rec get_default_default - ?(mutable_ok = true) (e : type_expr) : string option = + ?(mutable_ok = true) env (e : type_expr) : string option = match e with | Sum _ | Record _ @@ -532,36 +557,38 @@ let rec get_default_default else None | Option _ | Nullable _ -> Some "None" - | Shared (loc, e, an) -> get_default_default ~mutable_ok e - | Wrap (loc, e, an) -> get_default_default ~mutable_ok e + | Shared (loc, e, an) -> get_default_default ~mutable_ok env e + | Wrap (loc, e, an) -> get_default_default ~mutable_ok env e | Name (loc, (loc2, name, []), an) -> (match name with - | "unit" -> Some "None" - | "bool" -> Some "False" - | "int" -> Some "0" - | "float" -> Some "0.0" - | "string" -> Some {|""|} - | "abstract" -> Some "None" - | _ -> None + | TN ["unit"] -> Some "None" + | TN ["bool"] -> Some "False" + | TN ["int"] -> Some "0" + | TN ["float"] -> Some "0.0" + | TN ["string"] -> Some {|""|} + | TN ["abstract"] -> Some "None" + | _ -> assert false ) - | Name _ -> None - | Tvar _ -> None + | Name _ -> assert false + | Tvar _ -> assert false let get_python_default - ?mutable_ok (e : type_expr) (an : annot) : string option = + ?mutable_ok + env (e : type_expr) (an : annot) : string option = let user_default = Python_annot.get_python_default an in match user_default with | Some s -> Some s - | None -> get_default_default ?mutable_ok e + | None -> get_default_default ?mutable_ok env e (* see explanation where this function is used *) let has_no_class_inst_prop_default + env ((loc, (name, kind, an), e) : simple_field) = match kind with | Required -> true | Optional -> (* default is None *) false | With_default -> - match get_python_default ~mutable_ok:false e an with + match get_python_default env ~mutable_ok:false e an with | Some _ -> false | None -> (* There's either no default at all which is an error, @@ -577,10 +604,11 @@ let unwrap_field_type loc field_name kind e = | Optional -> match e with | Option (loc, e, an) -> e - | _ -> + | e -> A.error_at loc (sprintf "the type of optional field '%s' should be of \ - the form 'xxx option'" field_name) + the form 'xxx option'" + field_name) (* Instance variable that's really the name of the getter method created @@ -616,8 +644,9 @@ let rec json_writer env e = | Wrap (loc, e, an) -> json_writer env e | Name (loc, (loc2, name, []), an) -> (match name with - | "bool" | "int" | "float" | "string" -> sprintf "_atd_write_%s" name - | "abstract" -> "(lambda x: x)" + | TN ["bool" | "int" | "float" | "string" as str] -> + sprintf "_atd_write_%s" str + | TN ["abstract"] -> "(lambda x: x)" | _ -> "(lambda x: x.to_json())") | Name (loc, _, _) -> not_implemented loc "parametrized types" | Tvar (loc, _) -> not_implemented loc "type variables" @@ -697,9 +726,10 @@ let rec json_reader env (e : type_expr) = | Wrap (loc, e, an) -> json_reader env e | Name (loc, (loc2, name, []), an) -> (match name with - | "bool" | "int" | "float" | "string" -> sprintf "_atd_read_%s" name - | "abstract" -> "(lambda x: x)" - | _ -> sprintf "%s.from_json" (class_name env name)) + | TN ["bool" | "int" | "float" | "string" as str] -> + sprintf "_atd_read_%s" str + | TN ["abstract"] -> "(lambda x: x)" + | _ -> sprintf "%s.from_json" (class_name env loc2 name)) | Name (loc, _, _) -> not_implemented loc "parametrized types" | Tvar (loc, _) -> not_implemented loc "type variables" @@ -746,7 +776,7 @@ let from_json_class_argument (single_esc json_name) | Optional -> "None" | With_default -> - match get_python_default e an with + match get_python_default env e an with | Some x -> x | None -> A.error_at loc @@ -770,7 +800,7 @@ let inst_var_declaration | Required -> "" | Optional -> " = None" | With_default -> - match get_python_default ~mutable_ok:false unwrapped_e an with + match get_python_default ~mutable_ok:false env unwrapped_e an with | None -> "" | Some value -> sprintf " = %s" value in @@ -778,13 +808,15 @@ let inst_var_declaration Line (sprintf "%s: %s%s" var_name type_name default) ] -let record env ~class_decorators loc name (fields : field list) an = - let py_class_name = class_name env name in +let record + env ~class_decorators loc (name : type_name) (fields : field list) an = + let py_class_name = class_name env loc name in let trans_meth = env.translate_inst_variable () in let fields = - List.map (function - | `Field x -> x - | `Inherit _ -> (* expanded at loading time *) assert false) + List.map (fun (x : field) -> + match x with + | Field x -> x + | Inherit _ -> (* expanded at loading time *) assert false) fields in (* @@ -796,18 +828,20 @@ let record env ~class_decorators loc name (fields : field list) an = *) let fields = let no_default, with_default = - List.partition has_no_class_inst_prop_default fields in + List.partition (has_no_class_inst_prop_default env) fields in no_default @ with_default in let inst_var_declarations = - List.map (fun x -> Inline (inst_var_declaration env trans_meth x)) fields + List.map (fun x -> + Inline (inst_var_declaration env trans_meth x)) fields in let json_object_body = List.map (fun x -> Inline (construct_json_field env trans_meth x)) fields in let from_json_class_arguments = List.map (fun x -> - Line (from_json_class_argument env trans_meth py_class_name x) + Line (from_json_class_argument + env trans_meth py_class_name x) ) fields in let from_json = [ @@ -861,7 +895,7 @@ let record env ~class_decorators loc name (fields : field list) an = Inline class_decorators; Line (sprintf "class %s:" py_class_name); Block (spaced [ - Line (sprintf {|"""Original type: %s = { ... }"""|} name); + Line (sprintf {|"""Original type: %s = { ... }"""|} (Atd.Print.tn name)); Inline inst_var_declarations; Inline from_json; Inline to_json; @@ -886,14 +920,14 @@ class Foo: def from_json_string(x): ... *) -let alias_wrapper env ~class_decorators name type_expr = - let py_class_name = class_name env name in +let alias_wrapper env ~class_decorators loc name type_expr = + let py_class_name = class_name env loc name in let value_type = type_name_of_expr env type_expr in [ Inline class_decorators; Line (sprintf "class %s:" py_class_name); Block [ - Line (sprintf {|"""Original type: %s"""|} name); + Line (sprintf {|"""Original type: %s"""|} (Atd.Print.tn name)); Line ""; Line (sprintf "value: %s" value_type); Line ""; @@ -923,7 +957,7 @@ let alias_wrapper env ~class_decorators name type_expr = ] ] -let case_class env ~class_decorators type_name +let case_class env ~class_decorators (type_name : type_name) (loc, orig_name, unique_name, an, opt_e) = let json_name = Atd.Json.get_json_cons orig_name an in match opt_e with @@ -933,7 +967,7 @@ let case_class env ~class_decorators type_name Line (sprintf "class %s:" (trans env unique_name)); Block [ Line (sprintf {|"""Original type: %s = [ ... | %s | ... ]"""|} - type_name + (Atd.Print.tn type_name) orig_name); Line ""; Line "@property"; @@ -961,7 +995,7 @@ let case_class env ~class_decorators type_name Line (sprintf "class %s:" (trans env unique_name)); Block [ Line (sprintf {|"""Original type: %s = [ ... | %s of ... | ... ]"""|} - type_name + (Atd.Print.tn type_name) orig_name); Line ""; Line (sprintf "value: %s" (type_name_of_expr env e)); @@ -1003,7 +1037,7 @@ let read_cases0 env loc name cases0 = [ Inline ifs; Line (sprintf "_atd_bad_json('%s', x)" - (class_name env name |> single_esc)) + (class_name env loc name |> single_esc)) ] let read_cases1 env loc name cases1 = @@ -1029,11 +1063,11 @@ let read_cases1 env loc name cases1 = [ Inline ifs; Line (sprintf "_atd_bad_json('%s', x)" - (class_name env name |> single_esc)) + (class_name env loc name |> single_esc)) ] -let sum_container env ~class_decorators loc name cases = - let py_class_name = class_name env name in +let sum_container env ~class_decorators loc (name : type_name) cases = + let py_class_name = class_name env loc name in let type_list = List.map (fun (loc, orig_name, unique_name, an, opt_e) -> trans env unique_name @@ -1070,7 +1104,7 @@ let sum_container env ~class_decorators loc name cases = Inline class_decorators; Line (sprintf "class %s:" py_class_name); Block [ - Line (sprintf {|"""Original type: %s = [ ... ]"""|} name); + Line (sprintf {|"""Original type: %s = [ ... ]"""|} (Atd.Print.tn name)); Line ""; Line (sprintf "value: Union[%s]" type_list); Line ""; @@ -1088,7 +1122,7 @@ let sum_container env ~class_decorators loc name cases = Inline cases0_block; Inline cases1_block; Line (sprintf "_atd_bad_json('%s', x)" - (single_esc (class_name env name))) + (single_esc (class_name env loc name))) ]; Line ""; Line "def to_json(self) -> Any:"; @@ -1110,7 +1144,7 @@ let sum_container env ~class_decorators loc name cases = ] ] -let sum env ~class_decorators loc name cases = +let sum env ~class_decorators loc (name : type_name) cases = let cases = List.map (fun (x : variant) -> match x with @@ -1144,11 +1178,13 @@ let get_class_decorators an = else decorators @ ["dataclass"] -let type_def env ((loc, (name, param, an), e) : A.type_def) : B.t = - if param <> [] then +let type_def env (x : A.type_def) : B.t = + let loc = x.loc in + let name = x.name in + if x.param <> [] then not_implemented loc "parametrized type"; let class_decorators = - get_class_decorators an + get_class_decorators x.annot |> List.map (fun s -> Line ("@" ^ s)) in let rec unwrap e = @@ -1156,29 +1192,25 @@ let type_def env ((loc, (name, param, an), e) : A.type_def) : B.t = | Sum (loc, cases, an) -> sum env ~class_decorators loc name cases | Record (loc, fields, an) -> - record env ~class_decorators loc name fields an + record env ~class_decorators loc name fields an | Tuple _ | List _ | Option _ | Nullable _ - | Name _ -> alias_wrapper env ~class_decorators name e + | Name _ -> alias_wrapper env ~class_decorators loc name e | Shared _ -> not_implemented loc "cyclic references" | Wrap (loc, e, an) -> unwrap e | Tvar _ -> not_implemented loc "parametrized type" in - unwrap e + unwrap x.value -let module_body env x = - List.fold_left (fun acc (Type x) -> Inline (type_def env x) :: acc) [] x +let definition_group ~atd_filename env + (_is_recursive, (defs: A.type_def list)) : B.t = + List.fold_left (fun acc x -> + Inline (type_def env x) :: acc) [] defs |> List.rev |> spaced -let definition_group ~atd_filename env - (is_recursive, (items: A.module_body)) : B.t = - [ - Inline (module_body env items); - ] - (* Make sure that the types as defined in the atd file get a good name. For example, type 'foo' should become class 'Foo'. @@ -1188,20 +1220,43 @@ let definition_group ~atd_filename env We want to ensure that the type 'foo' gets the name 'Foo' and that only later the case 'Foo' gets a lesser name like 'Foo_' or 'Foo2'. *) -let reserve_good_class_names env (items: A.module_body) = +let reserve_good_class_names env (defs: type_def list) = List.iter - (fun (Type (loc, (name, param, an), e)) -> ignore (class_name env name)) - items + (fun (x : type_def) -> ignore (class_name env x.loc x.name)) + defs + +(* TODO: support ATD annotations that specify alternate module paths or names + for Python modules. *) +let format_import env (x : import) = + let path = + List.map (trans env) x.path + |> String.concat "." + in + let as_ = + match x.alias with + | None -> "" + | Some alias -> sprintf " as %s" alias + in + sprintf "import %s%s" path as_ + +let format_imports env imports = + List.map (fun x -> format_import env x ^ "\n") imports + |> String.concat "" -let to_file ~atd_filename ~head (items : A.module_body) dst_path = - let env = init_env () in - reserve_good_class_names env items; +let to_file ~atd_filename ~head ~imports (defs : A.type_def list) dst_path = + let env = init_env imports defs in + reserve_good_class_names env defs; let head = List.map (fun s -> Line s) head in + let atd_imports = format_imports env imports in let python_defs = - Atd.Util.tsort items + Atd.Util.tsort defs |> List.map (fun x -> Inline (definition_group ~atd_filename env x)) in - Line (fixed_size_preamble atd_filename) :: Inline head :: python_defs + let preamble = make_preamble ~atd_filename ~atd_imports in + [ + Line preamble; + Inline head; + ] @ python_defs |> double_spaced |> Indent.to_file ~indent:4 dst_path @@ -1215,7 +1270,7 @@ let run_file src_path = |> String.lowercase_ascii in let dst_path = dst_name in - let full_module, _original_types = + let module_ = Atd.Util.load_file ~annot_schema ~expand:true (* monomorphization = eliminate parametrized type defs *) @@ -1224,7 +1279,7 @@ let run_file src_path = ~inherit_variants:true src_path in - let full_module = Atd.Ast.use_only_specific_variants full_module in - let (atd_head, atd_module) = full_module in - let head = Python_annot.get_python_json_text (snd atd_head) in - to_file ~atd_filename:src_name ~head atd_module dst_path + let module_ = Atd.Ast.use_only_specific_variants module_ in + let head = Python_annot.get_python_json_text (snd module_.module_head) in + to_file ~atd_filename:src_name ~head ~imports:module_.imports + module_.type_defs dst_path diff --git a/atdpy/test/atd-input/everything.atd b/atdpy/test/atd-input/everything.atd index 3bb99ea9..51e4acad 100644 --- a/atdpy/test/atd-input/everything.atd +++ b/atdpy/test/atd-input/everything.atd @@ -2,6 +2,11 @@ +import external_defs as ext + +(* A list of objects whose type is defined in another ATD module. *) +type uses_external_type = ext.a list + type kind = [ | Root (* class name conflict *) | Thing of int diff --git a/atdpy/test/atd-input/external_defs.atd b/atdpy/test/atd-input/external_defs.atd new file mode 100644 index 00000000..5b4bb995 --- /dev/null +++ b/atdpy/test/atd-input/external_defs.atd @@ -0,0 +1,5 @@ +(* + This ATD module is referenced from 'everything.atd'. +*) + +type a = (int * int) diff --git a/atdpy/test/dune b/atdpy/test/dune index c9c13926..8a31af96 100644 --- a/atdpy/test/dune +++ b/atdpy/test/dune @@ -8,8 +8,14 @@ (alias runtest) (package atdpy) (action - (diff python-expected/everything.py - python-tests/everything.py))) + (progn + (diff python-expected/external_defs.py + python-tests/external_defs.py) + (diff python-expected/everything.py + python-tests/everything.py) + ) + ) +) ; 2. Run the generated Python code and check that is reads or writes JSON ; data as expected. diff --git a/atdpy/test/python-expected/everything.py b/atdpy/test/python-expected/everything.py index 15e4b83b..e9b499e6 100644 --- a/atdpy/test/python-expected/everything.py +++ b/atdpy/test/python-expected/everything.py @@ -14,6 +14,9 @@ import json +# ATD modules +import external_defs as ext + ############################################################################ # Private functions ############################################################################ @@ -276,6 +279,27 @@ def to_json_string(self, **kw: Any) -> str: return json.dumps(self.to_json(), **kw) +@dataclass +class UsesExternalType: + """Original type: uses_external_type""" + + value: List[ext.A] + + @classmethod + def from_json(cls, x: Any) -> 'UsesExternalType': + return cls(_atd_read_list(ext.A.from_json)(x)) + + def to_json(self) -> Any: + return _atd_write_list((lambda x: x.to_json()))(self.value) + + @classmethod + def from_json_string(cls, x: str) -> 'UsesExternalType': + return cls.from_json(json.loads(x)) + + def to_json_string(self, **kw: Any) -> str: + return json.dumps(self.to_json(), **kw) + + @dataclass class Root_: """Original type: kind = [ ... | Root | ... ]""" diff --git a/atdpy/test/python-expected/external_defs.py b/atdpy/test/python-expected/external_defs.py new file mode 100644 index 00000000..6964b0d5 --- /dev/null +++ b/atdpy/test/python-expected/external_defs.py @@ -0,0 +1,260 @@ +"""Generated by atdpy from type definitions in external_defs.atd. + +This implements classes for the types defined in 'external_defs.atd', providing +methods and functions to convert data from/to JSON. +""" + +# Disable flake8 entirely on this file: +# flake8: noqa + +# Import annotations to allow forward references +from __future__ import annotations +from dataclasses import dataclass +from typing import Any, Callable, Dict, List, NoReturn, Optional, Tuple, Union + +import json + +# ATD modules + +############################################################################ +# Private functions +############################################################################ + + +def _atd_missing_json_field(type_name: str, json_field_name: str) -> NoReturn: + raise ValueError(f"missing field '{json_field_name}'" + f" in JSON object of type '{type_name}'") + + +def _atd_bad_json(expected_type: str, json_value: Any) -> NoReturn: + value_str = str(json_value) + if len(value_str) > 200: + value_str = value_str[:200] + '…' + + raise ValueError(f"incompatible JSON value where" + f" type '{expected_type}' was expected: '{value_str}'") + + +def _atd_bad_python(expected_type: str, json_value: Any) -> NoReturn: + value_str = str(json_value) + if len(value_str) > 200: + value_str = value_str[:200] + '…' + + raise ValueError(f"incompatible Python value where" + f" type '{expected_type}' was expected: '{value_str}'") + + +def _atd_read_unit(x: Any) -> None: + if x is None: + return x + else: + _atd_bad_json('unit', x) + + +def _atd_read_bool(x: Any) -> bool: + if isinstance(x, bool): + return x + else: + _atd_bad_json('bool', x) + + +def _atd_read_int(x: Any) -> int: + if isinstance(x, int): + return x + else: + _atd_bad_json('int', x) + + +def _atd_read_float(x: Any) -> float: + if isinstance(x, (int, float)): + return x + else: + _atd_bad_json('float', x) + + +def _atd_read_string(x: Any) -> str: + if isinstance(x, str): + return x + else: + _atd_bad_json('str', x) + + +def _atd_read_list( + read_elt: Callable[[Any], Any] + ) -> Callable[[List[Any]], List[Any]]: + def read_list(elts: List[Any]) -> List[Any]: + if isinstance(elts, list): + return [read_elt(elt) for elt in elts] + else: + _atd_bad_json('array', elts) + return read_list + + +def _atd_read_assoc_array_into_dict( + read_key: Callable[[Any], Any], + read_value: Callable[[Any], Any], + ) -> Callable[[List[Any]], Dict[Any, Any]]: + def read_assoc(elts: List[List[Any]]) -> Dict[str, Any]: + if isinstance(elts, list): + return {read_key(elt[0]): read_value(elt[1]) for elt in elts} + else: + _atd_bad_json('array', elts) + raise AssertionError('impossible') # keep mypy happy + return read_assoc + + +def _atd_read_assoc_object_into_dict( + read_value: Callable[[Any], Any] + ) -> Callable[[Dict[str, Any]], Dict[str, Any]]: + def read_assoc(elts: Dict[str, Any]) -> Dict[str, Any]: + if isinstance(elts, dict): + return {_atd_read_string(k): read_value(v) + for k, v in elts.items()} + else: + _atd_bad_json('object', elts) + raise AssertionError('impossible') # keep mypy happy + return read_assoc + + +def _atd_read_assoc_object_into_list( + read_value: Callable[[Any], Any] + ) -> Callable[[Dict[str, Any]], List[Tuple[str, Any]]]: + def read_assoc(elts: Dict[str, Any]) -> List[Tuple[str, Any]]: + if isinstance(elts, dict): + return [(_atd_read_string(k), read_value(v)) + for k, v in elts.items()] + else: + _atd_bad_json('object', elts) + raise AssertionError('impossible') # keep mypy happy + return read_assoc + + +def _atd_read_nullable(read_elt: Callable[[Any], Any]) \ + -> Callable[[Optional[Any]], Optional[Any]]: + def read_nullable(x: Any) -> Any: + if x is None: + return None + else: + return read_elt(x) + return read_nullable + + +def _atd_write_unit(x: Any) -> None: + if x is None: + return x + else: + _atd_bad_python('unit', x) + + +def _atd_write_bool(x: Any) -> bool: + if isinstance(x, bool): + return x + else: + _atd_bad_python('bool', x) + + +def _atd_write_int(x: Any) -> int: + if isinstance(x, int): + return x + else: + _atd_bad_python('int', x) + + +def _atd_write_float(x: Any) -> float: + if isinstance(x, (int, float)): + return x + else: + _atd_bad_python('float', x) + + +def _atd_write_string(x: Any) -> str: + if isinstance(x, str): + return x + else: + _atd_bad_python('str', x) + + +def _atd_write_list( + write_elt: Callable[[Any], Any] + ) -> Callable[[List[Any]], List[Any]]: + def write_list(elts: List[Any]) -> List[Any]: + if isinstance(elts, list): + return [write_elt(elt) for elt in elts] + else: + _atd_bad_python('list', elts) + return write_list + + +def _atd_write_assoc_dict_to_array( + write_key: Callable[[Any], Any], + write_value: Callable[[Any], Any] + ) -> Callable[[Dict[Any, Any]], List[Tuple[Any, Any]]]: + def write_assoc(elts: Dict[str, Any]) -> List[Tuple[str, Any]]: + if isinstance(elts, dict): + return [(write_key(k), write_value(v)) for k, v in elts.items()] + else: + _atd_bad_python('Dict[str, ]]', elts) + raise AssertionError('impossible') # keep mypy happy + return write_assoc + + +def _atd_write_assoc_dict_to_object( + write_value: Callable[[Any], Any] + ) -> Callable[[Dict[str, Any]], Dict[str, Any]]: + def write_assoc(elts: Dict[str, Any]) -> Dict[str, Any]: + if isinstance(elts, dict): + return {_atd_write_string(k): write_value(v) + for k, v in elts.items()} + else: + _atd_bad_python('Dict[str, ]', elts) + raise AssertionError('impossible') # keep mypy happy + return write_assoc + + +def _atd_write_assoc_list_to_object( + write_value: Callable[[Any], Any], + ) -> Callable[[List[Any]], Dict[str, Any]]: + def write_assoc(elts: List[List[Any]]) -> Dict[str, Any]: + if isinstance(elts, list): + return {_atd_write_string(elt[0]): write_value(elt[1]) + for elt in elts} + else: + _atd_bad_python('List[Tuple[, ]]', elts) + raise AssertionError('impossible') # keep mypy happy + return write_assoc + + +def _atd_write_nullable(write_elt: Callable[[Any], Any]) \ + -> Callable[[Optional[Any]], Optional[Any]]: + def write_nullable(x: Any) -> Any: + if x is None: + return None + else: + return write_elt(x) + return write_nullable + + +############################################################################ +# Public classes +############################################################################ + + +@dataclass +class A: + """Original type: a""" + + value: Tuple[int, int] + + @classmethod + def from_json(cls, x: Any) -> 'A': + return cls((lambda x: (_atd_read_int(x[0]), _atd_read_int(x[1])) if isinstance(x, list) and len(x) == 2 else _atd_bad_json('array of length 2', x))(x)) + + def to_json(self) -> Any: + return (lambda x: [_atd_write_int(x[0]), _atd_write_int(x[1])] if isinstance(x, tuple) and len(x) == 2 else _atd_bad_python('tuple of length 2', x))(self.value) + + @classmethod + def from_json_string(cls, x: str) -> 'A': + return cls.from_json(json.loads(x)) + + def to_json_string(self, **kw: Any) -> str: + return json.dumps(self.to_json(), **kw) diff --git a/atdpy/test/python-tests/dune b/atdpy/test/python-tests/dune index 3814e0fa..015d1162 100644 --- a/atdpy/test/python-tests/dune +++ b/atdpy/test/python-tests/dune @@ -4,10 +4,12 @@ (rule (targets allcaps.py + external_defs.py everything.py ) (deps ../atd-input/ALLCAPS.atd + ../atd-input/external_defs.atd ../atd-input/everything.atd ) (action diff --git a/atds/src/atds_env.ml b/atds/src/atds_env.ml index 1d7fdb3c..9b36bd4e 100644 --- a/atds/src/atds_env.ml +++ b/atds/src/atds_env.ml @@ -4,14 +4,14 @@ type id = string type ty_name = string type env_t = { - module_items : (string * Atd.Ast.type_expr) list; + type_defs : (Atd.Ast.type_name * Atd.Ast.type_expr) list; package : string; input_file : string option; output : out_channel; } let default_env = { - module_items = []; + type_defs = []; package = "out"; input_file = None; output = stdout; diff --git a/atds/src/atds_helper.ml b/atds/src/atds_helper.ml index 3feac9d7..ccf0d24a 100644 --- a/atds/src/atds_helper.ml +++ b/atds/src/atds_helper.ml @@ -1,6 +1,6 @@ (* Helper classes *) -open Atd.Import +open Atd.Stdlib_extra open Atds_env (* TODO: Extract to to a plain file? *) diff --git a/atds/src/atds_main.ml b/atds/src/atds_main.ml index 3fdfc867..22d6b222 100644 --- a/atds/src/atds_main.ml +++ b/atds/src/atds_main.ml @@ -1,6 +1,6 @@ (* Main *) -open Atd.Import +open Atd.Stdlib_extra open Atds_env let args_spec env = Arg.align @@ -47,16 +47,16 @@ let main () = ); (* Parse ATD file *) - let (atd_head, atd_module), _original_types = + let module_ = Atd.Util.load_file ~expand:false ~inherit_fields:true ~inherit_variants:true input_file in let env = { env with - module_items = + type_defs = List.map - (function (Atd.Ast.Type (_, (name, _, _), atd_ty)) -> (name, atd_ty)) - atd_module + (fun (x : Atd.Ast.type_def) -> (x.name, x.value)) + module_.type_defs } in let close_package = Atds_trans.open_package env in @@ -65,7 +65,7 @@ let main () = Atds_helper.output_atds env; (* Generate classes from ATD definition *) - let _ = Atds_trans.trans_module env atd_module in + let _ = Atds_trans.trans_module env module_ in close_package() diff --git a/atds/src/atds_names.ml b/atds/src/atds_names.ml index 00f55c16..f9122884 100644 --- a/atds/src/atds_names.ml +++ b/atds/src/atds_names.ml @@ -1,4 +1,4 @@ -open Atd.Import +open Atd.Stdlib_extra (* Names *) let to_camel_case (s : string) = @@ -27,13 +27,14 @@ let to_camel_case (s : string) = * underscores and capitalise any character that is immediately following * an underscore or digit. We also capitalise the initial character * e.g. "foo_bar42baz" becomes "FooBar42Baz". *) -let to_class_name str = - match str with - | "string" -> "String" - | "int" -> "Int" - | "bool" -> "Boolean" - | "float" -> "Double" - | _ -> to_camel_case str +let to_class_name (name : Atd.Ast.type_name) = + match name with + | TN ["string"] -> "String" + | TN ["int"] -> "Int" + | TN ["bool"] -> "Boolean" + | TN ["float"] -> "Double" + | TN [str] -> to_camel_case str + | TN _ -> failwith ("Imports aren't supported: " ^ Atd.Print.tn name) (* Per https://scala-lang.org/files/archive/spec/2.12/01-lexical-syntax.html *) let scala_keywords = [ @@ -110,24 +111,31 @@ let get_scala_field_name field_name annot = ~field:"name" annot -let get_scala_variant_name field_name annot = - let lower_field_name = String.lowercase_ascii field_name in - let field_name = +let get_lowercase_name name annot = + let lower_field_name = String.lowercase_ascii name in + let name = if is_scala_keyword lower_field_name then - field_name ^ "_" + name ^ "_" else - field_name + name in - let field_name = + let name = Atd.Annot.get_field ~parse:(fun s -> Some s) - ~default:field_name + ~default:name ~sections:["scala"] ~field:"name" annot in - to_camel_case field_name + to_camel_case name + +let get_scala_variant_name name annot = + get_lowercase_name name annot +let get_scala_type_name (name : Atd.Ast.type_name) annot = + match name with + | TN [str] -> get_lowercase_name str annot + | TN _ -> failwith ("Imports are not supported: " ^ Atd.Print.tn name) let get_json_field_name field_name annot = Atd.Annot.get_field diff --git a/atds/src/atds_trans.ml b/atds/src/atds_trans.ml index 5b757cfb..23e9a6a3 100644 --- a/atds/src/atds_trans.ml +++ b/atds/src/atds_trans.ml @@ -1,4 +1,4 @@ -open Atd.Import +open Atd.Stdlib_extra open Atds_names open Atds_env open Atds_util @@ -40,10 +40,10 @@ let declare_field env (match norm_ty env atd_ty with | Name (_, (_, name, _), _) -> (match name with - | "bool" -> Some "false" - | "int" -> Some "0" - | "float" -> Some "0.0" - | "string" -> Some "\"\"" + | TN ["bool"] -> Some "false" + | TN ["int"] -> Some "0" + | TN ["float"] -> Some "0.0" + | TN ["string"] -> Some "\"\"" | _ -> None (* TODO: fail if no default is provided *) ) | List _ -> @@ -132,16 +132,19 @@ package object %s { suf; fun () -> output_string out "\n}\n" -let rec trans_module env items = List.fold_left trans_outer env items +let rec trans_module env (module_ : A.module_) = + List.fold_left (fun env x -> trans_type_def env x) env module_.type_defs -and trans_outer env (A.Type (_, (name, _, annots), atd_ty)) = +and trans_type_def env (x : A.type_def) = + let name = x.name in + let atd_ty = x.value in match unwrap atd_ty with | Sum (loc, v, a) -> trans_sum name env (loc, v, a) | Record (loc, v, a) -> trans_record name env (loc, v, a) | Name _ | Tuple _ | List _ -> - trans_alias name env annots atd_ty + trans_alias name env x.annot atd_ty | x -> type_not_supported x (* Translation of sum types. For a sum type @@ -178,7 +181,7 @@ and trans_sum my_name env (_, vars, _) = */ sealed abstract class %s extends Atds " - my_name + (Atd.Print.tn my_name) class_name; fprintf out " @@ -186,7 +189,7 @@ sealed abstract class %s extends Atds * Define tags for sum type %s. */ object %s {" - my_name + (Atd.Print.tn my_name) class_name; List.iter (fun (json_name, scala_name, opt_ty) -> @@ -223,9 +226,10 @@ object %s {" and trans_record my_name env (loc, fields, annots) = (* Remove `Inherit values *) let fields = List.map - (function - | `Field _ as f -> f - | `Inherit _ -> assert false + (fun (x : A.field) -> + match x with + | Field f -> `Field f + | Inherit _ -> assert false ) fields in (* Translate field types *) @@ -271,7 +275,7 @@ and trans_record my_name env (loc, fields, annots) = env and trans_alias name env annots ty = - let scala_name = Atds_names.get_scala_variant_name name annots in + let scala_name = Atds_names.get_scala_type_name name annots in fprintf env.output "\ntype %s = %s\n" scala_name (trans_inner env ty); env diff --git a/atds/src/atds_util.ml b/atds/src/atds_util.ml index df5039de..198339d7 100644 --- a/atds/src/atds_util.ml +++ b/atds/src/atds_util.ml @@ -1,6 +1,6 @@ (* Utilities *) -open Atd.Import +open Atd.Stdlib_extra open Atds_env (* Get rid of `wrap' constructors that we don't support on the Java side yet. @@ -16,12 +16,12 @@ let rec norm_ty env atd_ty = match atd_ty with | Atd.Ast.Name (_, (_, name, _), _) -> (match name with - | "bool" | "int" | "float" | "string" | "abstract" -> atd_ty + | TN ["bool" | "int" | "float" | "string" | "abstract"] -> atd_ty | _ -> - (match List.assoc name env.module_items with + (match List.assoc name env.type_defs with | Some x -> norm_ty env x | None -> - eprintf "Warning: unknown type %s\n%!" name; + eprintf "Warning: unknown type %s\n%!" (Atd.Print.tn name); atd_ty) ) | _ -> diff --git a/atdts/src/lib/Codegen.ml b/atdts/src/lib/Codegen.ml index 0d7411c2..ad9570bb 100644 --- a/atdts/src/lib/Codegen.ml +++ b/atdts/src/lib/Codegen.ml @@ -14,7 +14,7 @@ module B = Indent (* Mutable environment holding hash tables and such to avoid naming conflicts. *) type env = { - (* Global *) + imports: Atd.Imports.t; create_variable: string -> string; translate_variable: string -> string; } @@ -68,14 +68,21 @@ let trans env id = env.translate_variable id (* Use CamelCase as customary for type names. *) -let type_name env id = - trans env (to_camel_case id) +let type_name env loc (name : type_name) = + let import, base_name = Atd.Imports.resolve env.imports loc name in + match import with + | None -> trans env (to_camel_case base_name) + | Some import -> not_implemented loc "imports" -let writer_name _env name = - "write" ^ to_camel_case name +let writer_name _env loc name = + match name with + | TN [str] -> "write" ^ to_camel_case str + | _ -> not_implemented loc "imports" -let reader_name _env name = - "read" ^ to_camel_case name +let reader_name _env loc name = + match name with + | TN [str] -> "read" ^ to_camel_case str + | _ -> not_implemented loc "imports" (* Insert blank lines *) let spaced ?(spacer = [Line ""]) (blocks : B.node list) : B.node list = @@ -104,7 +111,8 @@ let rec unwrap e = | Nullable _ | Name _ -> e -let init_env () : env = +let init_env (imports : import list) : env = + let imports = Atd.Imports.load imports in (* The list of "keywords" is extracted from https://github.com/microsoft/TypeScript/issues/2536#issuecomment-87194347 In the current implementation, we don't use variables named by the @@ -155,6 +163,7 @@ let init_env () : env = Atd.Unique_name.translate variables id in { + imports; create_variable; translate_variable; } @@ -581,26 +590,26 @@ let assoc_kind loc (e : type_expr) an : assoc_kind = | Tuple (loc, [(_, key, _); (_, value, _)], an2), Array, Map -> Array_map (key, value) | Tuple (loc, - [(_, Name (_, (_, "string", _), _), _); (_, value, _)], an2), + [(_, Name (_, (_, TN ["string"], _), _), _); (_, value, _)], an2), Object, Map -> Object_map value | Tuple (loc, - [(_, Name (_, (_, "string", _), _), _); (_, value, _)], an2), + [(_, Name (_, (_, TN ["string"], _), _), _); (_, value, _)], an2), Object, Array -> Object_array value | _, Array, Array -> Array_array | _, Object, _ -> error_at loc "not a (string * _) list" | _, Array, _ -> error_at loc "not a (_ * _) list" (* Map ATD built-in types to built-in TypeScript types *) -let ts_type_name env (name : string) = +let ts_type_name env loc (name : type_name) = match name with - | "unit" -> "Null" - | "bool" -> "boolean" - | "int" -> "Int" - | "float" -> "number" - | "string" -> "string" - | "abstract" -> "any" - | user_defined -> type_name env user_defined + | TN ["unit"] -> "Null" + | TN ["bool"] -> "boolean" + | TN ["int"] -> "Int" + | TN ["float"] -> "number" + | TN ["string"] -> "string" + | TN ["abstract"] -> "any" + | user_defined -> type_name env loc user_defined let rec type_name_of_expr env (e : type_expr) : string = match e with @@ -624,7 +633,7 @@ let rec type_name_of_expr env (e : type_expr) : string = | Nullable (loc, e, an) -> sprintf "(%s | null)" (type_name_of_expr env e) | Shared (loc, e, an) -> not_implemented loc "shared" | Wrap (loc, e, an) -> todo "wrap" - | Name (loc, (loc2, name, []), an) -> ts_type_name env name + | Name (loc, (loc2, name, []), an) -> ts_type_name env loc2 name | Name (loc, _, _) -> assert false | Tvar (loc, _) -> not_implemented loc "type variables" @@ -647,12 +656,12 @@ let rec get_default_default (e : type_expr) : string option = | Wrap (loc, e, an) -> get_default_default e | Name (loc, (loc2, name, []), an) -> (match name with - | "unit" -> Some "null" - | "bool" -> Some "false" - | "int" -> Some "0" - | "float" -> Some "0.0" - | "string" -> Some {|""|} - | "abstract" -> Some "null" + | TN ["unit"] -> Some "null" + | TN ["bool"] -> Some "false" + | TN ["int"] -> Some "0" + | TN ["float"] -> Some "0.0" + | TN ["string"] -> Some {|""|} + | TN ["abstract"] -> Some "null" | _ -> None ) | Name _ -> None @@ -707,9 +716,11 @@ let rec json_reader env e = | Wrap (loc, e, an) -> json_reader env e | Name (loc, (loc2, name, []), an) -> (match name with - | "bool" | "int" | "float" | "string" -> sprintf "_atd_read_%s" name - | "abstract" -> "((x: any): any => x)" - | _ -> reader_name env name) + | TN ["bool" | "int" | "float" | "string" as str] -> + sprintf "_atd_read_%s" str + | TN ["abstract"] -> "((x: any): any => x)" + | TN [_] -> reader_name env loc2 name + | TN _ -> not_implemented loc2 "imports") | Name (loc, _, _) -> assert false | Tvar (loc, _) -> not_implemented loc "type variables" @@ -755,9 +766,11 @@ let rec json_writer env e = | Wrap (loc, e, an) -> json_writer env e | Name (loc, (loc2, name, []), an) -> (match name with - | "bool" | "int" | "float" | "string" -> sprintf "_atd_write_%s" name - | "abstract" -> "((x: any): any => x)" - | _ -> writer_name env name) + | TN ["bool" | "int" | "float" | "string" as str] -> + sprintf "_atd_write_%s" str + | TN ["abstract"] -> "((x: any): any => x)" + | TN [_] -> writer_name env loc2 name + | TN _ -> not_implemented loc2 "imports") | Name (loc, _, _) -> not_implemented loc "parametrized types" | Tvar (loc, _) -> not_implemented loc "type variables" @@ -788,12 +801,13 @@ let field_def env ((loc, (name, kind, an), e) : simple_field) = Line (sprintf "%s%s: %s;" field_name optional type_name) ] -let record_type env loc name (fields : field list) an = - let ts_type_name = type_name env name in +let record_type env loc (name : type_name) (fields : field list) an = + let ts_type_name = type_name env loc name in let fields = - List.map (function - | `Field x -> x - | `Inherit _ -> (* expanded at loading time *) assert false) + List.map (fun (x : field) -> + match x with + | Field x -> x + | Inherit _ -> (* expanded at loading time *) assert false) fields in let field_defs = @@ -805,8 +819,8 @@ let record_type env loc name (fields : field list) an = Line "}"; ] -let alias_type env name type_expr = - let ts_type_name = type_name env name in +let alias_type env loc (name : type_name) type_expr = + let ts_type_name = type_name env loc name in let value_type = type_name_of_expr env type_expr in [ Line (sprintf "export type %s = %s" ts_type_name value_type) @@ -850,14 +864,15 @@ let sum_type env loc name cases = List.map (fun x -> Inline (case_type env name x)) cases in [ - Line (sprintf "export type %s =" (type_name env name)); + Line (sprintf "export type %s =" (type_name env loc name)); Inline case_types; ] -let make_type_def env ((loc, (name, param, an), e) : A.type_def) : B.t = - if param <> [] then - not_implemented loc "parametrized type"; - match unwrap e with +let make_type_def env (x : A.type_def) : B.t = + if x.param <> [] then + not_implemented x.loc "parametrized type"; + let name = x.name in + match unwrap x.value with | Sum (loc, variants, an) -> sum_type env loc name (flatten_variants variants) | Record (loc, fields, an) -> @@ -866,7 +881,7 @@ let make_type_def env ((loc, (name, param, an), e) : A.type_def) : B.t = | List _ | Option _ | Nullable _ - | Name _ -> alias_type env name e + | Name _ -> alias_type env x.loc name x.value | Shared (loc, e, an) -> assert false | Wrap (loc, e, an) -> assert false | Tvar _ -> assert false @@ -979,9 +994,10 @@ let read_root_expr env ~ts_type_name e = | Record (loc, fields, an) -> let read_fields = - List.map (function - | `Inherit _ -> assert false - | `Field ((loc, (name, kind, an), e) : simple_field) -> + List.map (fun (x : field) -> + match x with + | Inherit _ -> assert false + | Field ((loc, (name, kind, an), e) : simple_field) -> let ts_name = trans env name in let json_name_lit = Atd.Json.get_json_fname name an |> single_esc @@ -1050,9 +1066,10 @@ let write_root_expr env ~ts_type_name e = ] | Record (loc, fields, an) -> let write_fields = - List.map (function - | `Inherit _ -> assert false - | `Field ((loc, (name, kind, an), e) : simple_field) -> + List.map (fun (x : field) -> + match x with + | Inherit _ -> assert false + | Field ((loc, (name, kind, an), e) : simple_field) -> let ts_name = trans env name in let json_name_lit = sprintf "'%s'" @@ -1110,8 +1127,8 @@ let write_root_expr env ~ts_type_name e = | Tvar _ -> assert false let make_reader env loc name an e = - let ts_type_name = type_name env name in - let ts_name = reader_name env name in + let ts_type_name = type_name env loc name in + let ts_name = reader_name env loc name in let read = read_root_expr env ~ts_type_name e in [ Line (sprintf "export function %s(x: any, context: any = x): %s {" @@ -1121,8 +1138,8 @@ let make_reader env loc name an e = ] let make_writer env loc name an e = - let ts_type_name = type_name env name in - let ts_name = writer_name env name in + let ts_type_name = type_name env loc name in + let ts_name = writer_name env loc name in let write = write_root_expr env ~ts_type_name e in [ Line (sprintf "export function %s(x: %s, context: any = x): any {" @@ -1131,11 +1148,11 @@ let make_writer env loc name an e = Line "}"; ] -let make_functions env ((loc, (name, param, an), e) : A.type_def) : B.t = - if param <> [] then - not_implemented loc "parametrized type"; - let writer = make_writer env loc name an e in - let reader = make_reader env loc name an e in +let make_functions env (x : A.type_def) : B.t = + if x.param <> [] then + assert false; + let writer = make_writer env x.loc x.name x.annot x.value in + let reader = make_reader env x.loc x.name x.annot x.value in [ Inline writer; Line ""; @@ -1151,22 +1168,21 @@ let make_functions env ((loc, (name, param, an), e) : A.type_def) : B.t = We want to ensure that the type 'foo' gets the name 'Foo' and that only later the case 'Foo' gets a lesser name like 'Foo_' or 'Foo2'. *) -let reserve_good_type_names env (items: A.module_body) = +let reserve_good_type_names env (defs: A.type_def list) = List.iter - (fun (Type (loc, (name, param, an), e)) -> ignore (type_name env name)) - items + (fun (x : type_def) -> ignore (type_name env x.loc x.name)) + defs -let to_file ~atd_filename (items : A.module_body) dst_path = - let env = init_env () in - let atd_defs = List.map (fun (Type x) -> x) items in - reserve_good_type_names env items; +let to_file ~atd_filename imports (defs : A.type_def list) dst_path = + let env = init_env imports in + reserve_good_type_names env defs; let type_defs = - List.map (fun x -> Inline (make_type_def env x)) atd_defs + List.map (fun x -> Inline (make_type_def env x)) defs in let functions = List.map (fun x -> Inline (make_functions env x) - ) atd_defs + ) defs in [ Line (runtime_start atd_filename); @@ -1187,7 +1203,7 @@ let run_file src_path = |> String.lowercase_ascii in let dst_path = dst_name in - let full_module, _original_types = + let module_ = Atd.Util.load_file ~annot_schema ~expand:true (* monomorphization *) @@ -1196,6 +1212,7 @@ let run_file src_path = ~inherit_variants:true src_path in - let full_module = Atd.Ast.use_only_specific_variants full_module in - let atd_head, atd_module = full_module in - to_file ~atd_filename:src_name atd_module dst_path + let module_ = Atd.Ast.use_only_specific_variants module_ in + if module_.imports <> [] then + failwith "not implemented: import"; + to_file ~atd_filename:src_name module_.imports module_.type_defs dst_path diff --git a/dune b/dune index 1a643634..eb5ce430 100644 --- a/dune +++ b/dune @@ -1,8 +1,8 @@ (env ;; disable warnings against "Innocuous unused variables" ;; enforce the separation between types `string` and `bytes` - (dev (flags :standard -w -27 -safe-string)) - (release (flags :standard -w -27 -safe-string))) + (dev (flags :standard -w -27-30 -safe-string)) + (release (flags :standard -w -27-30 -safe-string))) (rule (copy atd.opam.template atdgen-codec-runtime.opam.template)) (rule (copy atd.opam.template atdgen-runtime.opam.template))