diff --git a/.depend b/.depend index 32b0b62b3c79..0802342f21c7 100644 --- a/.depend +++ b/.depend @@ -25,9 +25,10 @@ utils/terminfo.cmx : utils/terminfo.cmi utils/warnings.cmo : utils/warnings.cmi utils/warnings.cmx : utils/warnings.cmi parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/asttypes.cmi + parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/asttypes.cmi : parsing/location.cmi +parsing/docstrings.cmi : parsing/location.cmi parsing/parsetree.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmi : utils/warnings.cmi parsing/longident.cmi : @@ -40,9 +41,11 @@ parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ parsing/printast.cmi : parsing/parsetree.cmi parsing/syntaxerr.cmi : parsing/location.cmi parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/asttypes.cmi parsing/ast_helper.cmi + parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ - parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi + parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmi parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi utils/config.cmi \ utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ @@ -51,10 +54,14 @@ parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx utils/config.cmx \ utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ parsing/ast_mapper.cmi +parsing/docstrings.cmo : utils/warnings.cmi parsing/location.cmi \ + parsing/docstrings.cmi +parsing/docstrings.cmx : utils/warnings.cmx parsing/location.cmx \ + parsing/docstrings.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ - parsing/location.cmi parsing/lexer.cmi + parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ - parsing/location.cmx parsing/lexer.cmi + parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \ parsing/location.cmi parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ @@ -62,9 +69,11 @@ parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ - parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi + parsing/location.cmi parsing/lexer.cmi parsing/docstrings.cmi \ + parsing/parse.cmi parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ - parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi + parsing/location.cmx parsing/lexer.cmx parsing/docstrings.cmx \ + parsing/parse.cmi parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ parsing/asttypes.cmi parsing/ast_helper.cmi parsing/parser.cmi diff --git a/Makefile b/Makefile index 8666fe17b449..3793dcdffc78 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,7 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot \ +COMPFLAGS=-strict-sequence -w +33..39+48+50 -warn-error A -bin-annot \ -safe-string $(INCLUDES) LINKFLAGS= @@ -43,7 +43,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ - parsing/ast_helper.cmo \ + parsing/docstrings.cmo parsing/ast_helper.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ diff --git a/Makefile.nt b/Makefile.nt index 16b53fe2692e..1ea5fe21209a 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -39,7 +39,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ - parsing/ast_helper.cmo \ + parsing/docstrings.cmo parsing/ast_helper.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ diff --git a/boot/ocamlc b/boot/ocamlc index ea306b374018..cade3affcf8e 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 64bb5040f9c4..ec308f047316 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 82bd72ddda23..3e400286b2a2 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index fed1d26dab52..645c3e1dd4dc 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -32,7 +32,7 @@ OTHEROBJS=\ $(UNIXDIR)/unix.cma \ ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \ ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \ - ../parsing/location.cmo ../parsing/longident.cmo \ + ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \ ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ diff --git a/driver/compenv.ml b/driver/compenv.ml index 82704fd8f9b3..87fded811e58 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -175,6 +175,7 @@ let read_OCAMLPARAM ppf position = | "verbose" -> set "verbose" [ verbose ] v | "nopervasives" -> set "nopervasives" [ nopervasives ] v | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *) + | "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v | "compact" -> clear "compact" [ optimize_for_speed ] v diff --git a/driver/main.ml b/driver/main.ml index f8358a0cbdcc..334c4dc7925b 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -92,6 +92,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _impl = impl let _intf = intf let _intf_suffix s = Config.interface_suffix := s + let _keep_docs = set keep_docs let _keep_locs = set keep_locs let _labels = unset classic let _linkall = set link_everything diff --git a/driver/main_args.ml b/driver/main_args.ml index 7636abe03045..4aed1ca384ed 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -126,6 +126,10 @@ let mk_intf_suffix_2 f = "-intf_suffix", Arg.String f, " (deprecated) same as -intf-suffix" ;; +let mk_keep_docs f = + "-keep-docs", Arg.Unit f, " Keep documentation strings in .cmi files" +;; + let mk_keep_locs f = "-keep-locs", Arg.Unit f, " Keep locations in .cmi files" ;; @@ -516,6 +520,7 @@ module type Compiler_options = sig val _impl : string -> unit val _intf : string -> unit val _intf_suffix : string -> unit + val _keep_docs : unit -> unit val _keep_locs : unit -> unit val _linkall : unit -> unit val _noautolink : unit -> unit @@ -653,6 +658,7 @@ struct mk_intf F._intf; mk_intf_suffix F._intf_suffix; mk_intf_suffix_2 F._intf_suffix; + mk_keep_docs F._keep_docs; mk_keep_locs F._keep_locs; mk_labels F._labels; mk_linkall F._linkall; @@ -769,6 +775,7 @@ struct mk_inline F._inline; mk_intf F._intf; mk_intf_suffix F._intf_suffix; + mk_keep_docs F._keep_docs; mk_keep_locs F._keep_locs; mk_labels F._labels; mk_linkall F._linkall; diff --git a/driver/main_args.mli b/driver/main_args.mli index 18ade80baeb3..857a89e3125e 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -62,6 +62,7 @@ module type Compiler_options = sig val _impl : string -> unit val _intf : string -> unit val _intf_suffix : string -> unit + val _keep_docs : unit -> unit val _keep_locs : unit -> unit val _linkall : unit -> unit val _noautolink : unit -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 947d43073ae4..ac187b874332 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -90,6 +90,7 @@ module Options = Main_args.Make_optcomp_options (struct let _inline n = inline_threshold := n * 8 let _intf = intf let _intf_suffix s = Config.interface_suffix := s + let _keep_docs = set keep_docs let _keep_locs = set keep_locs let _labels = clear classic let _linkall = set link_everything diff --git a/man/ocamlc.m b/man/ocamlc.m index 3b526f7eecc6..d4309e2f6204 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -374,6 +374,9 @@ compiled interface files (.cmi), compiled object code files .I string as interface files (instead of the default .mli). .TP +.B \-keep-docs +Keep documentation strings in generated .cmi files. +.TP .B \-keep-locs Keep locations in generated .cmi files. .TP diff --git a/man/ocamlopt.m b/man/ocamlopt.m index fa3db5df8cb1..9a3a9b3bd3c0 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -304,6 +304,9 @@ and libraries (.cmxa). By default, the current directory is searched as interface files (instead of the default .mli). .TP .B \-keep-locs +Keep documentation strings in generated .cmi files. +.TP +.B \-keep-locs Keep locations in generated .cmi files. .TP .B \-labels diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 1d0b8a8e47bf..9d314e51908d 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -706,6 +706,7 @@ flag ["ocaml"; "compile"; "no_alias_deps";] (A "-no-alias-deps");; flag ["ocaml"; "compile"; "strict_formats";] (A "-strict-formats");; flag ["ocaml"; "native"; "compile"; "opaque";] (A "-opaque");; flag ["ocaml"; "native"; "compile"; "no_float_const_prop";] (A "-no-float-const-prop"); +flag ["ocaml"; "compile"; "keep_docs";] (A "-keep-docs"); flag ["ocaml"; "compile"; "keep_locs";] (A "-keep-locs"); flag ["ocaml"; "absname"; "compile"] (A "-absname");; flag ["ocaml"; "absname"; "infer_interface"] (A "-absname");; diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index a0563c536e6e..0197d1db6b0e 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -34,7 +34,7 @@ COMPILEROBJS=\ ../../utils/terminfo.cmo ../../utils/warnings.cmo \ ../../parsing/asttypes.cmi \ ../../parsing/location.cmo ../../parsing/longident.cmo \ - ../../parsing/ast_helper.cmo \ + ../../parsing/docstrings.cmo ../../parsing/ast_helper.cmo \ ../../parsing/ast_mapper.cmo \ ../../typing/ident.cmo ../../typing/path.cmo \ ../../typing/primitive.cmo ../../typing/types.cmo \ diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 588451423f57..b84cda8cdd84 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -14,6 +14,7 @@ open Asttypes open Parsetree +open Docstrings type lid = Longident.t loc type str = string loc @@ -169,6 +170,10 @@ module Sig = struct let class_type ?loc a = mk ?loc (Psig_class_type a) let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) let attribute ?loc a = mk ?loc (Psig_attribute a) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt end module Str = struct @@ -189,6 +194,10 @@ module Str = struct let include_ ?loc a = mk ?loc (Pstr_include a) let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) let attribute ?loc a = mk ?loc (Pstr_attribute a) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt end module Cl = struct @@ -225,13 +234,13 @@ module Cty = struct end module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = { pctf_desc = d; pctf_loc = loc; - pctf_attributes = attrs; + pctf_attributes = add_docs_attrs docs attrs; } - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) @@ -239,16 +248,23 @@ module Ctf = struct let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) let attribute ?loc a = mk ?loc (Pctf_attribute a) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt + + let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} + end module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = { pcf_desc = d; pcf_loc = loc; - pcf_attributes = attrs; + pcf_attributes = add_docs_attrs docs attrs; } - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) @@ -257,96 +273,117 @@ module Cf = struct let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) let attribute ?loc a = mk ?loc (Pcf_attribute a) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt let virtual_ ct = Cfk_virtual ct let concrete o e = Cfk_concrete (o, e) + + let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} + end module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(prim = []) name typ = { pval_name = name; pval_type = typ; - pval_attributes = attrs; + pval_attributes = add_docs_attrs docs attrs; pval_loc = loc; pval_prim = prim; } end module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name typ = { pmd_name = name; pmd_type = typ; - pmd_attributes = attrs; + pmd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pmd_loc = loc; } end module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) ?typ name = { pmtd_name = name; pmtd_type = typ; - pmtd_attributes = attrs; + pmtd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pmtd_loc = loc; } end module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) name expr = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name expr = { pmb_name = name; pmb_expr = expr; - pmb_attributes = attrs; + pmb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pmb_loc = loc; } end module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(override = Fresh) lid = { popen_lid = lid; popen_override = override; popen_loc = loc; - popen_attributes = attrs; + popen_attributes = add_docs_attrs docs attrs; } end module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = { pincl_mod = mexpr; pincl_loc = loc; - pincl_attributes = attrs; + pincl_attributes = add_docs_attrs docs attrs; } + end module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(text = []) pat expr = { pvb_pat = pat; pvb_expr = expr; - pvb_attributes = attrs; + pvb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pvb_loc = loc; } end module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) - name expr = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) + ?(virt = Concrete) ?(params = []) name expr = { pci_virt = virt; pci_params = params; pci_name = name; pci_expr = expr; - pci_attributes = attrs; + pci_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pci_loc = loc; } end module Type = struct let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) ?(params = []) ?(cstrs = []) ?(kind = Ptype_abstract) @@ -360,65 +397,73 @@ module Type = struct ptype_kind = kind; ptype_private = priv; ptype_manifest = manifest; - ptype_attributes = attrs; + ptype_attributes = + add_text_attrs text (add_docs_attrs docs attrs); ptype_loc = loc; } - let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = []) ?res name = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(args = []) ?res name = { pcd_name = name; pcd_args = args; pcd_res = res; pcd_loc = loc; - pcd_attributes = attrs; + pcd_attributes = add_info_attrs info attrs; } - let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ = + let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(mut = Immutable) name typ = { pld_name = name; pld_mutable = mut; pld_type = typ; pld_loc = loc; - pld_attributes = attrs; + pld_attributes = add_info_attrs info attrs; } + end (** Type extensions *) module Te = struct - let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = + let mk ?(attrs = []) ?(docs = empty_docs) + ?(params = []) ?(priv = Public) path constructors = { ptyext_path = path; ptyext_params = params; ptyext_constructors = constructors; ptyext_private = priv; - ptyext_attributes = attrs; + ptyext_attributes = add_docs_attrs docs attrs; } - let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + let constructor ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name kind = { pext_name = name; pext_kind = kind; pext_loc = loc; - pext_attributes = attrs; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - let decl ?(loc = !default_loc) ?(attrs = []) ?(args = []) ?res name = + let decl ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) ?(args = []) ?res name = { pext_name = name; pext_kind = Pext_decl(args, res); pext_loc = loc; - pext_attributes = attrs; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + let rebind ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name lid = { pext_name = name; pext_kind = Pext_rebind lid; pext_loc = loc; - pext_attributes = attrs; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } -end +end module Csig = struct let mk self fields = diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index b9b04f822354..4dc96169f66e 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -14,6 +14,7 @@ open Parsetree open Asttypes +open Docstrings type lid = Longident.t loc type str = string loc @@ -24,6 +25,7 @@ type attrs = attribute list val default_loc: loc ref (** Default value for all optional location arguments. *) + val with_default_loc: loc -> (unit -> 'a) -> 'a (** Set the [default_loc] within the scope of the execution of the provided function. *) @@ -146,27 +148,38 @@ module Exp: (** Value declarations *) module Val: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?prim:string list -> str -> core_type -> value_description + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + ?prim:string list -> str -> core_type -> value_description end (** Type declarations *) module Type: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list -> ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?args:core_type list -> ?res:core_type -> str -> constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?mut:mutable_flag -> str -> core_type -> label_declaration + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> + type_declaration + + val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?args:core_type list -> ?res:core_type -> str -> constructor_declaration + val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?mut:mutable_flag -> str -> core_type -> label_declaration end (** Type extensions *) module Te: sig - val mk: ?attrs:attrs -> ?params:(core_type * variance) list -> ?priv:private_flag -> lid -> extension_constructor list -> type_extension + val mk: ?attrs:attrs -> ?docs:docs -> + ?params:(core_type * variance) list -> ?priv:private_flag -> + lid -> extension_constructor list -> type_extension - val constructor: ?loc:loc -> ?attrs:attrs -> str -> extension_constructor_kind -> extension_constructor + val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> extension_constructor_kind -> extension_constructor - val decl: ?loc:loc -> ?attrs:attrs -> ?args:core_type list -> ?res:core_type -> str -> extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor + val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + ?args:core_type list -> ?res:core_type -> str -> extension_constructor + val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> lid -> extension_constructor end (** {2 Module language} *) @@ -221,6 +234,7 @@ module Sig: val class_type: ?loc:loc -> class_type_declaration list -> signature_item val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item val attribute: ?loc:loc -> attribute -> signature_item + val text: text -> signature_item list end (** Structure items *) @@ -243,43 +257,49 @@ module Str: val include_: ?loc:loc -> include_declaration -> structure_item val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item val attribute: ?loc:loc -> attribute -> structure_item + val text: text -> structure_item list end (** Module declarations *) module Md: sig - val mk: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_declaration + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str -> module_type -> module_declaration end (** Module type declarations *) module Mtd: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?typ:module_type -> str -> module_type_declaration + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?typ:module_type -> str -> module_type_declaration end (** Module bindings *) module Mb: sig - val mk: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str -> module_expr -> module_binding end (* Opens *) module Opn: sig - val mk: ?loc: loc -> ?attrs:attrs -> ?override:override_flag -> lid -> open_description + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> + ?override:override_flag -> lid -> open_description end (* Includes *) module Incl: sig - val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos end (** Value bindings *) module Vb: sig - val mk: ?loc: loc -> ?attrs:attrs -> pattern -> expression -> value_binding + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + pattern -> expression -> value_binding end @@ -300,7 +320,8 @@ module Cty: (** Class type fields *) module Ctf: sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_field_desc -> class_type_field + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + class_type_field_desc -> class_type_field val attr: class_type_field -> attribute -> class_type_field val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field @@ -309,6 +330,7 @@ module Ctf: val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field val attribute: ?loc:loc -> attribute -> class_type_field + val text: text -> class_type_field list end (** Class expressions *) @@ -329,7 +351,7 @@ module Cl: (** Class fields *) module Cf: sig - val mk: ?loc:loc -> ?attrs:attrs -> class_field_desc -> class_field + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> class_field val attr: class_field -> attribute -> class_field val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> string option -> class_field @@ -339,15 +361,19 @@ module Cf: val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field val attribute: ?loc:loc -> attribute -> class_field + val text: text -> class_field list val virtual_: core_type -> class_field_kind val concrete: override_flag -> expression -> class_field_kind + end (** Classes *) module Ci: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?virt:virtual_flag -> ?params:(core_type * variance) list -> str -> 'a -> 'a class_infos + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?virt:virtual_flag -> ?params:(core_type * variance) list -> + str -> 'a -> 'a class_infos end (** Class signatures *) diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml new file mode 100644 index 000000000000..389f6cf75cbe --- /dev/null +++ b/parsing/docstrings.ml @@ -0,0 +1,344 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Location + +(* Docstrings *) + +(* A docstring is "attached" if it has been inserted in the AST. This + is used for generating unexpected docstring warnings. *) +type ds_attached = + | Unattached (* Not yet attached anything.*) + | Info (* Attached to a field or constructor. *) + | Docs (* Attached to an item or as floating text. *) + +(* A docstring is "associated" with an item if there are no blank lines between + them. This is used for generating docstring ambiguity warnings. *) +type ds_associated = + | Zero (* Not associated with an item *) + | One (* Associated with one item *) + | Many (* Associated with multiple items (ambiguity) *) + +type docstring = + { ds_body: string; + ds_loc: Location.t; + mutable ds_attached: ds_attached; + mutable ds_associated: ds_associated; } + +(* List of docstrings *) + +let docstrings : docstring list ref = ref [] + +(* Warn for unused and ambiguous docstrings *) + +let warn_bad_docstrings () = + if Warnings.is_active (Warnings.Bad_docstring true) then begin + List.iter + (fun ds -> + match ds.ds_attached with + | Info -> () + | Unattached -> + prerr_warning ds.ds_loc (Warnings.Bad_docstring true) + | Docs -> + match ds.ds_associated with + | Zero | One -> () + | Many -> + prerr_warning ds.ds_loc (Warnings.Bad_docstring false)) + (List.rev !docstrings) +end + +(* Docstring constructors and descturctors *) + +let docstring body loc = + let ds = + { ds_body = body; + ds_loc = loc; + ds_attached = Unattached; + ds_associated = Zero; } + in + docstrings := ds :: !docstrings; + ds + +let docstring_body ds = ds.ds_body + +let docstring_loc ds = ds.ds_loc + +(* Docstrings attached to items *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +let empty_docs = { docs_pre = None; docs_post = None } + +let doc_loc = {txt = "ocaml.doc"; loc = Location.none} + +let docs_attr ds = + let open Asttypes in + let open Parsetree in + let exp = + { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None)); + pexp_loc = ds.ds_loc; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } + in + (doc_loc, PStr [item]) + +let add_docs_attrs docs attrs = + let attrs = + match docs.docs_pre with + | None -> attrs + | Some ds -> docs_attr ds :: attrs + in + let attrs = + match docs.docs_post with + | None -> attrs + | Some ds -> attrs @ [docs_attr ds] + in + attrs + +(* Docstrings attached to consturctors or fields *) + +type info = docstring option + +let empty_info = None + +let info_attr = docs_attr + +let add_info_attrs info attrs = + let attrs = + match info with + | None -> attrs + | Some ds -> attrs @ [info_attr ds] + in + attrs + +(* Docstrings not attached to a specifc item *) + +type text = docstring list + +let empty_text = [] + +let text_loc = {txt = "ocaml.text"; loc = Location.none} + +let text_attr ds = + let open Asttypes in + let open Parsetree in + let exp = + { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None)); + pexp_loc = ds.ds_loc; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } + in + (text_loc, PStr [item]) + +let add_text_attrs dsl attrs = + (List.map text_attr dsl) @ attrs + +(* Find the first non-info docstring in a list, attach it and return it *) +let get_docstring ~info dsl = + let rec loop = function + | [] -> None + | {ds_attached = Info; _} :: rest -> loop rest + | ds :: rest -> + ds.ds_attached <- if info then Info else Docs; + Some ds + in + loop dsl + +(* Find all the non-info docstrings in a list, attach them and return them *) +let get_docstrings dsl = + let rec loop acc = function + | [] -> List.rev acc + | {ds_attached = Info; _} :: rest -> loop acc rest + | ds :: rest -> + ds.ds_attached <- Docs; + loop (ds :: acc) rest + in + loop [] dsl + +(* "Associate" all the docstrings in a list *) +let associate_docstrings dsl = + List.iter + (fun ds -> + match ds.ds_associated with + | Zero -> ds.ds_associated <- One + | (One | Many) -> ds.ds_associated <- Many) + dsl + +(* Map from positions to pre docstrings *) + +let pre_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_table pos dsl + +let get_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl + with Not_found -> () + +(* Map from positions to post docstrings *) + +let post_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_table pos dsl + +let get_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl + with Not_found -> () + +let get_info pos = + try + let dsl = Hashtbl.find post_table pos in + get_docstring ~info:true dsl + with Not_found -> None + +(* Map from positions to floating docstrings *) + +let floating_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_floating_docstrings pos dsl = + if dsl <> [] then Hashtbl.add floating_table pos dsl + +let get_text pos = + try + let dsl = Hashtbl.find floating_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Maps from positions to extra docstrings *) + +let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_extra_table pos dsl + +let get_pre_extra_text pos = + try + let dsl = Hashtbl.find pre_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_extra_table pos dsl + +let get_post_extra_text pos = + try + let dsl = Hashtbl.find post_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Docstrings from parser actions *) + +let symbol_docs () = + { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); + docs_post = get_post_docs (Parsing.symbol_end_pos ()); } + +let symbol_docs_lazy () = + let p1 = Parsing.symbol_start_pos () in + let p2 = Parsing.symbol_end_pos () in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let rhs_docs pos1 pos2 = + { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); + docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } + +let rhs_docs_lazy pos1 pos2 = + let p1 = Parsing.rhs_start_pos pos1 in + let p2 = Parsing.rhs_end_pos pos2 in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let mark_symbol_docs () = + mark_pre_docs (Parsing.symbol_start_pos ()); + mark_post_docs (Parsing.symbol_end_pos ()) + +let mark_rhs_docs pos1 pos2 = + mark_pre_docs (Parsing.rhs_start_pos pos1); + mark_post_docs (Parsing.rhs_end_pos pos2) + +let symbol_info () = + get_info (Parsing.symbol_end_pos ()) + +let rhs_info pos = + get_info (Parsing.rhs_end_pos pos) + +let symbol_text () = + get_text (Parsing.symbol_start_pos ()) + +let symbol_text_lazy () = + let pos = Parsing.symbol_start_pos () in + lazy (get_text pos) + +let rhs_text pos = + get_text (Parsing.rhs_start_pos pos) + +let rhs_text_lazy pos = + let pos = Parsing.rhs_start_pos pos in + lazy (get_text pos) + +let symbol_pre_extra_text () = + get_pre_extra_text (Parsing.symbol_start_pos ()) + +let symbol_post_extra_text () = + get_post_extra_text (Parsing.symbol_end_pos ()) + +let rhs_pre_extra_text pos = + get_pre_extra_text (Parsing.rhs_start_pos pos) + +let rhs_post_extra_text pos = + get_post_extra_text (Parsing.rhs_end_pos pos) + + +(* (Re)Initialise all comment state *) + +let init () = + docstrings := []; + Hashtbl.reset pre_table; + Hashtbl.reset post_table; + Hashtbl.reset floating_table; + Hashtbl.reset pre_extra_table; + Hashtbl.reset post_extra_table + + + diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli new file mode 100644 index 000000000000..e8737850127f --- /dev/null +++ b/parsing/docstrings.mli @@ -0,0 +1,148 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(** (Re)Initialise all docstring state *) +val init : unit -> unit + +(** Emit warnings for unattached and ambiguous docstrings *) +val warn_bad_docstrings : unit -> unit + +(** {3 Docstrings} *) + +(** Documentation comments *) +type docstring + +(** Create a docstring *) +val docstring : string -> Location.t -> docstring + +(** Get the text of a docstring *) +val docstring_body : docstring -> string + +(** Get the location of a docstring *) +val docstring_loc : docstring -> Location.t + +(** {3 Set functions} + + These functions are used by the lexer to associate docstrings to + the locations of tokens. *) + +(** Docstrings immediately preceding a token *) +val set_pre_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following a token *) +val set_post_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings not immediately adjacent to a token *) +val set_floating_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following the token which precedes this one *) +val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately preceding the token which follows this one *) +val set_post_extra_docstrings : Lexing.position -> docstring list -> unit + +(** {3 Items} + + The {!docs} type represents documentation attached to an item. *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +val empty_docs : docs + +val docs_attr : docstring -> Parsetree.attribute + +(** Convert item documentation to attributes and add them to an + attribute list *) +val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the item documentation for the current symbol. This also + marks this documentation (for ambiguity warnings). *) +val symbol_docs : unit -> docs +val symbol_docs_lazy : unit -> docs Lazy.t + +(** Fetch the item documentation for the symbols between two + positions. This also marks this documentation (for ambiguity + warnings). *) +val rhs_docs : int -> int -> docs +val rhs_docs_lazy : int -> int -> docs Lazy.t + +(** Mark the item documentation for the current symbol (for ambiguity + warnings). *) +val mark_symbol_docs : unit -> unit + +(** Mark as associated the item documentation for the symbols between + two positions (for ambiguity warnings) *) +val mark_rhs_docs : int -> int -> unit + +(** {3 Fields and constructors} + + The {!info} type represents documentation attached to a field or + constructor. *) + +type info = docstring option + +val empty_info : info + +val info_attr : docstring -> Parsetree.attribute + +(** Convert field info to attributes and add them to an + attribute list *) +val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the field info for the current symbol. *) +val symbol_info : unit -> info + +(** Fetch the field info following the symbol at a given position. *) +val rhs_info : int -> info + +(** {3 Unattached comments} + + The {!text} type represents documentation which is not attached to + anything. *) + +type text = docstring list + +val empty_text : text + +val text_attr : docstring -> Parsetree.attribute + +(** Convert text to attributes and add them to an attribute list *) +val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the text preceding the current symbol. *) +val symbol_text : unit -> text +val symbol_text_lazy : unit -> text Lazy.t + +(** Fetch the text preceding the symbol at the given position. *) +val rhs_text : int -> text +val rhs_text_lazy : int -> text Lazy.t + +(** {3 Extra text} + + There may be additional text attached to the delimiters of a block + (e.g. [struct] and [end]). This is fetched by the following + functions, which are applied to the contents of the block rather + than the delimiters. *) + +(** Fetch additional text preceding the current symbol *) +val symbol_pre_extra_text : unit -> text + +(** Fetch additional text following the current symbol *) +val symbol_post_extra_text : unit -> text + +(** Fetch additional text preceding the symbol at the given position *) +val rhs_pre_extra_text : int -> text + +(** Fetch additional text following the symbol at the given position *) +val rhs_post_extra_text : int -> text diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 9898e97198eb..4878a36ebc9b 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -49,10 +49,7 @@ by the parser, as [preprocessor lexer lexbuf] where [lexer] is the lexing function. When a preprocessor is configured by calling [set_preprocessor], the lexer -changes its behavior: -- It accepts backslash-newline as a token-separating blank. -- It emits an EOL token for every newline except those preceeded by backslash - and those in strings or comments. +changes its behavior to accept backslash-newline as a token-separating blank. *) val set_preprocessor : diff --git a/parsing/lexer.mll b/parsing/lexer.mll index dfa604d2382f..de9106c06ab3 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -133,6 +133,16 @@ let is_in_string = ref false let in_string () = !is_in_string let print_warnings = ref true +let with_comment_buffer comment lexbuf = + let start_loc = Location.curr lexbuf in + comment_start_loc := [start_loc]; + reset_string_buffer (); + let end_loc = comment lexbuf in + let s = get_stored_string () in + reset_string_buffer (); + let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in + s, loc + (* To translate escape sequences *) let char_for_backslash = function @@ -219,6 +229,8 @@ let update_loc lexbuf file line absolute chars = let preprocessor = ref None +let escaped_newlines = ref false + (* Warn about Latin-1 characters used in idents *) let warn_latin1 lexbuf = @@ -226,6 +238,17 @@ let warn_latin1 lexbuf = (Warnings.Deprecated "ISO-Latin1 characters in identifiers") ;; +let comment_list = ref [] + +let add_comment com = + comment_list := com :: !comment_list + +let add_docstring_comment ds = + let com = (Docstrings.docstring_body ds, Docstrings.docstring_loc ds) in + add_comment com + +let comments () = List.rev !comment_list + (* Error report *) open Format @@ -288,19 +311,14 @@ let float_literal = rule token = parse | "\\" newline { - match !preprocessor with - | None -> + if not !escaped_newlines then raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)) - | Some _ -> - update_loc lexbuf None 1 false 0; - token lexbuf } + Location.curr lexbuf)); + update_loc lexbuf None 1 false 0; + token lexbuf } | newline { update_loc lexbuf None 1 false 0; - match !preprocessor with - | None -> token lexbuf - | Some _ -> EOL - } + EOL } | blank + { token lexbuf } | "_" @@ -387,26 +405,27 @@ rule token = parse raise (Error(Illegal_escape esc, Location.curr lexbuf)) } | "(*" - { let start_loc = Location.curr lexbuf in - comment_start_loc := [start_loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - COMMENT (s, { start_loc with - Location.loc_end = end_loc.Location.loc_end }) - } + { let s, loc = with_comment_buffer comment lexbuf in + COMMENT (s, loc) } + | "(**" + { let s, loc = with_comment_buffer comment lexbuf in + DOCSTRING (Docstrings.docstring s loc) } + | "(**" ('*'+) as stars + { let s, loc = + with_comment_buffer + (fun lexbuf -> + store_string ("*" ^ stars); + comment lexbuf) + lexbuf + in + COMMENT (s, loc) } | "(*)" - { let loc = Location.curr lexbuf in - if !print_warnings then - Location.prerr_warning loc Warnings.Comment_start; - comment_start_loc := [loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end }) - } + { if !print_warnings then + Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; + let s, loc = with_comment_buffer comment lexbuf in + COMMENT (s, loc) } + | "(*" ('*'*) as stars "*)" + { COMMENT (stars, Location.curr lexbuf) } | "*)" { let loc = Location.curr lexbuf in Location.prerr_warning loc Warnings.Comment_not_end; @@ -657,24 +676,94 @@ and skip_sharp_bang = parse | None -> token lexbuf | Some (_init, preprocess) -> preprocess token lexbuf - let last_comments = ref [] - let rec token lexbuf = - match token_with_comments lexbuf with - COMMENT (s, comment_loc) -> - last_comments := (s, comment_loc) :: !last_comments; - token lexbuf - | tok -> tok - let comments () = List.rev !last_comments + type newline_state = + | NoLine (* There have been no blank lines yet. *) + | NewLine + (* There have been no blank lines, and the previous + token was a newline. *) + | BlankLine (* There have been blank lines. *) + + type doc_state = + | Initial (* There have been no docstrings yet *) + | After of docstring list + (* There have been docstrings, none of which were + preceeded by a blank line *) + | Before of docstring list * docstring list * docstring list + (* There have been docstrings, some of which were + preceeded by a blank line *) + + and docstring = Docstrings.docstring + + let token lexbuf = + let post_pos = lexeme_end_p lexbuf in + let attach lines docs pre_pos = + let open Docstrings in + match docs, lines with + | Initial, _ -> () + | After a, (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_pre_docstrings pre_pos a; + | After a, BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_pre_extra_docstrings pre_pos (List.rev a) + | Before(a, f, b), (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos (List.rev b); + set_floating_docstrings pre_pos (List.rev f); + set_pre_extra_docstrings pre_pos (List.rev a); + set_pre_docstrings pre_pos b + | Before(a, f, b), BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_floating_docstrings pre_pos (List.rev_append f (List.rev b)); + set_pre_extra_docstrings pre_pos (List.rev a) + in + let rec loop lines docs lexbuf = + match token_with_comments lexbuf with + | COMMENT (s, loc) -> + add_comment (s, loc); + let lines' = + match lines with + | NoLine -> NoLine + | NewLine -> NoLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | EOL -> + let lines' = + match lines with + | NoLine -> NewLine + | NewLine -> BlankLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | DOCSTRING doc -> + add_docstring_comment doc; + let docs' = + match docs, lines with + | Initial, (NoLine | NewLine) -> After [doc] + | Initial, BlankLine -> Before([], [], [doc]) + | After a, (NoLine | NewLine) -> After (doc :: a) + | After a, BlankLine -> Before (a, [], [doc]) + | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) + | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) + in + loop NoLine docs' lexbuf + | tok -> + attach lines docs (lexeme_start_p lexbuf); + tok + in + loop NoLine Initial lexbuf let init () = is_in_string := false; - last_comments := []; comment_start_loc := []; + comment_list := []; match !preprocessor with | None -> () | Some (init, _preprocess) -> init () let set_preprocessor init preprocess = + escaped_newlines := true; preprocessor := Some (init, preprocess) } diff --git a/parsing/location.mli b/parsing/location.mli index 158fd671dac1..de53223412e7 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -29,11 +29,14 @@ type t = { val none : t (** An arbitrary value of type [t]; describes an empty ghost range. *) -val in_file : string -> t;; + +val in_file : string -> t (** Return an empty ghost range located in a given file. *) + val init : Lexing.lexbuf -> string -> unit (** Set the file name and line number of the [lexbuf] to be the start of the named file. *) + val curr : Lexing.lexbuf -> t (** Get the location of the current token from the [lexbuf]. *) diff --git a/parsing/parse.ml b/parsing/parse.ml index 2f4926ff88b8..0941bf803b3b 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -34,9 +34,11 @@ let maybe_skip_phrase lexbuf = let wrap parsing_fun lexbuf = try + Docstrings.init (); Lexer.init (); let ast = parsing_fun Lexer.token lexbuf in Parsing.clear_parser(); + Docstrings.warn_bad_docstrings (); ast with | Lexer.Error(Lexer.Illegal_character _, _) as err diff --git a/parsing/parser.mly b/parsing/parser.mly index 27290adfa3fb..98cd34abc9b4 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -18,6 +18,7 @@ open Asttypes open Longident open Parsetree open Ast_helper +open Docstrings let mktyp d = Typ.mk ~loc:(symbol_rloc()) d let mkpat d = Pat.mk ~loc:(symbol_rloc()) d @@ -28,8 +29,10 @@ let mkmod d = Mod.mk ~loc:(symbol_rloc()) d let mkstr d = Str.mk ~loc:(symbol_rloc()) d let mkclass d = Cl.mk ~loc:(symbol_rloc()) d let mkcty d = Cty.mk ~loc:(symbol_rloc()) d -let mkctf d = Ctf.mk ~loc:(symbol_rloc()) d -let mkcf d = Cf.mk ~loc:(symbol_rloc()) d +let mkctf ?attrs ?docs d = + Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d +let mkcf ?attrs ?docs d = + Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d let mkrhs rhs pos = mkloc rhs (rhs_loc pos) let mkoption d = @@ -283,11 +286,23 @@ let wrap_exp_attrs body (ext, attrs) = let mkexp_attrs d attrs = wrap_exp_attrs (mkexp d) attrs -let mkcf_attrs d attrs = - Cf.mk ~loc:(symbol_rloc()) ~attrs d +let text_str pos = Str.text (rhs_text pos) +let text_sig pos = Sig.text (rhs_text pos) +let text_cstr pos = Cf.text (rhs_text pos) +let text_csig pos = Ctf.text (rhs_text pos) +let text_def pos = [Ptop_def (Str.text (rhs_text pos))] -let mkctf_attrs d attrs = - Ctf.mk ~loc:(symbol_rloc()) ~attrs d +let extra_text text pos items = + let pre_extras = rhs_pre_extra_text pos in + let post_extras = rhs_post_extra_text pos in + text pre_extras @ items @ text post_extras + +let extra_str pos items = extra_text Str.text pos items +let extra_sig pos items = extra_text Sig.text pos items +let extra_cstr pos items = extra_text Cf.text pos items +let extra_csig pos items = extra_text Ctf.text pos items +let extra_def pos items = + extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items let add_nonrec rf attrs pos = match rf with @@ -300,6 +315,8 @@ type let_binding = { lb_pattern: pattern; lb_expression: expression; lb_attributes: attributes; + lb_docs: docs Lazy.t; + lb_text: text Lazy.t; lb_loc: Location.t; } type let_bindings = @@ -313,6 +330,8 @@ let mklb (p, e) attrs = { lb_pattern = p; lb_expression = e; lb_attributes = attrs; + lb_docs = symbol_docs_lazy (); + lb_text = symbol_text_lazy (); lb_loc = symbol_rloc (); } let mklbs (ext, attrs) rf lb = @@ -336,6 +355,8 @@ let val_of_let_bindings lbs = List.map (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ~docs:(Lazy.force lb.lb_docs) + ~text:(Lazy.force lb.lb_text) lb.lb_pattern lb.lb_expression) bindings in @@ -497,6 +518,7 @@ let class_of_let_bindings lbs body = %token WHILE %token WITH %token COMMENT +%token DOCSTRING %token EOL @@ -586,38 +608,52 @@ The precedences must be listed from low to high. /* Entry points */ implementation: - structure EOF { $1 } + structure EOF { extra_str 1 $1 } ; interface: - signature EOF { $1 } + signature EOF { extra_sig 1 $1 } ; toplevel_phrase: - top_structure SEMISEMI { Ptop_def $1 } + top_structure SEMISEMI { Ptop_def (extra_str 1 $1) } | toplevel_directive SEMISEMI { $1 } | EOF { raise End_of_file } ; top_structure: - seq_expr post_item_attributes { [mkstrexp $1 $2] } - | top_structure_tail { $1 } + seq_expr post_item_attributes + { (text_str 1) @ [mkstrexp $1 $2] } + | top_structure_tail + { $1 } ; top_structure_tail: /* empty */ { [] } - | structure_item top_structure_tail { $1 :: $2 } + | structure_item top_structure_tail { (text_str 1) @ $1 :: $2 } ; use_file: + use_file_body { extra_def 1 $1 } +; +use_file_body: use_file_tail { $1 } | seq_expr post_item_attributes use_file_tail - { Ptop_def[mkstrexp $1 $2] :: $3 } + { (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 } ; use_file_tail: - EOF { [] } - | SEMISEMI EOF { [] } + EOF + { [] } + | SEMISEMI EOF + { text_def 1 } | SEMISEMI seq_expr post_item_attributes use_file_tail - { Ptop_def[mkstrexp $2 $3] :: $4 } - | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 } - | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 } - | structure_item use_file_tail { Ptop_def[$1] :: $2 } - | toplevel_directive use_file_tail { $1 :: $2 } + { mark_rhs_docs 2 3; + (text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp $2 $3] :: $4 } + | SEMISEMI structure_item use_file_tail + { (text_def 1) @ (text_def 2) @ Ptop_def[$2] :: $3 } + | SEMISEMI toplevel_directive use_file_tail + { mark_rhs_docs 2 3; + (text_def 1) @ (text_def 2) @ $2 :: $3 } + | structure_item use_file_tail + { (text_def 1) @ Ptop_def[$1] :: $2 } + | toplevel_directive use_file_tail + { mark_rhs_docs 1 1; + (text_def 1) @ $1 :: $2 } ; parse_core_type: core_type EOF { $1 } @@ -654,7 +690,7 @@ module_expr: mod_longident { mkmod(Pmod_ident (mkrhs $1 1)) } | STRUCT structure END - { mkmod(Pmod_structure($2)) } + { mkmod(Pmod_structure(extra_str 2 $2)) } | STRUCT structure error { unclosed "struct" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_expr @@ -699,13 +735,15 @@ module_expr: ; structure: - seq_expr post_item_attributes structure_tail { mkstrexp $1 $2 :: $3 } + seq_expr post_item_attributes structure_tail + { mark_rhs_docs 1 2; + (text_str 1) @ mkstrexp $1 $2 :: $3 } | structure_tail { $1 } ; structure_tail: /* empty */ { [] } - | SEMISEMI structure { $2 } - | structure_item structure_tail { $1 :: $2 } + | SEMISEMI structure { (text_str 1) @ $2 } + | structure_item structure_tail { (text_str 1) @ $1 :: $2 } ; structure_item: let_bindings @@ -732,9 +770,10 @@ structure_item: | str_include_statement { mkstr(Pstr_include $1) } | item_extension post_item_attributes - { mkstr(Pstr_extension ($1, $2)) } + { mkstr(Pstr_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } | floating_attribute - { mkstr(Pstr_attribute $1) } + { mark_symbol_docs (); + mkstr(Pstr_attribute $1) } ; str_include_statement: INCLUDE module_expr post_item_attributes @@ -750,7 +789,8 @@ module_binding_body: ; module_binding: MODULE UIDENT module_binding_body post_item_attributes - { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) } + { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; rec_module_bindings: rec_module_binding { [$1] } @@ -758,11 +798,13 @@ rec_module_bindings: ; rec_module_binding: MODULE REC UIDENT module_binding_body post_item_attributes - { Mb.mk (mkrhs $3 3) $4 ~attrs:$5 ~loc:(symbol_rloc ()) } + { Mb.mk (mkrhs $3 3) $4 ~attrs:$5 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; and_module_binding: AND UIDENT module_binding_body post_item_attributes - { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) } + { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; /* Module types */ @@ -771,7 +813,7 @@ module_type: mty_longident { mkmty(Pmty_ident (mkrhs $1 1)) } | SIG signature END - { mkmty(Pmty_signature $2) } + { mkmty(Pmty_signature (extra_sig 2 $2)) } | SIG signature error { unclosed "sig" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_type @@ -795,8 +837,8 @@ module_type: ; signature: /* empty */ { [] } - | SEMISEMI signature { $2 } - | signature_item signature { $1 :: $2 } + | SEMISEMI signature { (text_sig 1) @ $2 } + | signature_item signature { (text_sig 1) @ $1 :: $2 } ; signature_item: value_description @@ -826,17 +868,20 @@ signature_item: | class_type_declarations { mksig(Psig_class_type (List.rev $1)) } | item_extension post_item_attributes - { mksig(Psig_extension ($1, $2)) } + { mksig(Psig_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } | floating_attribute - { mksig(Psig_attribute $1) } + { mark_symbol_docs (); + mksig(Psig_attribute $1) } ; open_statement: | OPEN override_flag mod_longident post_item_attributes - { Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 ~loc:(symbol_rloc()) } + { Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; sig_include_statement: INCLUDE module_type post_item_attributes %prec below_WITH - { Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()) } + { Incl.mk $2 ~attrs:$3 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; module_declaration_body: COLON module_type @@ -848,13 +893,14 @@ module_declaration_body: ; module_declaration: MODULE UIDENT module_declaration_body post_item_attributes - { Md.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc()) } + { Md.mk (mkrhs $2 2) $3 ~attrs:$4 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; module_alias: MODULE UIDENT EQUAL mod_longident post_item_attributes { Md.mk (mkrhs $2 2) - (Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) - ~attrs:$5 ~loc:(symbol_rloc()) } + (Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; rec_module_declarations: rec_module_declaration { [$1] } @@ -862,11 +908,13 @@ rec_module_declarations: ; rec_module_declaration: MODULE REC UIDENT COLON module_type post_item_attributes - { Md.mk (mkrhs $3 3) $5 ~attrs:$6 ~loc:(symbol_rloc()) } + { Md.mk (mkrhs $3 3) $5 ~attrs:$6 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; and_module_declaration: AND UIDENT COLON module_type post_item_attributes - { Md.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) } + { Md.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) + ~text:(symbol_text()) ~docs:(symbol_docs()) } ; module_type_declaration_body: /* empty */ { None } @@ -874,7 +922,8 @@ module_type_declaration_body: ; module_type_declaration: MODULE TYPE ident module_type_declaration_body post_item_attributes - { Mtd.mk (mkrhs $3 3) ?typ:$4 ~loc:(symbol_rloc()) ~attrs:$5 } + { Mtd.mk (mkrhs $3 3) ?typ:$4 ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; /* Class expressions */ @@ -885,14 +934,15 @@ class_declarations: class_declaration: CLASS virtual_flag class_type_parameters LIDENT class_fun_binding post_item_attributes - { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 - ~attrs:$6 ~loc:(symbol_rloc ()) } + { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 ~attrs:$6 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; and_class_declaration: AND virtual_flag class_type_parameters LIDENT class_fun_binding post_item_attributes { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 - ~attrs:$6 ~loc:(symbol_rloc ()) } + ~attrs:$6 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; class_fun_binding: EQUAL class_expr @@ -932,7 +982,7 @@ class_simple_expr: | class_longident { mkclass(Pcl_constr(mkrhs $1 1, [])) } | OBJECT class_structure END - { mkclass(Pcl_structure($2)) } + { mkclass(Pcl_structure $2) } | OBJECT class_structure error { unclosed "object" 1 "end" 3 } | LPAREN class_expr COLON class_type RPAREN @@ -945,8 +995,8 @@ class_simple_expr: { unclosed "(" 1 ")" 3 } ; class_structure: - class_self_pattern class_fields - { Cstr.mk $1 (List.rev $2) } + | class_self_pattern class_fields + { Cstr.mk $1 (extra_cstr 2 (List.rev $2)) } ; class_self_pattern: LPAREN pattern RPAREN @@ -960,23 +1010,24 @@ class_fields: /* empty */ { [] } | class_fields class_field - { $2 :: $1 } + { $2 :: (text_cstr 2) @ $1 } ; class_field: | INHERIT override_flag class_expr parent_binder post_item_attributes - { mkcf_attrs (Pcf_inherit ($2, $3, $4)) $5 } + { mkcf (Pcf_inherit ($2, $3, $4)) ~attrs:$5 ~docs:(symbol_docs ()) } | VAL value post_item_attributes - { mkcf_attrs (Pcf_val $2) $3 } + { mkcf (Pcf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) } | METHOD method_ post_item_attributes - { mkcf_attrs (Pcf_method $2) $3 } + { mkcf (Pcf_method $2) ~attrs:$3 ~docs:(symbol_docs ()) } | CONSTRAINT constrain_field post_item_attributes - { mkcf_attrs (Pcf_constraint $2) $3 } + { mkcf (Pcf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) } | INITIALIZER seq_expr post_item_attributes - { mkcf_attrs (Pcf_initializer $2) $3 } + { mkcf (Pcf_initializer $2) ~attrs:$3 ~docs:(symbol_docs ()) } | item_extension post_item_attributes - { mkcf_attrs (Pcf_extension $1) $2 } + { mkcf (Pcf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } | floating_attribute - { mkcf (Pcf_attribute $1) } + { mark_symbol_docs (); + mkcf (Pcf_attribute $1) } ; parent_binder: AS LIDENT @@ -1051,7 +1102,7 @@ class_signature: ; class_sig_body: class_self_type class_sig_fields - { Csig.mk $1 (List.rev $2) } + { Csig.mk $1 (extra_csig 2 (List.rev $2)) } ; class_self_type: LPAREN core_type RPAREN @@ -1061,24 +1112,25 @@ class_self_type: ; class_sig_fields: /* empty */ { [] } -| class_sig_fields class_sig_field { $2 :: $1 } +| class_sig_fields class_sig_field { $2 :: (text_csig 2) @ $1 } ; class_sig_field: INHERIT class_signature post_item_attributes - { mkctf_attrs (Pctf_inherit $2) $3 } + { mkctf (Pctf_inherit $2) ~attrs:$3 ~docs:(symbol_docs ()) } | VAL value_type post_item_attributes - { mkctf_attrs (Pctf_val $2) $3 } + { mkctf (Pctf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) } | METHOD private_virtual_flags label COLON poly_type post_item_attributes { let (p, v) = $2 in - mkctf_attrs (Pctf_method ($3, p, v, $5)) $6 + mkctf (Pctf_method ($3, p, v, $5)) ~attrs:$6 ~docs:(symbol_docs ()) } | CONSTRAINT constrain_field post_item_attributes - { mkctf_attrs (Pctf_constraint $2) $3 } + { mkctf (Pctf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) } | item_extension post_item_attributes - { mkctf_attrs (Pctf_extension $1) $2 } + { mkctf (Pctf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } | floating_attribute - { mkctf(Pctf_attribute $1) } + { mark_symbol_docs (); + mkctf(Pctf_attribute $1) } ; value_type: VIRTUAL mutable_flag label COLON core_type @@ -1101,14 +1153,15 @@ class_descriptions: class_description: CLASS virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes - { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 - ~attrs:$7 ~loc:(symbol_rloc ()) } + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; and_class_description: AND virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 - ~attrs:$7 ~loc:(symbol_rloc ()) } + ~attrs:$7 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; class_type_declarations: class_type_declaration { [$1] } @@ -1117,14 +1170,15 @@ class_type_declarations: class_type_declaration: CLASS TYPE virtual_flag class_type_parameters LIDENT EQUAL class_signature post_item_attributes - { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 - ~attrs:$8 ~loc:(symbol_rloc ()) } + { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:$8 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; and_class_type_declaration: AND virtual_flag class_type_parameters LIDENT EQUAL class_signature post_item_attributes { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 - ~attrs:$7 ~loc:(symbol_rloc ()) } + ~attrs:$7 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; /* Core expressions */ @@ -1634,7 +1688,8 @@ lbl_pattern: value_description: VAL val_ident COLON core_type post_item_attributes - { Val.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) } + { Val.mk (mkrhs $2 2) $4 ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; /* Primitive declarations */ @@ -1646,7 +1701,8 @@ primitive_declaration_body: primitive_declaration: EXTERNAL val_ident COLON core_type EQUAL primitive_declaration_body post_item_attributes - { Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 ~loc:(symbol_rloc ()) } + { Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; /* Type declarations */ @@ -1661,14 +1717,16 @@ type_declaration: post_item_attributes { let (kind, priv, manifest) = $5 in Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) ~kind - ~priv ?manifest ~attrs:(add_nonrec $2 $7 2) ~loc:(symbol_rloc ()) } + ~priv ?manifest ~attrs:(add_nonrec $2 $7 2) + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; and_type_declaration: AND optional_type_parameters LIDENT type_kind constraints post_item_attributes { let (kind, priv, manifest) = $4 in Type.mk (mkrhs $3 3) ~params:$2 ~cstrs:(List.rev $5) - ~kind ~priv ?manifest ~attrs:$6 ~loc:(symbol_rloc ()) } + ~kind ~priv ?manifest ~attrs:$6 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; constraints: constraints CONSTRAINT constrain { $3 :: $1 } @@ -1743,29 +1801,31 @@ constructor_declaration: | constr_ident generalized_constructor_arguments attributes { let args,res = $2 in - Type.constructor (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$3 + Type.constructor (mkrhs $1 1) ~args ?res ~attrs:$3 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; bar_constructor_declaration: | BAR constr_ident generalized_constructor_arguments attributes { let args,res = $3 in - Type.constructor (mkrhs $2 2) ~args ?res ~loc:(symbol_rloc()) ~attrs:$4 + Type.constructor (mkrhs $2 2) ~args ?res ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; str_exception_declaration: | sig_exception_declaration { $1 } | EXCEPTION constr_ident EQUAL constr_longident attributes post_item_attributes - { Te.rebind (mkrhs $2 2) (mkrhs $4 4) - ~loc:(symbol_rloc()) ~attrs:($5 @ $6) } + { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:($5 @ $6) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; sig_exception_declaration: | EXCEPTION constr_ident generalized_constructor_arguments attributes post_item_attributes { let args, res = $3 in - Te.decl (mkrhs $2 2) ~args ?res - ~loc:(symbol_rloc()) ~attrs:($4 @ $5) } + Te.decl (mkrhs $2 2) ~args ?res ~attrs:($4 @ $5) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; generalized_constructor_arguments: /*empty*/ { ([],None) } @@ -1786,13 +1846,15 @@ label_declarations: label_declaration: mutable_flag label COLON poly_type_no_attr attributes { - Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 ~loc:(symbol_rloc()) + Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; label_declaration_semi: - mutable_flag label COLON poly_type_no_attr attributes SEMI + mutable_flag label COLON poly_type_no_attr attributes SEMI attributes { - Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 ~loc:(symbol_rloc()) + Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7) + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; @@ -1802,13 +1864,15 @@ str_type_extension: TYPE nonrec_flag optional_type_parameters type_longident PLUSEQ private_flag str_extension_constructors post_item_attributes { if $2 <> Recursive then not_expecting 2 "nonrec flag"; - Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 ~attrs:$8 } + Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 + ~attrs:$8 ~docs:(symbol_docs ()) } ; sig_type_extension: TYPE nonrec_flag optional_type_parameters type_longident PLUSEQ private_flag sig_extension_constructors post_item_attributes { if $2 <> Recursive then not_expecting 2 "nonrec flag"; - Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 ~attrs:$8 } + Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 + ~attrs:$8 ~docs:(symbol_docs ()) } ; str_extension_constructors: extension_constructor_declaration { [$1] } @@ -1829,20 +1893,24 @@ sig_extension_constructors: extension_constructor_declaration: | constr_ident generalized_constructor_arguments attributes { let args, res = $2 in - Te.decl (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$3 } + Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; bar_extension_constructor_declaration: | BAR constr_ident generalized_constructor_arguments attributes { let args, res = $3 in - Te.decl (mkrhs $2 2) ~args ?res ~loc:(symbol_rloc()) ~attrs:$4 } + Te.decl (mkrhs $2 2) ~args ?res ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; extension_constructor_rebind: | constr_ident EQUAL constr_longident attributes - { Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~loc:(symbol_rloc()) ~attrs:$4 } + { Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; bar_extension_constructor_rebind: | BAR constr_ident EQUAL constr_longident attributes - { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~loc:(symbol_rloc()) ~attrs:$5 } + { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:$5 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; /* "with" constraints (additional type equations over signature components) */ diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 2c92c25b9d0f..183a07eef914 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -1807,7 +1807,7 @@ let fmt_ebb_of_string ?legacy_behavior str = let legacy_behavior = match legacy_behavior with | Some flag -> flag | None -> true - (** When this flag is enabled, the format parser tries to behave as + (* When this flag is enabled, the format parser tries to behave as the <4.02 implementations, in particular it ignores most benine nonsensical format. When the flag is disabled, it will reject any format that is not accepted by the specification. diff --git a/stdlib/format.mli b/stdlib/format.mli index 541ffbe390b4..05e153b2e864 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -74,7 +74,7 @@ (** {6 Boxes} *) -val open_box : int -> unit;; +val open_box : int -> unit (** [open_box d] opens a new pretty-printing box with offset [d]. This box is the general purpose pretty-printing box. @@ -86,41 +86,41 @@ val open_box : int -> unit;; When a new line is printed in the box, [d] is added to the current indentation. *) -val close_box : unit -> unit;; +val close_box : unit -> unit (** Closes the most recently opened pretty-printing box. *) (** {6 Formatting functions} *) -val print_string : string -> unit;; +val print_string : string -> unit (** [print_string str] prints [str] in the current box. *) -val print_as : int -> string -> unit;; +val print_as : int -> string -> unit (** [print_as len str] prints [str] in the current box. The pretty-printer formats [str] as if it were of length [len]. *) -val print_int : int -> unit;; +val print_int : int -> unit (** Prints an integer in the current box. *) -val print_float : float -> unit;; +val print_float : float -> unit (** Prints a floating point number in the current box. *) -val print_char : char -> unit;; +val print_char : char -> unit (** Prints a character in the current box. *) -val print_bool : bool -> unit;; +val print_bool : bool -> unit (** Prints a boolean in the current box. *) (** {6 Break hints} *) -val print_space : unit -> unit;; +val print_space : unit -> unit (** [print_space ()] is used to separate items (typically to print a space between two words). It indicates that the line may be split at this point. It either prints one space or splits the line. It is equivalent to [print_break 1 0]. *) -val print_cut : unit -> unit;; +val print_cut : unit -> unit (** [print_cut ()] is used to mark a good break position. It indicates that the line may be split at this point. It either prints nothing or splits the line. @@ -128,7 +128,7 @@ val print_cut : unit -> unit;; point, without printing spaces or adding indentation. It is equivalent to [print_break 0 0]. *) -val print_break : int -> int -> unit;; +val print_break : int -> int -> unit (** Inserts a break hint in a pretty-printing box. [print_break nspaces offset] indicates that the line may be split (a newline character is printed) at this point, @@ -138,25 +138,25 @@ val print_break : int -> int -> unit;; the current indentation. If the line is not split, [nspaces] spaces are printed. *) -val print_flush : unit -> unit;; +val print_flush : unit -> unit (** Flushes the pretty printer: all opened boxes are closed, and all pending text is displayed. *) -val print_newline : unit -> unit;; +val print_newline : unit -> unit (** Equivalent to [print_flush] followed by a new line. *) -val force_newline : unit -> unit;; +val force_newline : unit -> unit (** Forces a newline in the current box. Not the normal way of pretty-printing, you should prefer break hints. *) -val print_if_newline : unit -> unit;; +val print_if_newline : unit -> unit (** Executes the next formatting command if the preceding line has just been split. Otherwise, ignore the next formatting command. *) (** {6 Margin} *) -val set_margin : int -> unit;; +val set_margin : int -> unit (** [set_margin d] sets the value of the right margin to [d] (in characters): this value is used to detect line overflows that leads to split lines. @@ -164,12 +164,12 @@ val set_margin : int -> unit;; If [d] is too large, the right margin is set to the maximum admissible value (which is greater than [10^9]). *) -val get_margin : unit -> int;; +val get_margin : unit -> int (** Returns the position of the right margin. *) (** {6 Maximum indentation limit} *) -val set_max_indent : int -> unit;; +val set_max_indent : int -> unit (** [set_max_indent d] sets the value of the maximum indentation limit to [d] (in characters): once this limit is reached, boxes are rejected to the left, @@ -178,32 +178,32 @@ val set_max_indent : int -> unit;; If [d] is too large, the limit is set to the maximum admissible value (which is greater than [10^9]). *) -val get_max_indent : unit -> int;; +val get_max_indent : unit -> int (** Return the value of the maximum indentation limit (in characters). *) (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *) -val set_max_boxes : int -> unit;; +val set_max_boxes : int -> unit (** [set_max_boxes max] sets the maximum number of boxes simultaneously opened. Material inside boxes nested deeper is printed as an ellipsis (more precisely as the text returned by [get_ellipsis_text ()]). Nothing happens if [max] is smaller than 2. *) -val get_max_boxes : unit -> int;; +val get_max_boxes : unit -> int (** Returns the maximum number of boxes allowed before ellipsis. *) -val over_max_boxes : unit -> bool;; +val over_max_boxes : unit -> bool (** Tests if the maximum number of boxes allowed have already been opened. *) (** {6 Advanced formatting} *) -val open_hbox : unit -> unit;; +val open_hbox : unit -> unit (** [open_hbox ()] opens a new pretty-printing box. This box is 'horizontal': the line is not split in this box (new lines may still occur inside boxes nested deeper). *) -val open_vbox : int -> unit;; +val open_vbox : int -> unit (** [open_vbox d] opens a new pretty-printing box with offset [d]. This box is 'vertical': every break hint inside this @@ -211,7 +211,7 @@ val open_vbox : int -> unit;; When a new line is printed in the box, [d] is added to the current indentation. *) -val open_hvbox : int -> unit;; +val open_hvbox : int -> unit (** [open_hvbox d] opens a new pretty-printing box with offset [d]. This box is 'horizontal-vertical': it behaves as an @@ -220,7 +220,7 @@ val open_hvbox : int -> unit;; When a new line is printed in the box, [d] is added to the current indentation. *) -val open_hovbox : int -> unit;; +val open_hovbox : int -> unit (** [open_hovbox d] opens a new pretty-printing box with offset [d]. This box is 'horizontal or vertical': break hints @@ -231,13 +231,13 @@ val open_hovbox : int -> unit;; (** {6 Tabulations} *) -val open_tbox : unit -> unit;; +val open_tbox : unit -> unit (** Opens a tabulation box. *) -val close_tbox : unit -> unit;; +val close_tbox : unit -> unit (** Closes the most recently opened tabulation box. *) -val print_tbreak : int -> int -> unit;; +val print_tbreak : int -> int -> unit (** Break hint in a tabulation box. [print_tbreak spaces offset] moves the insertion point to the next tabulation ([spaces] being added to this position). @@ -249,24 +249,24 @@ val print_tbreak : int -> int -> unit;; If a new line is printed, [offset] is added to the current indentation. *) -val set_tab : unit -> unit;; +val set_tab : unit -> unit (** Sets a tabulation mark at the current insertion point. *) -val print_tab : unit -> unit;; +val print_tab : unit -> unit (** [print_tab ()] is equivalent to [print_tbreak 0 0]. *) (** {6 Ellipsis} *) -val set_ellipsis_text : string -> unit;; +val set_ellipsis_text : string -> unit (** Set the text of the ellipsis printed when too many boxes are opened (a single dot, [.], by default). *) -val get_ellipsis_text : unit -> string;; +val get_ellipsis_text : unit -> string (** Return the text of the ellipsis. *) (** {6:tags Semantics Tags} *) -type tag = string;; +type tag = string (** {i Semantics tags} (or simply {e tags}) are used to decorate printed entities for user's defined purposes, e.g. setting font and giving size @@ -315,38 +315,42 @@ type tag = string;; Tag marking and tag printing functions are user definable and can be set by calling [set_formatter_tag_functions]. *) -val open_tag : tag -> unit;; +val open_tag : tag -> unit (** [open_tag t] opens the tag named [t]; the [print_open_tag] function of the formatter is called with [t] as argument; the tag marker [mark_open_tag t] will be flushed into the output device of the formatter. *) -val close_tag : unit -> unit;; +val close_tag : unit -> unit (** [close_tag ()] closes the most recently opened tag [t]. In addition, the [print_close_tag] function of the formatter is called with [t] as argument. The marker [mark_close_tag t] will be flushed into the output device of the formatter. *) -val set_tags : bool -> unit;; +val set_tags : bool -> unit (** [set_tags b] turns on or off the treatment of tags (default is off). *) -val set_print_tags : bool -> unit;; -val set_mark_tags : bool -> unit;; -(** [set_print_tags b] turns on or off the printing of tags, while - [set_mark_tags b] turns on or off the output of tag markers. *) -val get_print_tags : unit -> bool;; -val get_mark_tags : unit -> bool;; -(** Return the current status of tags printing and tags marking. *) + +val set_print_tags : bool -> unit +(**[set_print_tags b] turns on or off the printing of tags. *) + +val set_mark_tags : bool -> unit +(** [set_mark_tags b] turns on or off the output of tag markers. *) + +val get_print_tags : unit -> bool +(** Return the current status of tags printing. *) + +val get_mark_tags : unit -> bool +(** Return the current status of tags marking. *) (** {6 Redirecting the standard formatter output} *) -val set_formatter_out_channel : Pervasives.out_channel -> unit;; +val set_formatter_out_channel : Pervasives.out_channel -> unit (** Redirect the pretty-printer output to the given channel. (All the output functions of the standard formatter are set to the default output functions printing to the given channel.) *) val set_formatter_output_functions : (string -> int -> int -> unit) -> (unit -> unit) -> unit -;; (** [set_formatter_output_functions out flush] redirects the pretty-printer output functions to the functions [out] and [flush]. @@ -362,7 +366,6 @@ val set_formatter_output_functions : val get_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) -;; (** Return the current output functions of the pretty-printer. *) (** {6:meaning Changing the meaning of standard formatter pretty printing} *) @@ -378,9 +381,9 @@ type formatter_out_functions = { out_newline : unit -> unit; out_spaces : int -> unit; } -;; -val set_formatter_out_functions : formatter_out_functions -> unit;; + +val set_formatter_out_functions : formatter_out_functions -> unit (** [set_formatter_out_functions f] Redirect the pretty-printer output to the functions [f.out_string] and [f.out_flush] as described in @@ -397,7 +400,7 @@ val set_formatter_out_functions : formatter_out_functions -> unit;; default values for [f.out_space] and [f.out_newline] are [f.out_string (String.make n ' ') 0 n] and [f.out_string "\n" 0 1]. *) -val get_formatter_out_functions : unit -> formatter_out_functions;; +val get_formatter_out_functions : unit -> formatter_out_functions (** Return the current output functions of the pretty-printer, including line breaking and indentation functions. Useful to record the current setting and restore it afterwards. *) @@ -410,7 +413,6 @@ type formatter_tag_functions = { print_open_tag : tag -> unit; print_close_tag : tag -> unit; } -;; (** The tag handling functions specific to a formatter: [mark] versions are the 'tag marking' functions that associate a string marker to a tag in order for the pretty-printing engine to flush @@ -418,7 +420,7 @@ type formatter_tag_functions = { [print] versions are the 'tag printing' functions that can perform regular printing when a tag is closed or opened. *) -val set_formatter_tag_functions : formatter_tag_functions -> unit;; +val set_formatter_tag_functions : formatter_tag_functions -> unit (** [set_formatter_tag_functions tag_funs] changes the meaning of opening and closing tags to use the functions in [tag_funs]. @@ -434,12 +436,12 @@ val set_formatter_tag_functions : formatter_tag_functions -> unit;; called at tag opening and tag closing time, to output regular material in the pretty-printer queue. *) -val get_formatter_tag_functions : unit -> formatter_tag_functions;; +val get_formatter_tag_functions : unit -> formatter_tag_functions (** Return the current tag functions of the pretty-printer. *) (** {6 Multiple formatted output} *) -type formatter;; +type formatter (** Abstract data corresponding to a pretty-printer (also called a formatter) and all its machinery. @@ -457,40 +459,39 @@ type formatter;; (convenient to output material to strings for instance). *) -val formatter_of_out_channel : out_channel -> formatter;; +val formatter_of_out_channel : out_channel -> formatter (** [formatter_of_out_channel oc] returns a new formatter that writes to the corresponding channel [oc]. *) -val std_formatter : formatter;; +val std_formatter : formatter (** The standard formatter used by the formatting functions above. It is defined as [formatter_of_out_channel stdout]. *) -val err_formatter : formatter;; +val err_formatter : formatter (** A formatter to use with formatting functions below for output to standard error. It is defined as [formatter_of_out_channel stderr]. *) -val formatter_of_buffer : Buffer.t -> formatter;; +val formatter_of_buffer : Buffer.t -> formatter (** [formatter_of_buffer b] returns a new formatter writing to buffer [b]. As usual, the formatter has to be flushed at the end of pretty printing, using [pp_print_flush] or [pp_print_newline], to display all the pending material. *) -val stdbuf : Buffer.t;; +val stdbuf : Buffer.t (** The string buffer in which [str_formatter] writes. *) -val str_formatter : formatter;; +val str_formatter : formatter (** A formatter to use with formatting functions below for output to the [stdbuf] string buffer. [str_formatter] is defined as [formatter_of_buffer stdbuf]. *) -val flush_str_formatter : unit -> string;; +val flush_str_formatter : unit -> string (** Returns the material printed with [str_formatter], flushes the formatter and resets the corresponding buffer. *) val make_formatter : (string -> int -> int -> unit) -> (unit -> unit) -> formatter -;; (** [make_formatter out flush] returns a new formatter that writes according to the output function [out], and the flushing function [flush]. For instance, a formatter to the [Pervasives.out_channel] [oc] is returned by @@ -498,67 +499,66 @@ val make_formatter : (** {6 Basic functions to use with formatters} *) -val pp_open_hbox : formatter -> unit -> unit;; -val pp_open_vbox : formatter -> int -> unit;; -val pp_open_hvbox : formatter -> int -> unit;; -val pp_open_hovbox : formatter -> int -> unit;; -val pp_open_box : formatter -> int -> unit;; -val pp_close_box : formatter -> unit -> unit;; -val pp_open_tag : formatter -> string -> unit;; -val pp_close_tag : formatter -> unit -> unit;; -val pp_print_string : formatter -> string -> unit;; -val pp_print_as : formatter -> int -> string -> unit;; -val pp_print_int : formatter -> int -> unit;; -val pp_print_float : formatter -> float -> unit;; -val pp_print_char : formatter -> char -> unit;; -val pp_print_bool : formatter -> bool -> unit;; -val pp_print_break : formatter -> int -> int -> unit;; -val pp_print_cut : formatter -> unit -> unit;; -val pp_print_space : formatter -> unit -> unit;; -val pp_force_newline : formatter -> unit -> unit;; -val pp_print_flush : formatter -> unit -> unit;; -val pp_print_newline : formatter -> unit -> unit;; -val pp_print_if_newline : formatter -> unit -> unit;; -val pp_open_tbox : formatter -> unit -> unit;; -val pp_close_tbox : formatter -> unit -> unit;; -val pp_print_tbreak : formatter -> int -> int -> unit;; -val pp_set_tab : formatter -> unit -> unit;; -val pp_print_tab : formatter -> unit -> unit;; -val pp_set_tags : formatter -> bool -> unit;; -val pp_set_print_tags : formatter -> bool -> unit;; -val pp_set_mark_tags : formatter -> bool -> unit;; -val pp_get_print_tags : formatter -> unit -> bool;; -val pp_get_mark_tags : formatter -> unit -> bool;; -val pp_set_margin : formatter -> int -> unit;; -val pp_get_margin : formatter -> unit -> int;; -val pp_set_max_indent : formatter -> int -> unit;; -val pp_get_max_indent : formatter -> unit -> int;; -val pp_set_max_boxes : formatter -> int -> unit;; -val pp_get_max_boxes : formatter -> unit -> int;; -val pp_over_max_boxes : formatter -> unit -> bool;; -val pp_set_ellipsis_text : formatter -> string -> unit;; -val pp_get_ellipsis_text : formatter -> unit -> string;; +val pp_open_hbox : formatter -> unit -> unit +val pp_open_vbox : formatter -> int -> unit +val pp_open_hvbox : formatter -> int -> unit +val pp_open_hovbox : formatter -> int -> unit +val pp_open_box : formatter -> int -> unit +val pp_close_box : formatter -> unit -> unit +val pp_open_tag : formatter -> string -> unit +val pp_close_tag : formatter -> unit -> unit +val pp_print_string : formatter -> string -> unit +val pp_print_as : formatter -> int -> string -> unit +val pp_print_int : formatter -> int -> unit +val pp_print_float : formatter -> float -> unit +val pp_print_char : formatter -> char -> unit +val pp_print_bool : formatter -> bool -> unit +val pp_print_break : formatter -> int -> int -> unit +val pp_print_cut : formatter -> unit -> unit +val pp_print_space : formatter -> unit -> unit +val pp_force_newline : formatter -> unit -> unit +val pp_print_flush : formatter -> unit -> unit +val pp_print_newline : formatter -> unit -> unit +val pp_print_if_newline : formatter -> unit -> unit +val pp_open_tbox : formatter -> unit -> unit +val pp_close_tbox : formatter -> unit -> unit +val pp_print_tbreak : formatter -> int -> int -> unit +val pp_set_tab : formatter -> unit -> unit +val pp_print_tab : formatter -> unit -> unit +val pp_set_tags : formatter -> bool -> unit +val pp_set_print_tags : formatter -> bool -> unit +val pp_set_mark_tags : formatter -> bool -> unit +val pp_get_print_tags : formatter -> unit -> bool +val pp_get_mark_tags : formatter -> unit -> bool +val pp_set_margin : formatter -> int -> unit +val pp_get_margin : formatter -> unit -> int +val pp_set_max_indent : formatter -> int -> unit +val pp_get_max_indent : formatter -> unit -> int +val pp_set_max_boxes : formatter -> int -> unit +val pp_get_max_boxes : formatter -> unit -> int +val pp_over_max_boxes : formatter -> unit -> bool +val pp_set_ellipsis_text : formatter -> string -> unit +val pp_get_ellipsis_text : formatter -> unit -> string val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit -;; + val pp_set_formatter_output_functions : formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit -;; + val pp_get_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) -;; + val pp_set_formatter_tag_functions : formatter -> formatter_tag_functions -> unit -;; + val pp_get_formatter_tag_functions : formatter -> unit -> formatter_tag_functions -;; + val pp_set_formatter_out_functions : formatter -> formatter_out_functions -> unit -;; + val pp_get_formatter_out_functions : formatter -> unit -> formatter_out_functions -;; (** These functions are the basic ones: usual functions operating on the standard formatter are defined via partial evaluation of these primitives. For instance, @@ -587,7 +587,7 @@ val pp_print_text : formatter -> string -> unit (** {6 [printf] like functions for pretty-printing.} *) -val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; +val fprintf : formatter -> ('a, formatter, unit) format -> 'a (** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] according to the format string [fmt], and outputs the resulting string on @@ -656,13 +656,13 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; *) -val printf : ('a, formatter, unit) format -> 'a;; +val printf : ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but output on [std_formatter]. *) -val eprintf : ('a, formatter, unit) format -> 'a;; +val eprintf : ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but output on [err_formatter]. *) -val sprintf : ('a, unit, string) format -> 'a;; +val sprintf : ('a, unit, string) format -> 'a (** Same as [printf] above, but instead of printing on a formatter, returns a string containing the result of formatting the arguments. Note that the pretty-printer queue is flushed at the end of {e each @@ -678,7 +678,7 @@ val sprintf : ('a, unit, string) format -> 'a;; pretty-printing returns the desired string. *) -val asprintf : ('a, formatter, unit, string) format4 -> 'a;; +val asprintf : ('a, formatter, unit, string) format4 -> 'a (** Same as [printf] above, but instead of printing on a formatter, returns a string containing the result of formatting the arguments. The type of [asprintf] is general enough to interact nicely with [%a] @@ -686,7 +686,7 @@ val asprintf : ('a, formatter, unit, string) format4 -> 'a;; @since 4.01.0 *) -val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; +val ifprintf : formatter -> ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.10.0 @@ -696,19 +696,17 @@ val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; val kfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b -;; (** Same as [fprintf] above, but instead of returning immediately, passes the formatter to its first argument at the end of printing. *) val ikfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b -;; (** Same as [kfprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.12.0 *) -val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) @@ -716,7 +714,6 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a [@@ocaml.deprecated] -;; (** @deprecated This function is error prone. Do not use it. If you need to print to some buffer [b], you must first define a @@ -725,7 +722,6 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b [@@ocaml.deprecated "Use Format.ksprintf instead."] -;; (** @deprecated An alias for [ksprintf]. *) val set_all_formatter_output_functions : @@ -735,9 +731,7 @@ val set_all_formatter_output_functions : spaces:(int -> unit) -> unit [@@ocaml.deprecated "Use Format.set_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [set_formatter_out_functions]. -*) +(** @deprecated Subsumed by [set_formatter_out_functions]. *) val get_all_formatter_output_functions : unit -> @@ -746,22 +740,17 @@ val get_all_formatter_output_functions : (unit -> unit) * (int -> unit) [@@ocaml.deprecated "Use Format.get_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [get_formatter_out_functions]. -*) +(** @deprecated Subsumed by [get_formatter_out_functions]. *) + val pp_set_all_formatter_output_functions : formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit [@@ocaml.deprecated "Use Format.pp_set_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [pp_set_formatter_out_functions]. -*) +(** @deprecated Subsumed by [pp_set_formatter_out_functions]. *) val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) [@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [pp_get_formatter_out_functions]. -*) +(** @deprecated Subsumed by [pp_get_formatter_out_functions]. *) diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 4a72566594c9..573414ec2222 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -136,7 +136,7 @@ val ifprintf : 'a -> ('b, 'a, unit) format -> 'b (** Formatted output functions with continuations. *) val kfprintf : (out_channel -> 'a) -> out_channel -> - ('b, out_channel, unit, 'a) format4 -> 'b;; + ('b, out_channel, unit, 'a) format4 -> 'b (** Same as [fprintf], but instead of returning immediately, passes the out channel to its first argument at the end of printing. @since 3.09.0 @@ -144,20 +144,19 @@ val kfprintf : (out_channel -> 'a) -> out_channel -> val ikfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b -;; (** Same as [kfprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 4.0 *) -val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. @since 3.09.0 *) val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> - ('b, Buffer.t, unit, 'a) format4 -> 'b;; + ('b, Buffer.t, unit, 'a) format4 -> 'b (** Same as [bprintf], but instead of returning immediately, passes the buffer to its first argument at the end of printing. @since 3.10.0 diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 212aa00b75ce..f065c4610b5e 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -83,7 +83,7 @@ module Scanning : sig -type in_channel;; +type in_channel (** The notion of input channel for the [Scanf] module: those channels provide all the machinery necessary to read from a given [Pervasives.in_channel] value. @@ -93,7 +93,7 @@ type in_channel;; @since 3.12.0 *) -type scanbuf = in_channel;; +type scanbuf = in_channel (** The type of scanning buffers. A scanning buffer is the source from which a formatted input function gets characters. The scanning buffer holds the current state of the scan, plus a function to get the next char from the @@ -105,7 +105,7 @@ type scanbuf = in_channel;; character yet to be read. *) -val stdin : in_channel;; +val stdin : in_channel (** The standard input notion for the [Scanf] module. [Scanning.stdin] is the formatted input channel attached to [Pervasives.stdin]. @@ -118,12 +118,12 @@ val stdin : in_channel;; @since 3.12.0 *) -type file_name = string;; +type file_name = string (** A convenient alias to designate a file name. @since 4.00.0 *) -val open_in : file_name -> in_channel;; +val open_in : file_name -> in_channel (** [Scanning.open_in fname] returns a formatted input channel for bufferized reading in text mode from file [fname]. @@ -135,31 +135,32 @@ val open_in : file_name -> in_channel;; @since 3.12.0 *) -val open_in_bin : file_name -> in_channel;; +val open_in_bin : file_name -> in_channel (** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized reading in binary mode from file [fname]. @since 3.12.0 *) -val close_in : in_channel -> unit;; +val close_in : in_channel -> unit (** Closes the [Pervasives.in_channel] associated with the given [Scanning.in_channel] formatted input channel. @since 3.12.0 *) -val from_file : file_name -> in_channel;; +val from_file : file_name -> in_channel (** An alias for [open_in] above. *) -val from_file_bin : string -> in_channel;; + +val from_file_bin : string -> in_channel (** An alias for [open_in_bin] above. *) -val from_string : string -> in_channel;; +val from_string : string -> in_channel (** [Scanning.from_string s] returns a formatted input channel which reads from the given string. Reading starts from the first character in the string. The end-of-input condition is set when the end of the string is reached. *) -val from_function : (unit -> char) -> in_channel;; +val from_function : (unit -> char) -> in_channel (** [Scanning.from_function f] returns a formatted input channel with the given function as its reading method. @@ -169,39 +170,39 @@ val from_function : (unit -> char) -> in_channel;; end-of-input condition by raising the exception [End_of_file]. *) -val from_channel : Pervasives.in_channel -> in_channel;; +val from_channel : Pervasives.in_channel -> in_channel (** [Scanning.from_channel ic] returns a formatted input channel which reads from the regular input channel [ic] argument, starting at the current reading position. *) -val end_of_input : in_channel -> bool;; +val end_of_input : in_channel -> bool (** [Scanning.end_of_input ic] tests the end-of-input condition of the given formatted input channel. *) -val beginning_of_input : in_channel -> bool;; +val beginning_of_input : in_channel -> bool (** [Scanning.beginning_of_input ic] tests the beginning of input condition of the given formatted input channel. *) -val name_of_input : in_channel -> string;; +val name_of_input : in_channel -> string (** [Scanning.name_of_input ic] returns the name of the character source for the formatted input channel [ic]. @since 3.09.0 *) -val stdib : in_channel;; +val stdib : in_channel (** A deprecated alias for [Scanning.stdin], the scanning buffer reading from [Pervasives.stdin]. *) -end;; +end (** {6 Type of formatted input functions} *) type ('a, 'b, 'c, 'd) scanner = - ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; + ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c (** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the type of a formatted input function that reads from some formatted input channel according to some format string; more @@ -223,14 +224,14 @@ type ('a, 'b, 'c, 'd) scanner = @since 3.10.0 *) -exception Scan_failure of string;; +exception Scan_failure of string (** The exception that formatted input functions raise when the input cannot be read according to the given format. *) (** {6 The general formatted input function} *) -val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; +val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner (** [bscanf ic fmt r1 ... rN f] reads arguments for the function [f], from the formatted input channel [ic], according to the format string [fmt], and applies [f] to these values. @@ -453,7 +454,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; (** {6 Specialised formatted input functions} *) -val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; +val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the given regular input channel. Warning: since all formatted input functions operate from a {e formatted @@ -467,17 +468,17 @@ val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; scanning from the same regular input channel. *) -val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; +val sscanf : string -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the given string. *) -val scanf : ('a, 'b, 'c, 'd) scanner;; +val scanf : ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the predefined formatted input channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin]. *) val kscanf : Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) -> - ('a, 'b, 'c, 'd) scanner;; + ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but takes an additional function argument [ef] that is called in case of error: if the scanning process or some conversion fails, the scanning function aborts and calls the @@ -501,7 +502,7 @@ val kfscanf : val bscanf_format : Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g (** [bscanf_format ic fmt f] reads a format string token from the formatted input channel [ic], according to the given format string [fmt], and applies [f] to the resulting format string value. @@ -512,14 +513,14 @@ val bscanf_format : val sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g (** Same as {!Scanf.bscanf_format}, but reads from the given string. @since 3.09.0 *) val format_from_string : string -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;; + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 (** [format_from_string s fmt] converts a string argument to a format string, according to the given format string [fmt]. Raise [Scan_failure] if [s], considered as a format string, does not @@ -527,7 +528,7 @@ val format_from_string : @since 3.10.0 *) -val unescaped : string -> string;; +val unescaped : string -> string (** Return a copy of the argument with escape sequences, following the lexical conventions of OCaml, replaced by their corresponding special characters. If there is no escape sequence in the diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 251743449f59..3f929276299b 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -37,7 +37,7 @@ opt.opt: ocamldep.opt read_cmt.opt CAMLDEP_OBJ=depend.cmo ocamldep.cmo CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo \ + warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \ ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo @@ -67,7 +67,7 @@ install:: CSLPROF=ocamlprof.cmo CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo \ + warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo ocamlprof: $(CSLPROF) profiling.cmo @@ -160,7 +160,7 @@ clean:: # Insert labels following an interface file (upgrade 3.02 to 3.03) ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo \ + warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo addlabels: addlabels.cmo @@ -205,6 +205,7 @@ READ_CMT= \ ../utils/clflags.cmo \ ../parsing/location.cmo \ ../parsing/longident.cmo \ + ../parsing/docstrings.cmo \ ../parsing/lexer.cmo \ ../parsing/pprintast.cmo \ ../parsing/ast_helper.cmo \ diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 51559aea3ea9..a8c0c258882e 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -61,6 +61,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _impl s = with_impl := true; option_with_arg "-impl" s let _intf s = with_intf := true; option_with_arg "-intf" s let _intf_suffix s = option_with_arg "-intf-suffix" s + let _keep_docs = option "-keep-docs" let _keep_locs = option "-keep-locs" let _labels = option "-labels" let _linkall = option "-linkall" diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 0b788843fe78..2b93f4812273 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -61,6 +61,7 @@ module Options = Main_args.Make_optcomp_options (struct let _inline n = option_with_int "-inline" n let _intf s = with_intf := true; option_with_arg "-intf" s let _intf_suffix s = option_with_arg "-intf-suffix" s + let _keep_docs = option "-keep-docs" let _keep_locs = option "-keep-locs" let _labels = option "-labels" let _linkall = option "-linkall" diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli index 14659d62a249..1c2ec471b840 100644 --- a/toplevel/genprintval.mli +++ b/toplevel/genprintval.mli @@ -54,6 +54,7 @@ module type S = unit (** [install_generic_printer' function_path constructor_path printer] function_path is used to remove the printer. *) + val remove_printer : Path.t -> unit val outval_of_untyped_exception : t -> Outcometree.out_value val outval_of_value : diff --git a/typing/ctype.mli b/typing/ctype.mli index 37daf3a428ac..36cb186fa279 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -144,6 +144,7 @@ val try_expand_once_opt: Env.t -> type_expr -> type_expr val expand_head_opt: Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) + val full_expand: Env.t -> type_expr -> type_expr val extract_concrete_typedecl: Env.t -> type_expr -> Path.t * Path.t * type_declaration diff --git a/typing/subst.ml b/typing/subst.ml index 2e84be01ff5a..c9b18e267b4e 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -42,11 +42,22 @@ let remove_loc = let open Ast_mapper in {default_mapper with location = (fun _this _loc -> Location.none)} -let attrs s x = - if s.for_saving && not !Clflags.keep_locs - then remove_loc.Ast_mapper.attributes remove_loc x - else x +let is_not_doc = function + | ({Location.txt = "ocaml.doc"}, _) -> false + | ({Location.txt = "ocaml.text"}, _) -> false + | ({Location.txt = "doc"}, _) -> false + | ({Location.txt = "text"}, _) -> false + | _ -> true +let attrs s x = + let x = + if s.for_saving && not !Clflags.keep_docs then + List.filter is_not_doc x + else x + in + if s.for_saving && not !Clflags.keep_locs + then remove_loc.Ast_mapper.attributes remove_loc x + else x let rec module_path s = function Pident id as p -> @@ -306,7 +317,7 @@ let extension_constructor s ext = ext_args = List.map (typexp s) ext.ext_args; ext_ret_type = may_map (typexp s) ext.ext_ret_type; ext_private = ext.ext_private; - ext_attributes = ext.ext_attributes; + ext_attributes = attrs s ext.ext_attributes; ext_loc = if s.for_saving then Location.none else ext.ext_loc; } in cleanup_types (); diff --git a/utils/clflags.ml b/utils/clflags.ml index 57834ccf912d..8e601e0b761a 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -108,5 +108,6 @@ let dlcode = ref true (* not -nodynlink *) let runtime_variant = ref "";; (* -runtime-variant *) +let keep_docs = ref false (* -keep-docs *) let keep_locs = ref false (* -keep-locs *) let unsafe_string = ref true;; (* -safe-string / -unsafe-string *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 7e51cf33db25..6a3b33dfef86 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -91,6 +91,7 @@ val shared : bool ref val dlcode : bool ref val runtime_variant : string ref val force_slash : bool ref +val keep_docs : bool ref val keep_locs : bool ref val unsafe_string : bool ref val opaque : bool ref diff --git a/utils/warnings.ml b/utils/warnings.ml index 103789c4ed34..616f01267ee8 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -67,6 +67,7 @@ type t = | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string (* 49 *) + | Bad_docstring of bool (* 50 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -125,9 +126,10 @@ let number = function | Attribute_payload _ -> 47 | Eliminated_optional_arguments _ -> 48 | No_cmi_file _ -> 49 + | Bad_docstring _ -> 50 ;; -let last_warning_number = 49 +let last_warning_number = 50 (* Must be the max number returned by the [number] function. *) let letter = function @@ -240,7 +242,7 @@ let parse_options errflag s = current := {error; active} (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48";; +let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -384,6 +386,9 @@ let message = function (String.concat ", " sl) | No_cmi_file s -> "no cmi file was found in path for module " ^ s + | Bad_docstring unattached -> + if unattached then "unattached documentation comment (ignored)" + else "ambiguous documentation comment" ;; let nerrors = ref 0;; @@ -478,6 +483,7 @@ let descriptions = 47, "Illegal attribute payload."; 48, "Implicit elimination of optional arguments."; 49, "Absent cmi file when looking up module alias."; + 50, "Unexpected documentation comment."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index edfd732c317b..80e399a286b4 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -62,6 +62,7 @@ type t = | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string (* 49 *) + | Bad_docstring of bool (* 50 *) ;; val parse_options : bool -> string -> unit;;