diff --git a/INSTALL b/INSTALL index 9e42567e..a5990313 100644 --- a/INSTALL +++ b/INSTALL @@ -10,7 +10,7 @@ Requirements: - easy-format http://martin.jambon.free.fr/easy-format.html -GODI makes the installation process straightforward, +GODI makes the installation process straightforward, although other package managers can be equally convenient. diff --git a/Makefile b/Makefile index 1150b997..fde4da77 100644 --- a/Makefile +++ b/Makefile @@ -70,7 +70,7 @@ install: META uninstall: test ! -f $(BINDIR)/atdcat || rm $(BINDIR)/atdcat - test ! -f $(BINDIR)/atdcat.exe || rm $(BINDIR)/atdcat.exe + test ! -f $(BINDIR)/atdcat.exe || rm $(BINDIR)/atdcat.exe ocamlfind remove atd reinstall: diff --git a/atd_annot.ml b/atd_annot.ml index ef59c60c..149d04b7 100644 --- a/atd_annot.ml +++ b/atd_annot.ml @@ -38,11 +38,11 @@ let get_flag k k2 l = let loc, l2 = List.assoc k1 l in let loc, o = List.assoc k2 l2 in match o with - None -> Some true + None -> Some true | Some "true" -> Some true | Some "false" -> Some false | Some s -> - error_at loc + error_at loc (sprintf "Invalid value %S for flag %s.%s" s k1 k2) with Not_found -> None ) k @@ -60,15 +60,15 @@ let get_field parse default k k2 l = let loc, l2 = List.assoc k1 l in let loc, o = List.assoc k2 l2 in match o with - Some s -> - (match parse s with - Some x as y -> y - | None -> - error_at loc - (sprintf "Invalid annotation <%s %s=%S>" k1 k2 s) - ) + Some s -> + (match parse s with + Some x as y -> y + | None -> + error_at loc + (sprintf "Invalid annotation <%s %s=%S>" k1 k2 s) + ) | None -> - error_at loc + error_at loc (sprintf "Missing value for annotation %s.%s" k1 k2) with Not_found -> None @@ -126,7 +126,7 @@ let override_values x1 x2 = x1 let override_fields (loc1, l1) (loc2, l2) = (loc1, collapse override_values (l1 @ l2)) - + let merge l = collapse override_fields l diff --git a/atd_annot.mli b/atd_annot.mli index b453e8ed..853b69df 100644 --- a/atd_annot.mli +++ b/atd_annot.mli @@ -102,7 +102,7 @@ val set_field : Atd_ast.loc -> string -> string -> string option -> t -> t val merge : t -> t (** Merge sections of the same name together, - and keeps only the first occurrence of each + and keeps only the first occurrence of each field. {v diff --git a/atd_ast.ml b/atd_ast.ml index 6b3761fb..297d9364 100644 --- a/atd_ast.ml +++ b/atd_ast.ml @@ -26,7 +26,7 @@ and module_item = and type_param = string list -and type_expr = +and type_expr = [ `Sum of (loc * variant list * annot) | `Record of (loc * field list * annot) | `Tuple of (loc * cell list * annot) @@ -39,7 +39,7 @@ and type_expr = ] (* `List, `Option, `Nullable, and `Shared are the only predefined types with a type - parameter (and no special syntax). *) + parameter (and no special syntax). *) and type_inst = loc * string * type_expr list @@ -105,7 +105,7 @@ let annot_of_type_expr = function | `Name (_, _, an) -> an | `Tvar (_, _) -> [] - + let map_annot f = function `Sum (loc, vl, a) -> `Sum (loc, vl, f a) @@ -131,7 +131,7 @@ let rec amap_type_expr f (x : type_expr) = | `Tvar _ as x -> x | `Name (loc, (loc2, name, args), a) -> `Name (loc, (loc2, name, List.map (amap_type_expr f) args), f a) - + and amap_variant f = function `Variant (loc, (name, a), o) -> let o = @@ -167,39 +167,39 @@ let map_all_annot f ((head, body) : full_module) = let rec fold (f : type_expr -> 'a -> 'a) (x : type_expr) acc = let acc = f x acc in match x with - `Sum (loc, variant_list, annot) -> - List.fold_right (fold_variant f) variant_list acc - + `Sum (loc, variant_list, annot) -> + List.fold_right (fold_variant f) variant_list acc + | `Record (loc, field_list, annot) -> - List.fold_right (fold_field f) field_list acc - + List.fold_right (fold_field f) field_list acc + | `Tuple (loc, l, annot) -> - List.fold_right (fun (loc, x, _) acc -> fold f x acc) l acc - + List.fold_right (fun (loc, x, _) acc -> fold f x acc) l acc + | `List (loc, type_expr, annot) -> - fold f type_expr acc - + fold f type_expr acc + | `Option (loc, type_expr, annot) -> - fold f type_expr acc - + fold f type_expr acc + | `Nullable (loc, type_expr, annot) -> - fold f type_expr acc - + fold f type_expr acc + | `Shared (loc, type_expr, annot) -> fold f type_expr acc | `Name (loc, (loc2, name, type_expr_list), annot) -> - List.fold_right (fold f) type_expr_list acc - + List.fold_right (fold f) type_expr_list acc + | `Tvar (loc, string) -> - acc - + acc + and fold_variant f x acc = match x with `Variant (loc, _, Some type_expr) -> fold f type_expr acc | `Variant _ -> acc | `Inherit (loc, type_expr) -> fold f type_expr acc - + and fold_field f x acc = match x with `Field (loc, _, type_expr) -> fold f type_expr acc @@ -225,7 +225,7 @@ let extract_type_names ?(ignorable = []) x = match x with `Name (loc, (loc2, name, l), a) -> add name acc | _ -> acc - ) + ) x Type_names.empty in Type_names.elements acc diff --git a/atd_ast.mli b/atd_ast.mli index 5bcea5ad..cedb95fd 100644 --- a/atd_ast.mli +++ b/atd_ast.mli @@ -23,7 +23,7 @@ v} *) and annot_field = string * (loc * string option) - (** An annotation field, + (** An annotation field, i.e. a key with an optional value within an annotation. *) @@ -51,7 +51,7 @@ and type_def = loc * (string * type_param * annot) * type_expr and type_param = string list (** List of type variables without the tick. *) -and type_expr = +and type_expr = [ `Sum of (loc * variant list * annot) | `Record of (loc * field list * annot) | `Tuple of (loc * cell list * annot) @@ -69,7 +69,7 @@ and type_expr = - [`Tuple]: a tuple (within parentheses) - [`List]: a list type written [list] with its parameter e.g. [int list] - - [`Option]: an option type written [option] with its parameter + - [`Option]: an option type written [option] with its parameter e.g. [string option] - [`Nullable]: adds a null value to a type. [`Option] should be preferred over [`Nullable] since @@ -91,7 +91,7 @@ and variant = | `Inherit of (loc * type_expr) ] (** A single variant or an [inherit] statement. - [`Inherit] statements can be expanded into variants + [`Inherit] statements can be expanded into variants using {!Atd_inherit} or at loading time using the [inherit_variant] option offered by the {!Atd_util} functions. @@ -109,7 +109,7 @@ and field_kind = | `With_default ] (** - Different kinds of record fields based on the + Different kinds of record fields based on the - [`Required]: required field, e.g. [id : string] - [`Optional]: optional field without a default value, e.g. [?name : string option]. The ATD type of the field @@ -128,13 +128,13 @@ type user = \{ id : string; ?name : string option; - (* Field may be omitted when no value is set, if permitted + (* Field may be omitted when no value is set, if permitted by the target language. *) ~websites : string list; (* Implicit default: empty list. Field may be omitted if the field value is - equal to the default value and the + equal to the default value and the target language permits it. *) ~level : level; @@ -211,7 +211,7 @@ val extract_type_names : ?ignorable : string list -> type_expr -> string list (** - Extract all the type names occurring in a type expression + Extract all the type names occurring in a type expression under [`Name], without duplicates. @param ignorable specifies a list of type names to exclude from the result *) diff --git a/atd_check.ml b/atd_check.ml index 426d3ef7..003c6374 100644 --- a/atd_check.ml +++ b/atd_check.ml @@ -17,32 +17,32 @@ let get_kind = function let check_inheritance tbl (t0 : type_expr) = let not_a kind x = - let msg = + let msg = sprintf "Cannot inherit from non-%s type" - (match kind with - `Sum -> "variant" - | `Record -> "record" - | _ -> assert false) + (match kind with + `Sum -> "variant" + | `Record -> "record" + | _ -> assert false) in error_at (loc_of_type_expr t0) msg in 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 - | `Variant _ -> () - ) vl - - | `Record (_, fl, _) when kind = `Record -> - List.iter ( - function - `Inherit (_, t) -> check kind inherited t - | `Field _ -> () - ) fl - + `Sum (_, vl, _) when kind = `Sum -> + List.iter ( + function + `Inherit (_, t) -> check kind inherited t + | `Variant _ -> () + ) vl + + | `Record (_, fl, _) when kind = `Record -> + List.iter ( + function + `Inherit (_, t) -> check kind inherited t + | `Field _ -> () + ) fl + | `Sum _ | `Record _ | `Tuple _ @@ -50,37 +50,37 @@ let check_inheritance tbl (t0 : type_expr) = | `Option _ | `Nullable _ | `Shared _ as x -> not_a kind x - + | `Name (_, (loc, k, tal), _) -> - if List.mem k 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) - in - (match opt_def with - None -> () - | Some (_, _, t) -> check kind (k :: inherited) t - ) - + if List.mem k 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) + in + (match opt_def with + None -> () + | Some (_, _, t) -> check kind (k :: inherited) t + ) + | `Tvar _ -> - error_at (loc_of_type_expr t0) "Cannot inherit from a type variable" - + error_at (loc_of_type_expr t0) "Cannot inherit from a type variable" + in - + check (get_kind t0) (add_name [] t0) t0 let check_type_expr tbl 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 + List.iter (check_variant (Hashtbl.create 10)) vl; + check_inheritance tbl x - | `Record (_, fl, _) as x -> - List.iter (check_field (Hashtbl.create 10)) fl; - check_inheritance tbl x + | `Record (_, fl, _) as x -> + List.iter (check_field (Hashtbl.create 10)) fl; + check_inheritance tbl x | `Tuple (_, tl, _) -> List.iter (fun (_, x, _) -> check x) tl | `List (_, t, _) -> check t @@ -92,53 +92,53 @@ let check_type_expr tbl tvars (t : type_expr) = check t | `Name (_, (loc, k, tal), _) -> - assert (k <> "list" && k <> "option" + assert (k <> "list" && k <> "option" && k <> "nullable" && k <> "shared"); - 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, \ + 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") - ); + k arity n (if n > 1 then "s are given" + else " is given") + ); - List.iter check tal + List.iter check tal | `Tvar (loc, s) -> - if not (List.mem s tvars) then - error_at loc (sprintf "Unbound type variable '%s" s) + if not (List.mem s tvars) then + error_at loc (sprintf "Unbound type variable '%s" s) and check_variant accu = function `Variant (loc, (k, _), opt_t) -> - if Hashtbl.mem accu k then - error_at loc - (sprintf - "Multiple definitions of the same variant constructor %s" k); - Hashtbl.add accu k (); - (match opt_t with - None -> () - | Some t -> check t) + if Hashtbl.mem accu k then + error_at loc + (sprintf + "Multiple definitions of the same variant constructor %s" k); + Hashtbl.add accu k (); + (match opt_t with + None -> () + | Some t -> check t) | `Inherit (_, t) -> - (* overriding is allowed, for now without a warning *) - check t + (* overriding is allowed, for now without a warning *) + check t - and check_field accu = function + and check_field accu = function `Field (loc, (k, fk, _), 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 + 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) -> - (* overriding is allowed, for now without a warning *) - check t + (* overriding is allowed, for now without a warning *) + check t in check t @@ -152,14 +152,14 @@ let check (l : Atd_ast.module_body) = List.iter ( function `Type ((loc, (k, pl, a), t) 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) + 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) + Hashtbl.add tbl k (List.length pl, Some x) ) l; (* second pass: check existence and arity of types in type expressions, diff --git a/atd_doc.ml b/atd_doc.ml index a8c91c44..bc412711 100644 --- a/atd_doc.ml +++ b/atd_doc.ml @@ -1,6 +1,6 @@ open Printf -type inline = +type inline = [ `Text of string | `Code of string ] type block = [ `Paragraph of inline list | `Pre of string ] diff --git a/atd_doc.mli b/atd_doc.mli index aba8801f..4afb045b 100644 --- a/atd_doc.mli +++ b/atd_doc.mli @@ -31,7 +31,7 @@ Character encoding: UTF-8 is strongly recommended, if not plain ASCII. *) -type inline = +type inline = [ `Text of string | `Code of string ] (** [`Text] is regular text. [`Code] is text that was enclosed diff --git a/atd_doc_lexer.mll b/atd_doc_lexer.mll index debb9c54..3ca22f3f 100644 --- a/atd_doc_lexer.mll +++ b/atd_doc_lexer.mll @@ -25,7 +25,7 @@ let verb_not_special = [^ '\\' ' ' '\t' '\r' '\n' '}'] rule paragraph a1 a2 a3 = parse '\\' ('\\' | "{{" | "{{{" as s) { paragraph a1 a2 (s :: a3) lexbuf } - | "{{" + | "{{" { let code = inline_verbatim [] lexbuf in let a2 = match String.concat "" (List.rev a3) with diff --git a/atd_expand.ml b/atd_expand.ml index a9bac978..a77800d3 100644 --- a/atd_expand.ml +++ b/atd_expand.ml @@ -29,7 +29,7 @@ By default, only parameterless type definitions are returned. - The [keep_poly] option allows to return parametrized type definitions as + The [keep_poly] option allows to return parametrized type definitions as well. Input: @@ -50,8 +50,8 @@ type "int tree" = [ Leaf of int | Node of ("int tree" * "int tree") ] type t = "int tree" - type "[ Foo | Bar ] tree" = - [ Leaf of [ Foo | Bar ] + type "[ Foo | Bar ] tree" = + [ Leaf of [ Foo | Bar ] | Node of ("[ Foo | Bar ] tree" * "[ Foo | Bar ] tree") ] type x = "[ Foo | Bar ] tree" @@ -88,12 +88,12 @@ let init_table () = seqnum, tbl -let rec mapvar_expr +let rec mapvar_expr (f : string -> string) (x : Atd_ast.type_expr) : Atd_ast.type_expr = match x with - `Sum (loc, vl, a) -> + `Sum (loc, vl, a) -> `Sum (loc, List.map (mapvar_variant f) vl, a) - | `Record (loc, fl, a) -> + | `Record (loc, fl, a) -> `Record (loc, List.map (mapvar_field f) fl, a) | `Tuple (loc, tl, a) -> `Tuple (loc, @@ -103,27 +103,27 @@ let rec mapvar_expr `List (loc, mapvar_expr f t, a) | `Name (loc, (loc2, "list", [t]), a) -> `Name (loc, (loc2, "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) - + | `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) - + | `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) | `Tvar (loc, s) -> `Tvar (loc, f s) - + | `Name (loc, (loc2, k, args), a) -> `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) @@ -131,14 +131,14 @@ and mapvar_field f = function and mapvar_variant f = function `Variant (loc, k, opt_t) -> `Variant ( - loc, k, + loc, k, (match opt_t with None -> None | Some t -> Some (mapvar_expr f t) ) ) | `Inherit (loc, t) -> `Inherit (loc, mapvar_expr f t) - + let var_of_int i = let letter = i mod 26 in @@ -224,14 +224,14 @@ let add_annot (x : type_expr) a : type_expr = let expand ?(keep_poly = false) (l : type_def list) : type_def list = - + let seqnum, tbl = init_table () in let rec subst env (t : type_expr) : type_expr = match t with - `Sum (loc, vl, a) -> + `Sum (loc, vl, a) -> `Sum (loc, List.map (subst_variant env) vl, a) - | `Record (loc, fl, a) -> + | `Record (loc, fl, a) -> `Record (loc, List.map (subst_field env) fl, a) | `Tuple (loc, tl, a) -> `Tuple (loc, @@ -322,12 +322,12 @@ let expand ?(keep_poly = false) (l : type_def list) : type_def list = (* Create entry in the table, indicating that we are working on it *) Hashtbl.add tbl name (i, n_param, None, None); - + (* Get the original type definition *) let (_, n, orig_opt_td, new_opt_td) = try Hashtbl.find tbl orig_name with Not_found -> - assert false (* All original type definitions must + assert false (* All original type definitions must have been put in the table initially *) in let ((_, _, t') as td') = @@ -341,7 +341,7 @@ let expand ?(keep_poly = false) (l : type_def list) : type_def list = let t = add_annot t an0 in let t = set_type_expr_loc loc t in - (* + (* First replace the type expression being specialized (orig_name, orig_args) by the equivalent expression in the new environment (variables 'a, 'b, ...) @@ -396,7 +396,7 @@ let expand ?(keep_poly = false) (l : type_def list) : type_def list = (loc, (name, new_params, def_an), t') 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) @@ -412,7 +412,7 @@ let expand ?(keep_poly = false) (l : type_def list) : type_def list = and subst_only_args env = function `List (loc, t, a) | `Name (loc, (_, "list", [t]), a) -> - `List (loc, subst env t, a) + `List (loc, subst env t, a) | `Option (loc, t, a) | `Name (loc, (_, "option", [t]), a) -> @@ -440,12 +440,12 @@ let expand ?(keep_poly = false) (l : type_def list) : type_def list = let n = List.length pl in Hashtbl.add tbl k (i, n, Some td, 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 ( - let (i, n, _, _) = + let (i, n, _, _) = try Hashtbl.find tbl k with Not_found -> assert false in @@ -456,7 +456,7 @@ let expand ?(keep_poly = false) (l : type_def list) : type_def list = ) l; (* third pass: collect all parameterless definitions *) - let l = + let l = Hashtbl.fold ( fun k (i, n, opt_td, opt_td') l -> match opt_td' with @@ -489,7 +489,7 @@ let replace_type_names (subst : string -> string) (t : type_expr) : type_expr = and replace_field = function `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 -> (match opt_t with @@ -501,7 +501,7 @@ let replace_type_names (subst : string -> string) (t : type_expr) : type_expr = replace t -let standardize_type_names +let standardize_type_names ~prefix (l : type_def list) : type_def list = let new_id = @@ -518,7 +518,7 @@ let standardize_type_names let tbl = Hashtbl.create 50 in List.iter (fun (k, _, _) -> Hashtbl.add tbl k k) Atd_predef.list; List.iter ( - fun (_, (k, _, _), _) -> + fun (_, (k, _, _), _) -> if not (is_special k) then ( Hashtbl.add tbl k k ) @@ -533,7 +533,7 @@ let standardize_type_names in let l = List.map ( - fun (loc, (k, pl, a), t) -> + fun (loc, (k, pl, a), t) -> let k' = replace_name k in (loc, (k', pl, a), t) ) l diff --git a/atd_expand.mli b/atd_expand.mli index 6af86803..ed5578b2 100644 --- a/atd_expand.mli +++ b/atd_expand.mli @@ -9,7 +9,7 @@ val expand_module_body : Atd_ast.module_body -> Atd_ast.module_body (** Monomorphization of type expressions. - + @param prefix prefix to use for new type names. Default is ["_"]. @param keep_poly return definitions for the parametrized types. @@ -51,7 +51,7 @@ v} v} By default, only parameterless type definitions are returned. - The [keep_poly] option allows to return parametrized type definitions as + The [keep_poly] option allows to return parametrized type definitions as well. Input: @@ -75,8 +75,8 @@ v} type "int tree" = [ Leaf of int | Node of ("int tree" * "int tree") ] type t = "int tree" - type "[ Foo | Bar ] tree" = - [ Leaf of [ Foo | Bar ] + type "[ Foo | Bar ] tree" = + [ Leaf of [ Foo | Bar ] | Node of ("[ Foo | Bar ] tree" * "[ Foo | Bar ] tree") ] type x = "[ Foo | Bar ] tree" v} diff --git a/atd_indent.ml b/atd_indent.ml index 4395fb61..9b680f94 100644 --- a/atd_indent.ml +++ b/atd_indent.ml @@ -1,6 +1,6 @@ -type t = +type t = [ | `Line of string | `Block of t list @@ -12,11 +12,11 @@ let to_buffer ?(offset = 0) ?(indent = 2) buf l = `Block l -> List.iter (print (n + indent)) l | `Inline l -> List.iter (print n) l | `Line s -> - for i = 1 to n do - Buffer.add_char buf ' ' - done; - Buffer.add_string buf s; - Buffer.add_char buf '\n'; + for i = 1 to n do + Buffer.add_char buf ' ' + done; + Buffer.add_string buf s; + Buffer.add_char buf '\n'; in List.iter (print offset) l diff --git a/atd_indent.mli b/atd_indent.mli index 0ef28097..46b33904 100644 --- a/atd_indent.mli +++ b/atd_indent.mli @@ -4,7 +4,7 @@ Simple indentation utility for code generators *) -type t = +type t = [ | `Line of string | `Block of t list @@ -20,7 +20,7 @@ type t = Example: {v -let l = +let l = [ `Line "d"; `Line "e"; @@ -52,11 +52,11 @@ v} val to_buffer : ?offset:int -> ?indent:int -> Buffer.t -> t list -> unit (** Write to a buffer. - + @param offset defines the number of space characters to use for the left margin. Default: 0. - @param indent defines the number of space characters to use for + @param indent defines the number of space characters to use for indenting blocks. Default: 2. *) diff --git a/atd_inherit.ml b/atd_inherit.ml index 782cf7ca..742d6ea2 100644 --- a/atd_inherit.ml +++ b/atd_inherit.ml @@ -20,13 +20,13 @@ let load_defs l = ) l; tbl -let keep_last_defined get_name l = +let keep_last_defined get_name l = let set, l = List.fold_right ( fun x (set, l) -> - let k = get_name x in - if S.mem k set then (set, l) - else (S.add k set, x :: l) + let k = get_name x in + if S.mem k set then (set, l) + else (S.add k set, x :: l) ) l (S.empty, []) in l @@ -44,98 +44,98 @@ let expand ?(inherit_fields = true) ?(inherit_variants = true) tbl t0 = let rec subst deref param (t : type_expr) : type_expr = match t with - `Sum (loc, vl, a) -> - let vl = List.flatten (List.map (subst_variant param) vl) in - let vl = + `Sum (loc, vl, a) -> + let vl = List.flatten (List.map (subst_variant param) vl) in + let vl = if inherit_variants then keep_last_defined get_variant_name vl else vl in - `Sum (loc, vl, a) + `Sum (loc, vl, a) - | `Record (loc, fl, a) -> - let fl = List.flatten (List.map (subst_field param) fl) in - let fl = + | `Record (loc, fl, a) -> + let fl = List.flatten (List.map (subst_field param) fl) in + let fl = if inherit_fields then keep_last_defined get_field_name fl else fl in - `Record (loc, fl, a) - - | `Tuple (loc, tl, a) -> - `Tuple ( - loc, - List.map (fun (loc, x, a) -> (loc, subst false param x, a)) tl, a - ) - + `Record (loc, fl, a) + + | `Tuple (loc, tl, a) -> + `Tuple ( + loc, + List.map (fun (loc, x, a) -> (loc, subst false param x, a)) tl, a + ) + | `List (loc, t, a) | `Name (loc, (_, "list", [t]), a) -> - `List (loc, subst false param t, a) - + `List (loc, subst false param t, a) + | `Option (loc, t, a) - | `Name (loc, (_, "option", [t]), a) -> - `Option (loc, subst false param t, a) - + | `Name (loc, (_, "option", [t]), a) -> + `Option (loc, subst false param t, a) + | `Nullable (loc, t, a) - | `Name (loc, (_, "nullable", [t]), a) -> - `Nullable (loc, subst false param t, a) - + | `Name (loc, (_, "nullable", [t]), a) -> + `Nullable (loc, subst false param t, a) + | `Shared (loc, t, a) - | `Name (loc, (_, "shared", [t]), a) -> + | `Name (loc, (_, "shared", [t]), a) -> `Shared (loc, subst false param t, a) | `Tvar (loc, s) -> - (try List.assoc s param - with Not_found -> t) - + (try List.assoc s param + with Not_found -> t) + | `Name (loc, (loc2, k, args), a) -> - let expanded_args = List.map (subst false param) args in - if deref then + let expanded_args = List.map (subst false param) args in + if deref then let k, vars, a, t = - try + try match Hashtbl.find tbl k with n, Some (_, (k, vars, a), t) -> k, vars, a, t - | n, None -> failwith ("Cannot inherit from type " ^ k) - with Not_found -> + | n, None -> failwith ("Cannot inherit from type " ^ k) + with Not_found -> failwith ("Missing type definition for " ^ k) - in - let param = List.combine vars expanded_args in - subst true param t - else - `Name (loc, (loc2, k, expanded_args), a) - + in + let param = List.combine vars expanded_args in + subst true param t + else + `Name (loc, (loc2, k, expanded_args), a) + and subst_field param = function `Field (loc, k, t) -> [ `Field (loc, k, subst false param t) ] | `Inherit (loc, t) as x -> - (match subst true param t with - `Record (loc, vl, a) -> + (match subst true param t with + `Record (loc, vl, a) -> if inherit_fields then vl else [ x ] - | _ -> failwith "Not a record type" - ) - + | _ -> failwith "Not a record type" + ) + and subst_variant param = function `Variant (loc, k, opt_t) as x -> - (match opt_t with - None -> [ x ] - | Some t -> [ `Variant (loc, k, Some (subst false param t)) ] - ) + (match opt_t with + None -> [ x ] + | Some t -> [ `Variant (loc, k, Some (subst false param t)) ] + ) | `Inherit (loc, t) as x -> - (match subst true param t with - `Sum (loc, vl, a) -> + (match subst true param t with + `Sum (loc, vl, a) -> if inherit_variants then vl else [ x ] - | _ -> failwith "Not a sum type" - ) + | _ -> failwith "Not a sum type" + ) in subst false [] t0 let expand_module_body ?inherit_fields - ?inherit_variants + ?inherit_variants (l : Atd_ast.module_body) = let td_list = List.map (function `Type td -> td) l in let tbl = load_defs td_list in diff --git a/atd_inherit.mli b/atd_inherit.mli index 978bcdee..5e19852e 100644 --- a/atd_inherit.mli +++ b/atd_inherit.mli @@ -2,7 +2,7 @@ (** Expansion of [inherit] statements *) -val expand_module_body : +val expand_module_body : ?inherit_fields : bool -> ?inherit_variants : bool -> Atd_ast.module_body -> Atd_ast.module_body diff --git a/atd_lexer.mll b/atd_lexer.mll index 36cfb070..842bc9c3 100644 --- a/atd_lexer.mll +++ b/atd_lexer.mll @@ -9,22 +9,22 @@ Atd_ast.error (Atd_ast.string_of_loc loc ^ "\n" ^ msg) type accu = { mutable depth : int; - buf : Buffer.t } - + buf : Buffer.t } + let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with - pos_lnum = pos.pos_lnum + 1; - pos_bol = pos.pos_cnum } + pos_lnum = pos.pos_lnum + 1; + pos_bol = pos.pos_cnum } let int_of_dec c = match c with - '0'..'9' -> Char.code c - 48 + '0'..'9' -> Char.code c - 48 | _ -> invalid_arg "int_of_dec" let int_of_hex c = match c with - '0'..'9' -> Char.code c - 48 + '0'..'9' -> Char.code c - 48 | 'a'..'f' -> Char.code c - 87 | 'A'..'F' -> Char.code c - 55 | _ -> invalid_arg "int_of_hex" @@ -113,27 +113,27 @@ rule token = parse | eof { EOF } | '"' { STRING (string (Buffer.create 200) lexbuf) } | "(*" { comment 1 lexbuf; token lexbuf } - | _ as c { lexing_error lexbuf - (sprintf "Illegal character %S" (String.make 1 c)) } + | _ as c { lexing_error lexbuf + (sprintf "Illegal character %S" (String.make 1 c)) } and string buf = parse | '"' { Buffer.contents buf } | '\\' (['\\' '"'] as c) { Buffer.add_char buf c; - string buf lexbuf } + string buf lexbuf } | "\\x" (hex as a) (hex as b) { Buffer.add_char buf (byte_of_hex a b); - string buf lexbuf } + string buf lexbuf } | '\\' (digit as a) (digit as b) (digit as c) { Buffer.add_char buf (byte_of_dec a b c); - string buf lexbuf } + string buf lexbuf } | "\\n" { Buffer.add_char buf '\n'; string buf lexbuf } | "\\r" { Buffer.add_char buf '\r'; string buf lexbuf } | "\\t" { Buffer.add_char buf '\t'; string buf lexbuf } | "\\b" { Buffer.add_char buf '\b'; string buf lexbuf } - | '\n' { newline lexbuf; - Buffer.add_char buf '\n'; - string buf lexbuf } + | '\n' { newline lexbuf; + Buffer.add_char buf '\n'; + string buf lexbuf } | '\\' newline blank* { newline lexbuf; string buf lexbuf } | '\\' { lexing_error lexbuf "Invalid escape sequence" } @@ -142,11 +142,11 @@ and string buf = parse and comment depth = parse | "*)" { if depth > 1 then - comment (depth - 1) lexbuf - } + comment (depth - 1) lexbuf + } | "(*" { comment (depth + 1) lexbuf } | '"' { ignore (string (Buffer.create 200) lexbuf); - comment depth lexbuf } + comment depth lexbuf } | newline { newline lexbuf; comment depth lexbuf } | _ { comment depth lexbuf } | eof { lexing_error lexbuf "Unterminated comment" } diff --git a/atd_parser.mly b/atd_parser.mly index 44523a8a..6a3614b8 100644 --- a/atd_parser.mly +++ b/atd_parser.mly @@ -39,12 +39,12 @@ annot: asection: | LT x = LIDENT l = afield_list GT { (x, (($startpos, $endpos), l)) } -| LT LIDENT afield_list _e=error { syntax_error - "Expecting '>'" - $startpos(_e) $endpos(_e) } +| LT LIDENT afield_list _e=error { syntax_error + "Expecting '>'" + $startpos(_e) $endpos(_e) } | LT _e=error { syntax_error - "Expecting lowercase identifier" - $startpos(_e) $endpos(_e) } + "Expecting lowercase identifier" + $startpos(_e) $endpos(_e) } ; afield_list: @@ -74,7 +74,7 @@ type_param: | TIDENT { [ $1 ] } | OP_PAREN type_var_list CL_PAREN { $2 } | { [] } -| OP_PAREN type_var_list _e=error +| OP_PAREN type_var_list _e=error { syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) } ; @@ -112,14 +112,14 @@ type_expr: (* may cause ID clashes if not used properly *) a else - Atd_annot.set_field loc + Atd_annot.set_field loc "share" "id" (Some (Atd_annot.create_id ())) a in `Shared (loc, x, a) | ("list"|"option"|"nullable"|"shared"), _ -> syntax_error (sprintf "%s expects one argument" name) pos1 pos2 - + | _ -> (`Name (loc, x, a) : type_expr) } | x = TIDENT @@ -150,7 +150,7 @@ type_args: | type_expr { [ $1 ] } | OP_PAREN type_arg_list CL_PAREN { $2 } | { [] } -| OP_PAREN type_arg_list _e=error +| OP_PAREN type_arg_list _e=error { syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) } ; @@ -172,13 +172,13 @@ variant_list0: variant: | x = UIDENT a = annot OF t = type_expr { `Variant (($startpos, $endpos), (x, a), Some t) } -| x = UIDENT a = annot +| x = UIDENT a = annot { `Variant (($startpos, $endpos), (x, a), None) } | INHERIT t = type_expr { `Inherit (($startpos, $endpos), t) } | UIDENT annot OF _e=error - { syntax_error "Expecting type expression after 'of'" - $startpos(_e) $endpos(_e) } + { syntax_error "Expecting type expression after 'of'" + $startpos(_e) $endpos(_e) } ; field_list: @@ -195,7 +195,7 @@ field: { `Inherit (($startpos, $endpos), t) } | field_name annot COLON _e=error { syntax_error "Expecting type expression after ':'" - $startpos(_e) $endpos(_e) } + $startpos(_e) $endpos(_e) } | field_name annot _e=error { syntax_error "Expecting ':'" $startpos(_e) $endpos(_e) } ; diff --git a/atd_predef.ml b/atd_predef.ml index af025685..44fc69ae 100644 --- a/atd_predef.ml +++ b/atd_predef.ml @@ -6,34 +6,34 @@ open Atd_ast -let list_def : type_def = +let list_def : type_def = let loc = dummy_loc in ( - loc, + loc, ("list", ["a"], []), `List (loc, `Tvar (loc, "a"), []) ) -let option_def : type_def = +let option_def : type_def = let loc = dummy_loc in ( - loc, + loc, ("option", ["a"], []), `Option (loc, `Tvar (loc, "a"), []) ) -let nullable_def : type_def = +let nullable_def : type_def = let loc = dummy_loc in ( - loc, + loc, ("nullable", ["a"], []), `Nullable (loc, `Tvar (loc, "a"), []) ) -let shared_def : type_def = +let shared_def : type_def = let loc = dummy_loc in ( - loc, + loc, ("shared", ["a"], []), `Shared (loc, `Tvar (loc, "a"), []) ) diff --git a/atd_print.ml b/atd_print.ml index 711c0532..2a0c5c89 100644 --- a/atd_print.ml +++ b/atd_print.ml @@ -4,26 +4,26 @@ open Easy_format open Atd_ast let rlist = { list with - wrap_body = `Force_breaks; - indent_body = 0; - align_closing = false; - space_after_opening = false; - space_before_closing = false - } + 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 } + 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 shlist = { hlist with + stick_to_label = false; + space_after_opening = false; + space_before_closing = false } let shlist0 = { shlist with space_after_separator = false } -let llist = { +let llist = { list with separators_stick_left = false; space_before_separator = true; @@ -49,27 +49,27 @@ let format_prop (k, (_, opt)) = match opt with None -> make_atom k | Some s -> - Label ( - (make_atom (k ^ "="), label0), - (make_atom (quote_string s)) - ) + Label ( + (make_atom (k ^ "="), label0), + (make_atom (quote_string s)) + ) let default_annot (s, (_, l)) = match l with [] -> make_atom ("<" ^ s ^ ">") | l -> - List ( - ("<", "", ">", plist), - [ - Label ( - (make_atom s, label), - List ( - ("", "", "", plist), - List.map format_prop l - ) - ) - ] - ) + List ( + ("<", "", ">", plist), + [ + Label ( + (make_atom s, label), + List ( + ("", "", "", plist), + List.map format_prop l + ) + ) + ] + ) let string_of_field k fk = @@ -85,155 +85,155 @@ let make_closures format_annot = match l with [] -> x | _ -> - Label ( - (x, label), - List (("", "", "", plist), List.map format_annot l) - ) + Label ( + (x, label), + List (("", "", "", plist), List.map format_annot l) + ) in let prepend_colon_annots l x = match l with [] -> x | _ -> - Label ( - (Label ( - (List (("", "", "", plist), List.map format_annot l), label0), - make_atom ":" - ), - label), - x - ) + Label ( + (Label ( + (List (("", "", "", plist), List.map format_annot l), label0), + make_atom ":" + ), + label), + x + ) 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 - ) - - - + 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 = 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 - + 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 - + 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 (_, l, a) -> - append_annots a ( - List ( - ("[", "|", "]", llist), - List.map format_variant l - ) - ) + append_annots a ( + List ( + ("[", "|", "]", llist), + List.map format_variant l + ) + ) | `Record (_, l, a) -> - append_annots a ( - List ( - ("{", ";", "}", list), - List.map format_field l - ) - ) + append_annots a ( + List ( + ("{", ";", "}", list), + List.map format_field l + ) + ) | `Tuple (_, l, a) -> - append_annots a ( - List ( - ("(", "*", ")", lplist), - List.map format_tuple_field l - ) - ) - + append_annots a ( + List ( + ("(", "*", ")", lplist), + List.map format_tuple_field l + ) + ) + | `List (loc, t, a) -> - format_type_name "list" [t] a - + format_type_name "list" [t] a + | `Option (loc, t, a) -> - format_type_name "option" [t] a - + format_type_name "option" [t] a + | `Nullable (loc, t, a) -> - format_type_name "nullable" [t] a - + format_type_name "nullable" [t] a + | `Shared (loc, t, a) -> format_type_name "shared" [t] a - + | `Name (_, (_, name, args), a) -> - format_type_name name args a - + format_type_name name args a + | `Tvar (_, name) -> - make_atom ("'" ^ name) - + make_atom ("'" ^ name) + and format_type_name name args a = append_annots a ( horizontal_sequence (prepend_type_args args [ make_atom name ]) ) - + and format_inherit t = horizontal_sequence [ make_atom "inherit"; format_type_expr t ] - + and format_tuple_field (loc, x, a) = prepend_colon_annots a (format_type_expr x) - + and format_field x = match x with `Field (_, (k, fk, a), t) -> - Label ( - (horizontal_sequence0 [ - append_annots a (make_atom (string_of_field k fk)); - make_atom ":" - ], label), - format_type_expr t - ) + Label ( + (horizontal_sequence0 [ + append_annots a (make_atom (string_of_field k fk)); + make_atom ":" + ], label), + format_type_expr t + ) | `Inherit (_, t) -> format_inherit t - + and format_variant x = match x with `Variant (_, (k, a), opt) -> - let cons = append_annots a (make_atom k) in - (match opt with - None -> cons - | Some t -> - Label ( - (cons, label), - Label ( - (make_atom "of", label), - format_type_expr t - ) - ) - ) + let cons = append_annots a (make_atom k) in + (match opt with + None -> cons + | Some t -> + Label ( + (cons, label), + Label ( + (make_atom "of", label), + format_type_expr t + ) + ) + ) | `Inherit (_, t) -> format_inherit t in @@ -248,7 +248,7 @@ let make_closures format_annot = -let format ?(annot = default_annot) x = +let format ?(annot = default_annot) x = let f, _ = make_closures annot in f x diff --git a/atd_print.mli b/atd_print.mli index b0fc893f..d16d38aa 100644 --- a/atd_print.mli +++ b/atd_print.mli @@ -11,12 +11,12 @@ val format : module to convert an [Easy_format.t] into a string or add it to a channel or buffer. - @param annot can be used to specify another way of formatting + @param annot can be used to specify another way of formatting annotations. The default is available as [default_format_annot]. *) -val string_of_type_name : +val string_of_type_name : string -> Atd_ast.type_expr list -> Atd_ast.annot -> string (** Convert a type name with its arguments and its annotations into a string. *) diff --git a/atd_reflect.ml b/atd_reflect.ml index 1c6200c4..895bc9fe 100644 --- a/atd_reflect.ml +++ b/atd_reflect.ml @@ -23,7 +23,7 @@ let print_prop_list buf l = print_list ( fun buf (s, (loc, o)) -> bprintf buf "(%S, (%a, %a))" - s print_loc loc (print_opt print_qstring) o + s print_loc loc (print_opt print_qstring) o ) buf l @@ -37,49 +37,49 @@ let print_annot_list buf l = let rec print_type_expr buf (x : Atd_ast.type_expr) = match x with `Sum (loc, variant_list, annot_list) -> - bprintf buf "`Sum (%a, %a, %a)" - print_loc loc - (print_list print_variant) variant_list - print_annot_list annot_list + 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)" - print_loc loc - (print_list print_field) field_list - print_annot_list annot_list + 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)" - print_loc loc - (print_list print_cell) cell_list - print_annot_list annot_list + 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)" - print_loc loc - print_type_expr type_expr - print_annot_list annot_list + 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)" - print_loc loc - print_type_expr type_expr - print_annot_list annot_list + 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)" - print_loc loc - print_type_expr type_expr - print_annot_list annot_list + 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)" - print_loc loc + print_loc loc print_type_expr type_expr - print_annot_list annot_list + print_annot_list annot_list | `Name (loc, type_inst, annot_list) -> - bprintf buf "`Name (%a, %a, %a)" - print_loc loc - print_type_inst type_inst - print_annot_list annot_list + 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)" - print_loc loc - string + bprintf buf "`Tvar (%a, %S)" + print_loc loc + string and print_cell buf (loc, x, a) = bprintf buf "(%a, %a, %a)" @@ -90,31 +90,31 @@ 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)" - print_loc loc - s print_annot_list a - (print_opt print_type_expr) o + 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)" - print_loc loc - print_type_expr x + bprintf buf "`Inherit (%a, %a)" + print_loc loc + print_type_expr x and print_field buf x = 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 + 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 + 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" + `Required -> "`Required" | `Optional -> "`Optional" | `With_default -> "`With_default") @@ -126,17 +126,17 @@ and print_type_inst buf (loc, s, l) = let print_module_item buf (`Type (loc, (name, param, a), x)) = - bprintf buf "`Type (%a, (%S, %a, %a), %a)" + bprintf buf "`Type (%a, (%S, %a, %a), %a)" print_loc loc name (print_list print_qstring) param print_annot_list a print_type_expr x let print_module_body buf l = bprintf buf "[\n"; - List.iter (fun x -> - print_module_item buf x; - bprintf buf ";\n" - ) l; + List.iter (fun x -> + print_module_item buf x; + bprintf buf ";\n" + ) l; bprintf buf "]\n" let print_module_body_def buf name l = diff --git a/atd_tsort.ml b/atd_tsort.ml index abd3ed95..cc046531 100644 --- a/atd_tsort.ml +++ b/atd_tsort.ml @@ -31,52 +31,52 @@ struct try !(M.find key states) with Not_found -> invalid_arg (sprintf "Atd_tsort: undefined child node %s" - (Param.to_string key)) + (Param.to_string key)) let set_state key state states = try M.find key states := state with Not_found -> invalid_arg (sprintf "Atd_tsort: undefined child node %s" - (Param.to_string key)) + (Param.to_string key)) let merge (s1, l1, ll1) (s2, l2, ll2) = (S.union s1 s2, l1 @ l2, ll1 @ ll2) - let map_of_list l = + let map_of_list l = List.fold_left (fun m x -> M.add (fst3 x) x m) M.empty l let get_node key graph = try M.find key graph with Not_found -> invalid_arg - (sprintf "Atd_tsort: undefined child node %s" (Param.to_string key)) + (sprintf "Atd_tsort: undefined child node %s" (Param.to_string key)) let rec sort_root graph states (x : (_, _) node) = let key, children, value = x in match get_state key states with - Black -> (S.empty, [], []) + Black -> (S.empty, [], []) | Grey -> (S.singleton key, [], []) | White -> - set_state key Grey states; - let closing_nodes, cycle_nodes, sorted = - sort_list graph states children in - set_state key Black states; - if S.is_empty closing_nodes then - (closing_nodes, [], (false, [value]) :: sorted) - else - let closing_nodes = S.remove key closing_nodes in - let cycle_nodes = value :: cycle_nodes in - if S.is_empty closing_nodes then - (closing_nodes, [], (true, cycle_nodes) :: sorted) - else - (closing_nodes, cycle_nodes, sorted) - + set_state key Grey states; + let closing_nodes, cycle_nodes, sorted = + sort_list graph states children in + set_state key Black states; + if S.is_empty closing_nodes then + (closing_nodes, [], (false, [value]) :: sorted) + else + let closing_nodes = S.remove key closing_nodes in + let cycle_nodes = value :: cycle_nodes in + if S.is_empty closing_nodes then + (closing_nodes, [], (true, cycle_nodes) :: sorted) + else + (closing_nodes, cycle_nodes, sorted) + and sort_list graph states l = List.fold_left ( fun accu key -> - merge (sort_root graph states (get_node key graph)) accu + merge (sort_root graph states (get_node key graph)) accu ) (S.empty, [], []) l - + and sort (l : (Param.t, 'a) node list) = let graph = map_of_list l in let states = init_states l in diff --git a/atd_util.ml b/atd_util.ml index d12bf200..c2de4ece 100644 --- a/atd_util.ml +++ b/atd_util.ml @@ -34,7 +34,7 @@ let read_channel else pos_fname in - read_lexbuf ?expand ?keep_poly ?xdebug + read_lexbuf ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf let load_file @@ -59,7 +59,7 @@ let load_file finally (); raise e -let load_string +let load_string ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum s = @@ -80,9 +80,9 @@ let tsort l0 = let l = List.map ( fun def -> - let `Type (loc, (name, _, _), x) = def in - let deps = Atd_ast.extract_type_names ~ignorable x in - (name, deps, def) + let `Type (loc, (name, _, _), x) = def in + let deps = Atd_ast.extract_type_names ~ignorable x in + (name, deps, def) ) l0 in List.rev (Tsort.sort l) diff --git a/atd_util.mli b/atd_util.mli index 420484c5..c81bab6e 100644 --- a/atd_util.mli +++ b/atd_util.mli @@ -13,9 +13,9 @@ val read_lexbuf : Lexing.lexbuf -> Atd_ast.full_module (** Read an ATD file from a lexbuf. See also [read_channel], [load_file] and [load_string]. - + @param expand - Perform monomorphization by creating specialized + Perform monomorphization by creating specialized type definitions starting with an underscore. Default is false. See also {!Atd_expand}. This corresponds to the [-x] option of [atdcat]. diff --git a/atdcat.ml b/atdcat.ml index 9e13b192..669ef9a4 100644 --- a/atdcat.ml +++ b/atdcat.ml @@ -56,7 +56,7 @@ let parse let l = List.map ( fun file -> - Atd_util.load_file ~expand ~keep_poly ~xdebug + Atd_util.load_file ~expand ~keep_poly ~xdebug ~inherit_fields ~inherit_variants file ) files in @@ -73,11 +73,11 @@ let parse let print ~html_doc ~out_format ast = let f = match out_format with - `Atd -> print_atd ~html_doc + `Atd -> print_atd ~html_doc | `Ocaml name -> print_ml ~name in f ast - + let split_on_comma = Str.split_delim (Str.regexp ",") @@ -158,7 +158,7 @@ let () = let ast = parse ~expand: !expand - ~keep_poly: !keep_poly + ~keep_poly: !keep_poly ~xdebug: !xdebug ~inherit_fields: !inherit_fields ~inherit_variants: !inherit_variants @@ -169,6 +169,6 @@ let () = print ~html_doc: !html_doc ~out_format: !out_format ast with Atd_ast.Atd_error s -> - flush stdout; - eprintf "%s\n%!" s + flush stdout; + eprintf "%s\n%!" s | e -> raise e diff --git a/test.atd b/test.atd index 346d5213..6fe24f6b 100644 --- a/test.atd +++ b/test.atd @@ -51,7 +51,7 @@ type ('a, 'b, 'ccccccccccccccccccccc) r = { } type tuple = (z * z * tuple option * kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk - * z * z * tuple option * kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk) + * z * z * tuple option * kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk) type tuple2 = (int * float)