├── .gitignore ├── .ocp-indent ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── _tags ├── doc-ock.opam ├── doc └── api.odocl ├── pkg └── pkg.ml ├── src ├── docOck.ml ├── docOck.mli ├── docOckAttrs.ml ├── docOckAttrs.mli ├── docOckCmi.ml ├── docOckCmi.mli ├── docOckCmt.ml ├── docOckCmt.mli ├── docOckCmti.ml ├── docOckCmti.mli ├── docOckComponentTbl.ml ├── docOckComponentTbl.mli ├── docOckComponents.ml ├── docOckComponents.mli ├── docOckExpand.ml ├── docOckExpand.mli ├── docOckIdentEnv.ml ├── docOckIdentEnv.mli ├── docOckLookup.ml ├── docOckLookup.mli ├── docOckMaps.ml ├── docOckMaps.mli ├── docOckNameEnv.ml ├── docOckNameEnv.mli ├── docOckPaths.ml ├── docOckPaths.mli ├── docOckPayload.ml ├── docOckPayload.mli ├── docOckPredef.ml ├── docOckPredef.mli ├── docOckResolve.ml ├── docOckResolve.mli ├── docOckSubst.ml ├── docOckSubst.mli ├── docOckTypes.ml ├── index.mld └── jbuild └── test ├── jbuild ├── ocamlary.ml ├── ocamlary.mli ├── testCmi.ml ├── testCmt.ml ├── testCmti.ml └── testCommon.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.native 7 | *.byte 8 | *.install 9 | .merlin 10 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause=4 2 | in=2 -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v1.2.1 2 | ------ 3 | 4 | - Fix assertion failure (ocaml/odoc#103). 5 | 6 | v1.2.0 7 | ------ 8 | 9 | - Follow odoc evolution. 10 | 11 | v1.1.1 12 | ------ 13 | 14 | - minimize substs in paths. 15 | i.e. instead of having (Foo.Bar.Baz.t)/(Toto.Tata.Baz.t) we now have 16 | ((Foo.Bar)/(Toto.Tata)).Baz.t 17 | 18 | - remember sections titles to be able to splice them when referencing sections. 19 | (ocaml-doc/odoc#37) 20 | 21 | v1.1.0 22 | ------- 23 | 24 | - switch build to jbuilder. 25 | 26 | - add support for OCaml 4.04 and 4.05. 27 | 28 | - nicer handling of canonical modules using "display types". 29 | 30 | - ad hoc handling of undocumented module aliases: we retrieve the synopsis of 31 | the module which is aliased and use that to document the binding. 32 | 33 | 34 | v1.0.0 35 | ------- 36 | 37 | Initial release. 38 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Leo White 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # This makefile is used for dev convenience. It is removed 2 | # by the distribution process. 3 | 4 | .PHONY: lib test doc clean 5 | 6 | lib: 7 | jbuilder build -p doc-ock 8 | 9 | test: 10 | jbuilder runtest 11 | topkg test 12 | 13 | doc: 14 | @echo "waiting for jbuilder support (cf. pull #74)" 15 | @# jbuilder odoc 16 | 17 | clean: 18 | rm -R _build 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Doc-ock — Extract documentation from OCaml files 2 | ------------------------------------------------ 3 | %%VERSION%% 4 | 5 | > **NOTE**: this library is deprecated as a standalone project. The functionality implemented here can now be found in the [`model`](https://github.com/ocaml/odoc/tree/master/src/model) and [`xref`](https://github.com/ocaml/odoc/tree/master/src/xref) sub-libraries of the [odoc](https://github.com/ocaml/odoc) package. 6 | 7 | Doc-ock is a library extract documentation from OCaml files 8 | 9 | ## Installation 10 | 11 | Doc-ock can be installed with `opam`: 12 | 13 | opam install doc-ock 14 | 15 | If you don't use `opam` consult the [`opam`](opam) file for build instructions. 16 | 17 | ## Testing 18 | 19 | The package compiles and installs the interface 20 | [`test/ocamlary.mli`](test/ocamlary.mli) in the package's `lib` 21 | directory along the library. This allows documentation consumers and 22 | renderers to exercise a common and tricky selection of documentation 23 | features packages may use. 24 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | true : package(compiler-libs.common), package(octavius) 3 | true : warn_error(+8) 4 | 5 | : include 6 | : no_alias_deps 7 | 8 | : include 9 | -------------------------------------------------------------------------------- /doc-ock.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "lpw25@cl.cam.ac.uk" 3 | authors: [ "Leo White " 4 | "Thomas Refis " ] 5 | homepage: "https://github.com/ocaml-doc/doc-ock" 6 | doc: "https://ocaml-doc.github.com/doc-ock/" 7 | license: "ISC" 8 | dev-repo: "http://github.com/ocaml-doc/doc-ock.git" 9 | bug-reports: "https://github.com/ocaml-doc/odoc/issues" 10 | tags: ["doc" "ocaml" "org:ocaml-doc"] 11 | 12 | available: [ ocaml-version >= "4.03.0" ] 13 | depends: [ 14 | "cppo" {build} 15 | "ocamlfind" {build} 16 | "jbuilder" {build} 17 | "octavius" 18 | ] 19 | 20 | build: [ 21 | ["jbuilder" "subst"] {pinned} 22 | ["jbuilder" "build" "-p" name "-j" jobs] 23 | ] 24 | -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | DocOck 2 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg-jbuilder.auto" 4 | -------------------------------------------------------------------------------- /src/docOck.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Attrs = DocOckAttrs 18 | 19 | module Maps = DocOckMaps 20 | 21 | module Paths = DocOckPaths 22 | 23 | module Types = DocOckTypes 24 | 25 | type 'a lookup_result = 'a DocOckComponentTbl.lookup_unit_result = 26 | | Forward_reference 27 | | Found of { root : 'a; hidden : bool } 28 | | Not_found 29 | 30 | let core_types = DocOckPredef.core_types 31 | 32 | let core_exceptions = DocOckPredef.core_exceptions 33 | 34 | type 'a result = 35 | | Ok of 'a Types.Unit.t 36 | | Not_an_interface 37 | | Wrong_version 38 | | Corrupted 39 | | Not_a_typedtree 40 | | Not_an_implementation 41 | 42 | let read_cmti root_fn filename = 43 | let open Cmi_format in 44 | let open Cmt_format in 45 | let open Types.Unit in 46 | try 47 | let cmt_info = read_cmt filename in 48 | match cmt_info.cmt_annots with 49 | | Interface intf -> begin 50 | match cmt_info.cmt_interface_digest with 51 | | Some digest -> 52 | let name = cmt_info.cmt_modname in 53 | let root = root_fn name digest in 54 | let (id, doc, items) = DocOckCmti.read_interface root name intf in 55 | let imports = 56 | List.filter (fun (name', _) -> name <> name') cmt_info.cmt_imports 57 | in 58 | let imports = 59 | List.map (fun (s, d) -> Import.Unresolved(s, d)) imports 60 | in 61 | let interface = true in 62 | let hidden = Paths.contains_double_underscore name in 63 | let source = 64 | match cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest with 65 | | Some file, Some digest -> 66 | let open Source in 67 | let build_dir = cmt_info.cmt_builddir in 68 | Some {file; digest; build_dir} 69 | | _, _ -> None 70 | in 71 | let content = Module items in 72 | let unit = 73 | {id; doc; digest; imports; source; 74 | interface; hidden; content; expansion = None} 75 | in 76 | let unit = DocOckLookup.lookup unit in 77 | Ok unit 78 | | None -> Corrupted 79 | end 80 | | _ -> Not_an_interface 81 | with 82 | | Cmi_format.Error (Not_an_interface _) -> Not_an_interface 83 | | Cmi_format.Error (Wrong_version_interface _) -> Wrong_version 84 | | Cmi_format.Error (Corrupted_interface _) -> Corrupted 85 | | Cmt_format.Error (Not_a_typedtree _) -> Not_a_typedtree 86 | 87 | let read_cmt root_fn filename = 88 | let open Cmi_format in 89 | let open Cmt_format in 90 | let open Types.Unit in 91 | try 92 | let cmt_info = read_cmt filename in 93 | match cmt_info.cmt_annots with 94 | | Packed(_, files) -> 95 | let name = cmt_info.cmt_modname in 96 | let interface, digest = 97 | match cmt_info.cmt_interface_digest with 98 | | Some digest -> true, digest 99 | | None -> 100 | match List.assoc name cmt_info.cmt_imports with 101 | | Some digest -> false, digest 102 | | None -> assert false 103 | | exception Not_found -> assert false 104 | in 105 | let hidden = Paths.contains_double_underscore name in 106 | let root = root_fn name digest in 107 | let id = Paths.Identifier.Root(root, name) in 108 | let items = 109 | List.map 110 | (fun file -> 111 | let pref = Misc.chop_extensions file in 112 | String.capitalize_ascii (Filename.basename pref)) 113 | files 114 | in 115 | let items = List.sort String.compare items in 116 | let items = 117 | List.map 118 | (fun name -> 119 | let open Packed in 120 | let id = Paths.Identifier.Module(id, name) in 121 | let path = Paths.Path.Root name in 122 | {id; path}) 123 | items 124 | in 125 | let imports = 126 | List.filter (fun (name', _) -> name <> name') cmt_info.cmt_imports 127 | in 128 | let imports = 129 | List.map (fun (s, d) -> Import.Unresolved(s, d)) imports 130 | in 131 | let doc = DocOckAttrs.empty in 132 | let source = None in 133 | let content = Pack items in 134 | Ok {id; doc; digest; imports; 135 | source; interface; hidden; content; expansion = None} 136 | | Implementation impl -> 137 | let open Types.Unit in 138 | let name = cmt_info.cmt_modname in 139 | let interface, digest = 140 | match cmt_info.cmt_interface_digest with 141 | | Some digest -> true, digest 142 | | None -> 143 | match List.assoc name cmt_info.cmt_imports with 144 | | Some digest -> false, digest 145 | | None -> assert false 146 | | exception Not_found -> assert false 147 | in 148 | let hidden = Paths.contains_double_underscore name in 149 | let root = root_fn name digest in 150 | let (id, doc, items) = DocOckCmt.read_implementation root name impl in 151 | let imports = 152 | List.filter (fun (name', _) -> name <> name') cmt_info.cmt_imports 153 | in 154 | let imports = 155 | List.map (fun (s, d) -> Import.Unresolved(s, d)) imports 156 | in 157 | let source = 158 | match cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest with 159 | | Some file, Some digest -> 160 | let open Source in 161 | let build_dir = cmt_info.cmt_builddir in 162 | Some {file; digest; build_dir} 163 | | _, _ -> None 164 | in 165 | let content = Module items in 166 | let unit = 167 | {id; doc; digest; imports; 168 | source; interface; hidden; content; expansion = None} 169 | in 170 | let unit = DocOckLookup.lookup unit in 171 | Ok unit 172 | | _ -> Not_an_implementation 173 | with 174 | | Cmi_format.Error (Not_an_interface _) -> Not_an_implementation 175 | | Cmi_format.Error (Wrong_version_interface _) -> Wrong_version 176 | | Cmi_format.Error (Corrupted_interface _) -> Corrupted 177 | | Cmt_format.Error (Not_a_typedtree _) -> Not_a_typedtree 178 | 179 | let read_cmi root_fn filename = 180 | let open Cmi_format in 181 | let open Types.Unit in 182 | try 183 | let cmi_info = read_cmi filename in 184 | match cmi_info.cmi_crcs with 185 | | (name, Some digest) :: imports when name = cmi_info.cmi_name -> 186 | let root = root_fn name digest in 187 | let (id, doc, items) = 188 | DocOckCmi.read_interface root name cmi_info.cmi_sign 189 | in 190 | let imports = 191 | List.map (fun (s, d) -> Import.Unresolved(s, d)) imports 192 | in 193 | let interface = true in 194 | let hidden = Paths.contains_double_underscore name in 195 | let source = None in 196 | let content = Module items in 197 | let unit = 198 | {id; doc; digest; imports; 199 | source; interface; hidden; content; expansion = None} 200 | in 201 | let unit = DocOckLookup.lookup unit in 202 | Ok unit 203 | | _ -> Corrupted 204 | with 205 | | Cmi_format.Error (Not_an_interface _) -> Not_an_interface 206 | | Cmi_format.Error (Wrong_version_interface _) -> Wrong_version 207 | | Cmi_format.Error (Corrupted_interface _) -> Corrupted 208 | 209 | type 'a resolver = 'a DocOckResolve.resolver 210 | 211 | let build_resolver = DocOckResolve.build_resolver 212 | 213 | let resolve = DocOckResolve.resolve 214 | 215 | let resolve_page = DocOckResolve.resolve_page 216 | 217 | type 'a expander = 'a DocOckExpand.t 218 | 219 | let build_expander = DocOckExpand.build_expander 220 | 221 | let expand = DocOckExpand.expand 222 | -------------------------------------------------------------------------------- /src/docOck.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (**/**) 18 | 19 | module Attrs = DocOckAttrs 20 | 21 | module Maps = DocOckMaps 22 | 23 | module Paths = DocOckPaths 24 | 25 | module Types = DocOckTypes 26 | 27 | (**/**) 28 | 29 | (** {2:from_ocaml Processing OCaml's compilation units} *) 30 | 31 | type 'a result = 32 | | Ok of 'a Types.Unit.t 33 | | Not_an_interface 34 | | Wrong_version 35 | | Corrupted 36 | | Not_a_typedtree 37 | | Not_an_implementation 38 | 39 | val read_cmti: (string -> Digest.t -> 'a) -> string -> 'a result 40 | 41 | val read_cmt: (string -> Digest.t -> 'a) -> string -> 'a result 42 | 43 | val read_cmi: (string -> Digest.t -> 'a) -> string -> 'a result 44 | 45 | (** {2:resolving Resolving} 46 | 47 | This is the part of DocOck handling the resolving of path and references. *) 48 | 49 | type 'a resolver 50 | 51 | type 'a lookup_result = 52 | | Forward_reference 53 | | Found of { root : 'a; hidden : bool } 54 | | Not_found 55 | 56 | (** Build a resolver. Optionally provide equality and hash on ['a]. *) 57 | val build_resolver: ?equal:('a -> 'a -> bool) -> ?hash:('a -> int) 58 | -> (string -> 'a lookup_result) -> ('a -> 'a Types.Unit.t) 59 | -> (string -> 'a option) -> ('a -> 'a Types.Page.t) 60 | -> 'a resolver 61 | 62 | val resolve: 'a resolver -> 'a Types.Unit.t -> 'a Types.Unit.t 63 | 64 | val resolve_page : 'a resolver -> 'a Types.Page.t -> 'a Types.Page.t 65 | 66 | (** {2:expansion Expansion} 67 | 68 | This is the part of DocOck in charge of performing substitutions, inlining 69 | of includes, etc. *) 70 | 71 | type 'a expander 72 | 73 | (** Build an expander. Assumes that it is safe to use {!Hashtbl.hash} and 74 | structural equality (=) on ['a]. *) 75 | val build_expander: ?equal:('a -> 'a -> bool) -> ?hash:('a -> int) -> 76 | (string -> 'a lookup_result) -> 77 | (root:'a -> 'a -> 'a Types.Unit.t) -> 'a expander 78 | 79 | val expand: 'a expander -> 'a Types.Unit.t -> 'a Types.Unit.t 80 | 81 | (** {2 Misc.} 82 | 83 | OCaml's predefined types and exceptions. *) 84 | 85 | val core_types : 'a Types.TypeDecl.t list 86 | 87 | val core_exceptions : 'a Types.Exception.t list 88 | 89 | -------------------------------------------------------------------------------- /src/docOckAttrs.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes.Documentation 19 | 20 | val empty : 'a t 21 | 22 | val read_attributes : 'a Identifier.label_parent -> ('a, 'k) Identifier.t -> 23 | Parsetree.attributes -> 'a t 24 | 25 | val read_string : 'a Identifier.label_parent -> Location.t -> string -> 'a comment 26 | (** The parent identifier is used to define labels in the given string (i.e. 27 | for things like [{1:some_section Some title}]) and the location is used for 28 | error messages. 29 | 30 | This function is meant to be used to read arbitrary files containing text in 31 | the ocamldoc syntax. *) 32 | 33 | val read_comment : 'a Identifier.label_parent -> 34 | Parsetree.attribute -> 'a comment option 35 | 36 | val read_comments : 'a Identifier.label_parent -> 37 | Parsetree.attributes -> 'a comment list 38 | -------------------------------------------------------------------------------- /src/docOckCmi.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | 18 | val read_interface: 'a -> string -> Types.signature -> 19 | 'a DocOckPaths.Identifier.module_ * 20 | 'a DocOckTypes.Documentation.t * 21 | 'a DocOckTypes.Signature.t 22 | 23 | val read_label : Asttypes.arg_label -> DocOckTypes.TypeExpr.label option 24 | 25 | val mark_type_expr : Types.type_expr -> unit 26 | 27 | val read_type_expr : 'a DocOckIdentEnv.t -> 28 | Types.type_expr -> 'a DocOckTypes.TypeExpr.t 29 | 30 | val mark_type_extension : Types.type_expr list -> 31 | Types.extension_constructor list -> 32 | Types.type_expr list 33 | 34 | val read_type_parameter : bool -> Types.Variance.t -> 35 | Types.type_expr -> DocOckTypes.TypeDecl.param 36 | 37 | val mark_class_declaration : Types.class_declaration -> unit 38 | 39 | val read_self_type : Types.type_expr -> 'a DocOckTypes.TypeExpr.t option 40 | 41 | val read_type_constraints : 'a DocOckIdentEnv.t -> Types.type_expr list -> 42 | ('a DocOckTypes.TypeExpr.t 43 | * 'a DocOckTypes.TypeExpr.t) list 44 | 45 | val read_class_signature : 'a DocOckIdentEnv.t -> 46 | 'a DocOckPaths.Identifier.class_signature -> 47 | Types.type_expr list -> Types.class_type -> 48 | 'a DocOckTypes.ClassType.expr 49 | 50 | val read_class_type : 'a DocOckIdentEnv.t -> 51 | 'a DocOckPaths.Identifier.class_signature -> 52 | Types.type_expr list -> Types.class_type -> 53 | 'a DocOckTypes.Class.decl 54 | 55 | val read_module_type : 'a DocOckIdentEnv.t -> 56 | 'a DocOckPaths.Identifier.signature -> int -> 57 | Types.module_type -> 'a DocOckTypes.ModuleType.expr 58 | 59 | val read_signature : 'a DocOckIdentEnv.t -> 60 | 'a DocOckPaths.Identifier.signature -> 61 | Types.signature -> 'a DocOckTypes.Signature.t 62 | 63 | val read_extension_constructor : 'a DocOckIdentEnv.t -> 64 | 'a DocOckPaths.Identifier.signature -> 65 | Ident.t -> Types.extension_constructor -> 66 | 'a DocOckTypes.Extension.Constructor.t 67 | 68 | val read_exception : 'a DocOckIdentEnv.t -> 69 | 'a DocOckPaths.Identifier.signature -> Ident.t -> 70 | Types.extension_constructor -> 'a DocOckTypes.Exception.t 71 | -------------------------------------------------------------------------------- /src/docOckCmt.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Asttypes 18 | open Types 19 | open Typedtree 20 | 21 | module OCamlPath = Path 22 | 23 | open DocOckPaths 24 | open DocOckTypes 25 | open DocOckAttrs 26 | 27 | module Env = DocOckIdentEnv 28 | 29 | let parenthesise name = 30 | match name with 31 | | "asr" | "land" | "lnot" | "lor" | "lsl" | "lsr" 32 | | "lxor" | "mod" -> "(" ^ name ^ ")" 33 | | _ -> 34 | if (String.length name > 0) then 35 | match name.[0] with 36 | | 'a' .. 'z' | '\223' .. '\246' | '\248' .. '\255' | '_' 37 | | 'A' .. 'Z' | '\192' .. '\214' | '\216' .. '\222' -> name 38 | | _ -> "(" ^ name ^ ")" 39 | else name 40 | 41 | let read_core_type env ctyp = 42 | DocOckCmi.read_type_expr env ctyp.ctyp_type 43 | 44 | let rec read_pattern env parent doc pat = 45 | let open Signature in 46 | match pat.pat_desc with 47 | | Tpat_any -> [] 48 | | Tpat_var(id, _) -> 49 | let open Value in 50 | let name = parenthesise (Ident.name id) in 51 | let id = Identifier.Value(parent, name) in 52 | DocOckCmi.mark_type_expr pat.pat_type; 53 | let type_ = DocOckCmi.read_type_expr env pat.pat_type in 54 | [Value {id; doc; type_}] 55 | | Tpat_alias(pat, id, _) -> 56 | let open Value in 57 | let name = parenthesise (Ident.name id) in 58 | let id = Identifier.Value(parent, name) in 59 | DocOckCmi.mark_type_expr pat.pat_type; 60 | let type_ = DocOckCmi.read_type_expr env pat.pat_type in 61 | Value {id; doc; type_} :: read_pattern env parent doc pat 62 | | Tpat_constant _ -> [] 63 | | Tpat_tuple pats -> 64 | List.concat (List.map (read_pattern env parent doc) pats) 65 | | Tpat_construct(_, _, pats) -> 66 | List.concat (List.map (read_pattern env parent doc) pats) 67 | | Tpat_variant(_, None, _) -> [] 68 | | Tpat_variant(_, Some pat, _) -> 69 | read_pattern env parent doc pat 70 | | Tpat_record(pats, _) -> 71 | List.concat 72 | (List.map 73 | (fun (_, _, pat) -> read_pattern env parent doc pat) 74 | pats) 75 | | Tpat_array pats -> 76 | List.concat (List.map (read_pattern env parent doc) pats) 77 | | Tpat_or(pat, _, _) -> 78 | read_pattern env parent doc pat 79 | | Tpat_lazy pat -> 80 | read_pattern env parent doc pat 81 | 82 | let read_value_binding env parent vb = 83 | let container = 84 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 85 | in 86 | let doc = read_attributes container parent vb.vb_attributes in 87 | read_pattern env parent doc vb.vb_pat 88 | 89 | let read_value_bindings env parent vbs = 90 | let container = 91 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 92 | in 93 | let items = 94 | List.fold_left 95 | (fun acc vb -> 96 | let open Signature in 97 | let comments = read_comments container vb.vb_attributes in 98 | let comments = List.map (fun com -> Comment com) comments in 99 | let vb = read_value_binding env parent vb in 100 | List.rev_append vb (List.rev_append comments acc)) 101 | [] vbs 102 | in 103 | List.rev items 104 | 105 | let read_type_extension env parent tyext = 106 | let open Extension in 107 | let type_path = Env.Path.read_type env tyext.tyext_path in 108 | let container = 109 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 110 | in 111 | let doc = read_attributes container parent tyext.tyext_attributes in 112 | let type_params = 113 | List.map (fun (ctyp, _) -> ctyp.ctyp_type) tyext.tyext_params 114 | in 115 | let constructors = 116 | List.map (fun ext -> ext.ext_type) tyext.tyext_constructors 117 | in 118 | let type_params = 119 | DocOckCmi.mark_type_extension type_params constructors 120 | in 121 | let type_params = 122 | List.map 123 | (DocOckCmi.read_type_parameter false Variance.null) 124 | type_params 125 | in 126 | let private_ = (tyext.tyext_private = Private) in 127 | let constructors = 128 | List.map 129 | (fun ext -> 130 | DocOckCmi.read_extension_constructor 131 | env parent ext.ext_id ext.ext_type) 132 | tyext.tyext_constructors 133 | in 134 | { type_path; doc; type_params; private_; constructors; } 135 | 136 | let rec read_class_type_field env parent ctf = 137 | let open ClassSignature in 138 | let container = 139 | Identifier.label_parent_of_parent (Identifier.parent_of_class_signature parent) 140 | in 141 | let doc = read_attributes container parent ctf.ctf_attributes in 142 | match ctf.ctf_desc with 143 | | Tctf_val(name, mutable_, virtual_, typ) -> 144 | let open InstanceVariable in 145 | let name = parenthesise name in 146 | let id = Identifier.InstanceVariable(parent, name) in 147 | let mutable_ = (mutable_ = Mutable) in 148 | let virtual_ = (virtual_ = Virtual) in 149 | let type_ = read_core_type env typ in 150 | Some (InstanceVariable {id; doc; mutable_; virtual_; type_}) 151 | | Tctf_method(name, private_, virtual_, typ) -> 152 | let open Method in 153 | let name = parenthesise name in 154 | let id = Identifier.Method(parent, name) in 155 | let private_ = (private_ = Private) in 156 | let virtual_ = (virtual_ = Virtual) in 157 | let type_ = read_core_type env typ in 158 | Some (Method {id; doc; private_; virtual_; type_}) 159 | | Tctf_constraint(_, _) -> None 160 | | Tctf_inherit cltyp -> 161 | Some (Inherit (read_class_signature env parent [] cltyp)) 162 | | Tctf_attribute attr -> 163 | match read_comment container attr with 164 | | None -> None 165 | | Some doc -> Some (Comment doc) 166 | 167 | and read_class_signature env parent params cltyp = 168 | let open ClassType in 169 | match cltyp.cltyp_desc with 170 | | Tcty_constr(p, _, params) -> 171 | let p = Env.Path.read_class_type env p in 172 | let params = List.map (read_core_type env) params in 173 | Constr(p, params) 174 | | Tcty_signature csig -> 175 | let open ClassSignature in 176 | let self = 177 | DocOckCmi.read_self_type csig.csig_self.ctyp_type 178 | in 179 | let constraints = 180 | DocOckCmi.read_type_constraints env params 181 | in 182 | let constraints = 183 | List.map 184 | (fun (typ1, typ2) -> Constraint(typ1, typ2)) 185 | constraints 186 | in 187 | let items = 188 | List.fold_left 189 | (fun rest item -> 190 | match read_class_type_field env parent item with 191 | | None -> rest 192 | | Some item -> item :: rest) 193 | [] csig.csig_fields 194 | in 195 | let items = constraints @ List.rev items in 196 | Signature {self; items} 197 | | Tcty_arrow _ -> assert false 198 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 199 | | Tcty_open _ -> assert false 200 | #endif 201 | 202 | let rec read_class_type env parent params cty = 203 | let open Class in 204 | match cty.cltyp_desc with 205 | | Tcty_constr _ | Tcty_signature _ -> 206 | ClassType (read_class_signature env parent params cty) 207 | | Tcty_arrow(lbl, arg, res) -> 208 | let lbl = DocOckCmi.read_label lbl in 209 | let arg = read_core_type env arg in 210 | let res = read_class_type env parent params res in 211 | Arrow(lbl, arg, res) 212 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 213 | | Tcty_open (_, _, _, _, cty) -> read_class_type env parent params cty 214 | #endif 215 | 216 | let rec read_class_field env parent cf = 217 | let open ClassSignature in 218 | let container = 219 | Identifier.label_parent_of_parent (Identifier.parent_of_class_signature parent) 220 | in 221 | let doc = read_attributes container parent (cf.cf_attributes) in 222 | match cf.cf_desc with 223 | | Tcf_val({txt = name; _}, mutable_, _, kind, _) -> 224 | let open InstanceVariable in 225 | let name = parenthesise name in 226 | let id = Identifier.InstanceVariable(parent, name) in 227 | let mutable_ = (mutable_ = Mutable) in 228 | let virtual_, type_ = 229 | match kind with 230 | | Tcfk_virtual typ -> 231 | true, read_core_type env typ 232 | | Tcfk_concrete(_, expr) -> 233 | false, DocOckCmi.read_type_expr env expr.exp_type 234 | in 235 | Some (InstanceVariable {id; doc; mutable_; virtual_; type_}) 236 | | Tcf_method({txt = name; _}, private_, kind) -> 237 | let open Method in 238 | let name = parenthesise name in 239 | let id = Identifier.Method(parent, name) in 240 | let private_ = (private_ = Private) in 241 | let virtual_, type_ = 242 | match kind with 243 | | Tcfk_virtual typ -> 244 | true, read_core_type env typ 245 | | Tcfk_concrete(_, expr) -> 246 | false, DocOckCmi.read_type_expr env expr.exp_type 247 | in 248 | Some (Method {id; doc; private_; virtual_; type_}) 249 | | Tcf_constraint(_, _) -> None 250 | | Tcf_inherit(_, cl, _, _, _) -> 251 | Some (Inherit (read_class_structure env parent [] cl)) 252 | | Tcf_initializer _ -> None 253 | | Tcf_attribute attr -> 254 | match read_comment container attr with 255 | | None -> None 256 | | Some doc -> Some (Comment doc) 257 | 258 | and read_class_structure env parent params cl = 259 | let open ClassType in 260 | match cl.cl_desc with 261 | | Tcl_ident _ | Tcl_apply _ -> 262 | DocOckCmi.read_class_signature env parent params cl.cl_type 263 | | Tcl_structure cstr -> 264 | let open ClassSignature in 265 | let self = DocOckCmi.read_self_type cstr.cstr_self.pat_type in 266 | let constraints = 267 | DocOckCmi.read_type_constraints env params 268 | in 269 | let constraints = 270 | List.map 271 | (fun (typ1, typ2) -> Constraint(typ1, typ2)) 272 | constraints 273 | in 274 | let items = 275 | List.fold_left 276 | (fun rest item -> 277 | match read_class_field env parent item with 278 | | None -> rest 279 | | Some item -> item :: rest) 280 | [] cstr.cstr_fields 281 | in 282 | let items = constraints @ List.rev items in 283 | Signature {self; items} 284 | | Tcl_fun _ -> assert false 285 | | Tcl_let(_, _, _, cl) -> read_class_structure env parent params cl 286 | | Tcl_constraint(cl, None, _, _, _) -> read_class_structure env parent params cl 287 | | Tcl_constraint(_, Some cltyp, _, _, _) -> 288 | read_class_signature env parent params cltyp 289 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 290 | | Tcl_open (_, _, _, _, cl) -> read_class_structure env parent params cl 291 | #endif 292 | 293 | let rec read_class_expr env parent params cl = 294 | let open Class in 295 | match cl.cl_desc with 296 | | Tcl_ident _ | Tcl_apply _ -> 297 | DocOckCmi.read_class_type env parent params cl.cl_type 298 | | Tcl_structure _ -> 299 | ClassType (read_class_structure env parent params cl) 300 | | Tcl_fun(lbl, arg, _, res, _) -> 301 | let lbl = DocOckCmi.read_label lbl in 302 | let arg = DocOckCmi.read_type_expr env arg.pat_type in 303 | let res = read_class_expr env parent params res in 304 | Arrow(lbl, arg, res) 305 | | Tcl_let(_, _, _, cl) -> 306 | read_class_expr env parent params cl 307 | | Tcl_constraint(cl, None, _, _, _) -> 308 | read_class_expr env parent params cl 309 | | Tcl_constraint(_, Some cltyp, _, _, _) -> 310 | read_class_type env parent params cltyp 311 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 312 | | Tcl_open (_, _, _, _, cl) -> read_class_expr env parent params cl 313 | #endif 314 | 315 | let read_class_declaration env parent cld = 316 | let open Class in 317 | let name = parenthesise (Ident.name cld.ci_id_class) in 318 | let id = Identifier.Class(parent, name) in 319 | let container = 320 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 321 | in 322 | let doc = read_attributes container id cld.ci_attributes in 323 | DocOckCmi.mark_class_declaration cld.ci_decl; 324 | let virtual_ = (cld.ci_virt = Virtual) in 325 | let clparams = 326 | List.map (fun (ctyp, _) -> ctyp.ctyp_type) cld.ci_params 327 | in 328 | let params = 329 | List.map 330 | (DocOckCmi.read_type_parameter false Variance.null) 331 | clparams 332 | in 333 | let type_ = read_class_expr env id clparams cld.ci_expr in 334 | { id; doc; virtual_; params; type_; expansion = None } 335 | 336 | let read_class_declarations env parent clds = 337 | let container = 338 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 339 | in 340 | let items = 341 | List.fold_left 342 | (fun acc cld -> 343 | let open Signature in 344 | let comments = read_comments container cld.ci_attributes in 345 | let comments = List.map (fun com -> Comment com) comments in 346 | let cld = read_class_declaration env parent cld in 347 | (Class cld) :: (List.rev_append comments acc)) 348 | [] clds 349 | in 350 | List.rev items 351 | 352 | let rec read_module_expr env parent pos mexpr = 353 | let open ModuleType in 354 | match mexpr.mod_desc with 355 | | Tmod_ident _ -> 356 | DocOckCmi.read_module_type env parent pos mexpr.mod_type 357 | | Tmod_structure str -> Signature (read_structure env parent str) 358 | | Tmod_functor(id, _, arg, res) -> 359 | let arg = 360 | match arg with 361 | | None -> None 362 | | Some arg -> 363 | let name = parenthesise (Ident.name id) in 364 | let id = Identifier.Argument(parent, pos, name) in 365 | let arg = DocOckCmti.read_module_type env id 1 arg in 366 | let expansion = 367 | match arg with 368 | | Signature _ -> Some Module.AlreadyASig 369 | | _ -> None 370 | in 371 | Some { FunctorArgument. id; expr = arg; expansion } 372 | in 373 | let env = Env.add_argument parent pos id env in 374 | let res = read_module_expr env parent (pos + 1) res in 375 | Functor(arg, res) 376 | | Tmod_apply _ -> 377 | DocOckCmi.read_module_type env parent pos mexpr.mod_type 378 | | Tmod_constraint(_, _, Tmodtype_explicit mty, _) -> 379 | DocOckCmti.read_module_type env parent pos mty 380 | | Tmod_constraint(mexpr, _, Tmodtype_implicit, _) -> 381 | read_module_expr env parent pos mexpr 382 | | Tmod_unpack(_, mty) -> 383 | DocOckCmi.read_module_type env parent pos mty 384 | 385 | and unwrap_module_expr_desc = function 386 | | Tmod_constraint(mexpr, _, Tmodtype_implicit, _) -> 387 | unwrap_module_expr_desc mexpr.mod_desc 388 | | desc -> desc 389 | 390 | and read_module_binding env parent mb = 391 | let open Module in 392 | let name = parenthesise (Ident.name mb.mb_id) in 393 | let id = Identifier.Module(parent, name) in 394 | let container = 395 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 396 | in 397 | let doc = read_attributes container id mb.mb_attributes in 398 | let canonical = 399 | let open Documentation in 400 | match doc with 401 | | Ok { tags; _ } -> 402 | begin match List.find (function Canonical _ -> true | _ -> false) tags with 403 | | exception Not_found -> None 404 | | Canonical(p, r) -> Some (p, r) 405 | | _ -> None 406 | end 407 | | _ -> None 408 | in 409 | let type_ = 410 | match unwrap_module_expr_desc mb.mb_expr.mod_desc with 411 | | Tmod_ident(p, _) -> Alias (Env.Path.read_module env p) 412 | | _ -> ModuleType (read_module_expr env id 1 mb.mb_expr) 413 | in 414 | let hidden = 415 | match canonical with 416 | | Some _ -> false 417 | | None -> contains_double_underscore (Ident.name mb.mb_id) 418 | in 419 | let expansion = 420 | match type_ with 421 | | ModuleType (ModuleType.Signature _) -> Some AlreadyASig 422 | | _ -> None 423 | in 424 | {id; doc; type_; expansion; canonical; hidden; display_type = None} 425 | 426 | and read_module_bindings env parent mbs = 427 | let container = 428 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 429 | in 430 | let items = 431 | List.fold_left 432 | (fun acc mb -> 433 | let open Signature in 434 | let comments = read_comments container mb.mb_attributes in 435 | let comments = List.map (fun com -> Comment com) comments in 436 | let mb = read_module_binding env parent mb in 437 | (Module mb) :: (List.rev_append comments acc)) 438 | [] mbs 439 | in 440 | List.rev items 441 | 442 | and read_structure_item env parent item = 443 | let open Signature in 444 | match item.str_desc with 445 | | Tstr_eval _ -> [] 446 | | Tstr_value(_, vbs) -> 447 | read_value_bindings env parent vbs 448 | | Tstr_primitive vd -> 449 | [DocOckCmti.read_value_description env parent vd] 450 | | Tstr_type (_rec_flag, decls) -> (* TODO: handle rec_flag *) 451 | DocOckCmti.read_type_declarations env parent decls 452 | | Tstr_typext tyext -> 453 | [TypExt (read_type_extension env parent tyext)] 454 | | Tstr_exception ext -> 455 | let ext = 456 | DocOckCmi.read_exception env parent ext.ext_id ext.ext_type 457 | in 458 | [Exception ext] 459 | | Tstr_module mb -> 460 | [Module (read_module_binding env parent mb)] 461 | | Tstr_recmodule mbs -> 462 | read_module_bindings env parent mbs 463 | | Tstr_modtype mtd -> 464 | [ModuleType (DocOckCmti.read_module_type_declaration env parent mtd)] 465 | | Tstr_open _ -> [] 466 | | Tstr_include incl -> 467 | [Include (read_include env parent incl)] 468 | | Tstr_class cls -> 469 | let cls = List.map (fun (cl, _) -> cl) cls in 470 | read_class_declarations env parent cls 471 | | Tstr_class_type cltyps -> 472 | let cltyps = List.map (fun (_, _, clty) -> clty) cltyps in 473 | DocOckCmti.read_class_type_declarations env parent cltyps 474 | | Tstr_attribute attr -> 475 | let container = 476 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 477 | in 478 | match read_comment container attr with 479 | | None -> [] 480 | | Some doc -> [Comment doc] 481 | 482 | and read_include env parent incl = 483 | let open Include in 484 | let container = 485 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 486 | in 487 | let doc = read_attributes container parent incl.incl_attributes in 488 | let decl = 489 | let open Module in 490 | match unwrap_module_expr_desc incl.incl_mod.mod_desc with 491 | | Tmod_ident(p, _) -> Alias (Env.Path.read_module env p) 492 | | _ -> ModuleType (read_module_expr env parent 1 incl.incl_mod) 493 | in 494 | let content = DocOckCmi.read_signature env parent incl.incl_type in 495 | let expansion = { content; resolved = false } in 496 | {parent; doc; decl; expansion} 497 | 498 | and read_structure env parent str = 499 | let env = Env.add_structure_tree_items parent str env in 500 | let items = 501 | List.fold_left 502 | (fun items item -> 503 | List.rev_append (read_structure_item env parent item) items) 504 | [] str.str_items 505 | in 506 | List.rev items 507 | 508 | let read_implementation root name impl = 509 | let id = Identifier.Root(root, name) in 510 | let items = read_structure Env.empty id impl in 511 | let doc, items = 512 | let open Signature in 513 | let open Documentation in 514 | match items with 515 | | Comment (Documentation doc) :: items -> doc, items 516 | | _ -> empty, items 517 | in 518 | (id, doc, items) 519 | -------------------------------------------------------------------------------- /src/docOckCmt.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | val read_implementation: 'a -> string -> Typedtree.structure -> 18 | 'a DocOckPaths.Identifier.module_ * 19 | 'a DocOckTypes.Documentation.t * 20 | 'a DocOckTypes.Signature.t 21 | -------------------------------------------------------------------------------- /src/docOckCmti.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Asttypes 18 | open Typedtree 19 | 20 | module OCamlPath = Path 21 | 22 | open DocOckPaths 23 | open DocOckTypes 24 | open DocOckAttrs 25 | 26 | module Env = DocOckIdentEnv 27 | 28 | let opt_map f = function 29 | | None -> None 30 | | Some x -> Some (f x) 31 | 32 | let parenthesise name = 33 | match name with 34 | | "asr" | "land" | "lnot" | "lor" | "lsl" | "lsr" 35 | | "lxor" | "mod" -> "(" ^ name ^ ")" 36 | | _ -> 37 | if (String.length name > 0) then 38 | match name.[0] with 39 | | 'a' .. 'z' | '\223' .. '\246' | '\248' .. '\255' | '_' 40 | | 'A' .. 'Z' | '\192' .. '\214' | '\216' .. '\222' -> name 41 | | _ -> "(" ^ name ^ ")" 42 | else name 43 | 44 | let read_label = DocOckCmi.read_label 45 | 46 | let rec read_core_type env ctyp = 47 | let open TypeExpr in 48 | match ctyp.ctyp_desc with 49 | | Ttyp_any -> Any 50 | | Ttyp_var s -> Var s 51 | | Ttyp_arrow(lbl, arg, res) -> 52 | let arg = read_core_type env arg in 53 | let lbl = read_label lbl in 54 | let res = read_core_type env res in 55 | Arrow(lbl, arg, res) 56 | | Ttyp_tuple typs -> 57 | let typs = List.map (read_core_type env) typs in 58 | Tuple typs 59 | | Ttyp_constr(p, _, params) -> 60 | let p = Env.Path.read_type env p in 61 | let params = List.map (read_core_type env) params in 62 | Constr(p, params) 63 | | Ttyp_object(methods, closed) -> 64 | let open TypeExpr.Object in 65 | let fields = 66 | List.map 67 | #if OCAML_MAJOR = 4 && OCAML_MINOR < 06 68 | (fun (name, _, typ) -> Method {name; type_ = read_core_type env typ}) 69 | #else 70 | (function 71 | | OTtag (name, _, typ) -> 72 | Method {name = name.txt; type_ = read_core_type env typ} 73 | | OTinherit typ -> Inherit (read_core_type env typ)) 74 | #endif 75 | methods 76 | in 77 | Object {fields; open_ = (closed = Asttypes.Open)} 78 | | Ttyp_class(p, _, params) -> 79 | let p = Env.Path.read_class_type env p in 80 | let params = List.map (read_core_type env) params in 81 | Class(p, params) 82 | | Ttyp_alias(typ, var) -> 83 | let typ = read_core_type env typ in 84 | Alias(typ, var) 85 | | Ttyp_variant(fields, closed, present) -> 86 | let open TypeExpr.Variant in 87 | let elements = 88 | List.map 89 | (function 90 | | Ttag(name, _, const, args) -> 91 | let args = List.map (read_core_type env) args in 92 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 93 | let name = name.txt in 94 | #endif 95 | Constructor(name, const, args) 96 | | Tinherit typ -> Type (read_core_type env typ)) 97 | fields 98 | in 99 | let kind = 100 | if closed = Asttypes.Open then Open 101 | else match present with 102 | | None -> Fixed 103 | | Some names -> Closed names 104 | in 105 | Variant {kind; elements} 106 | | Ttyp_poly([], typ) -> read_core_type env typ 107 | | Ttyp_poly(vars, typ) -> Poly(vars, read_core_type env typ) 108 | | Ttyp_package {pack_path; pack_fields; _} -> 109 | let open TypeExpr.Package in 110 | let path = Env.Path.read_module_type env pack_path in 111 | let substitutions = 112 | List.map 113 | (fun (frag, typ) -> 114 | let frag = Env.Fragment.read_type frag.Location.txt in 115 | let typ = read_core_type env typ in 116 | (frag, typ)) 117 | pack_fields 118 | in 119 | Package {path; substitutions} 120 | 121 | let read_value_description env parent vd = 122 | let open Signature in 123 | let name = parenthesise (Ident.name vd.val_id) in 124 | let id = Identifier.Value(parent, name) in 125 | let container = 126 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 127 | in 128 | let doc = read_attributes container id vd.val_attributes in 129 | let type_ = read_core_type env vd.val_desc in 130 | match vd.val_prim with 131 | | [] -> Value {Value.id; doc; type_} 132 | | primitives -> External {External.id; doc; type_; primitives} 133 | 134 | let read_type_parameter (ctyp, var) = 135 | let open TypeDecl in 136 | let desc = 137 | match ctyp.ctyp_desc with 138 | | Ttyp_any -> Any 139 | | Ttyp_var s -> Var s 140 | | _ -> assert false 141 | in 142 | let var = 143 | match var with 144 | | Covariant -> Some Pos 145 | | Contravariant -> Some Neg 146 | | Invariant -> None 147 | in 148 | (desc, var) 149 | 150 | let read_label_declaration env parent ld = 151 | let open TypeDecl.Field in 152 | let name = parenthesise (Ident.name ld.ld_id) in 153 | let id = Identifier.Field(parent, name) in 154 | let doc = 155 | read_attributes (Identifier.label_parent_of_parent parent) id ld.ld_attributes 156 | in 157 | let mutable_ = (ld.ld_mutable = Mutable) in 158 | let type_ = read_core_type env ld.ld_type in 159 | {id; doc; mutable_; type_} 160 | 161 | let read_constructor_declaration_arguments env parent arg = 162 | let open TypeDecl.Constructor in 163 | match arg with 164 | | Cstr_tuple args -> Tuple (List.map (read_core_type env) args) 165 | | Cstr_record lds -> 166 | Record (List.map (read_label_declaration env parent) lds) 167 | 168 | let read_constructor_declaration env parent cd = 169 | let open TypeDecl.Constructor in 170 | let name = parenthesise (Ident.name cd.cd_id) in 171 | let id = Identifier.Constructor(parent, name) in 172 | let container = Identifier.parent_of_datatype parent in 173 | let doc = read_attributes (Identifier.label_parent_of_parent container) id cd.cd_attributes in 174 | let args = read_constructor_declaration_arguments env container cd.cd_args in 175 | let res = opt_map (read_core_type env) cd.cd_res in 176 | {id; doc; args; res} 177 | 178 | let read_type_kind env parent = 179 | let open TypeDecl.Representation in function 180 | | Ttype_abstract -> None 181 | | Ttype_variant cstrs -> 182 | let cstrs = List.map (read_constructor_declaration env parent) cstrs in 183 | Some (Variant cstrs) 184 | | Ttype_record lbls -> 185 | let parent = Identifier.parent_of_datatype parent in 186 | let lbls = List.map (read_label_declaration env parent) lbls in 187 | Some (Record lbls) 188 | | Ttype_open -> Some Extensible 189 | 190 | let read_type_equation env decl = 191 | let open TypeDecl.Equation in 192 | let params = List.map read_type_parameter decl.typ_params in 193 | let private_ = (decl.typ_private = Private) in 194 | let manifest = opt_map (read_core_type env) decl.typ_manifest in 195 | let constraints = 196 | List.map 197 | (fun (typ1, typ2, _) -> 198 | (read_core_type env typ1, 199 | read_core_type env typ2)) 200 | decl.typ_cstrs 201 | in 202 | {params; private_; manifest; constraints} 203 | 204 | let read_type_declaration env parent decl = 205 | let open TypeDecl in 206 | let name = parenthesise (Ident.name decl.typ_id) in 207 | let id = Identifier.Type(parent, name) in 208 | let container = 209 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 210 | in 211 | let doc = read_attributes container id decl.typ_attributes in 212 | let equation = read_type_equation env decl in 213 | let representation = read_type_kind env id decl.typ_kind in 214 | {id; doc; equation; representation} 215 | 216 | let read_type_declarations env parent decls = 217 | let container = 218 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 219 | in 220 | let items = 221 | List.fold_left 222 | (fun acc decl -> 223 | let open Signature in 224 | let comments = read_comments container decl.typ_attributes in 225 | let comments = List.map (fun com -> Comment com) comments in 226 | let decl = read_type_declaration env parent decl in 227 | (Type decl) :: (List.rev_append comments acc)) 228 | [] decls 229 | in 230 | List.rev items 231 | 232 | let read_extension_constructor env parent ext = 233 | let open Extension.Constructor in 234 | let name = parenthesise (Ident.name ext.ext_id) in 235 | let id = Identifier.Extension(parent, name) in 236 | let container = Identifier.parent_of_signature parent in 237 | let doc = read_attributes (Identifier.label_parent_of_parent container) id ext.ext_attributes in 238 | match ext.ext_kind with 239 | | Text_rebind _ -> assert false 240 | | Text_decl(args, res) -> 241 | let args = read_constructor_declaration_arguments env container args in 242 | let res = opt_map (read_core_type env) res in 243 | {id; doc; args; res} 244 | 245 | let read_type_extension env parent tyext = 246 | let open Extension in 247 | let type_path = Env.Path.read_type env tyext.tyext_path in 248 | let container = 249 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 250 | in 251 | let doc = read_attributes container parent tyext.tyext_attributes in 252 | let type_params = List.map read_type_parameter tyext.tyext_params in 253 | let private_ = (tyext.tyext_private = Private) in 254 | let constructors = 255 | List.map (read_extension_constructor env parent) tyext.tyext_constructors 256 | in 257 | { type_path; doc; type_params; private_; constructors; } 258 | 259 | let read_exception env parent ext = 260 | let open Exception in 261 | let name = parenthesise (Ident.name ext.ext_id) in 262 | let id = Identifier.Exception(parent, name) in 263 | let container = Identifier.parent_of_signature parent in 264 | let doc = read_attributes (Identifier.label_parent_of_parent container) id ext.ext_attributes in 265 | match ext.ext_kind with 266 | | Text_rebind _ -> assert false 267 | | Text_decl(args, res) -> 268 | let args = read_constructor_declaration_arguments env container args in 269 | let res = opt_map (read_core_type env) res in 270 | {id; doc; args; res} 271 | 272 | let rec read_class_type_field env parent ctf = 273 | let open ClassSignature in 274 | let container = 275 | Identifier.label_parent_of_parent 276 | (Identifier.parent_of_class_signature parent) 277 | in 278 | let doc = read_attributes container parent ctf.ctf_attributes in 279 | match ctf.ctf_desc with 280 | | Tctf_val(name, mutable_, virtual_, typ) -> 281 | let open InstanceVariable in 282 | let name = parenthesise name in 283 | let id = Identifier.InstanceVariable(parent, name) in 284 | let mutable_ = (mutable_ = Mutable) in 285 | let virtual_ = (virtual_ = Virtual) in 286 | let type_ = read_core_type env typ in 287 | Some (InstanceVariable {id; doc; mutable_; virtual_; type_}) 288 | | Tctf_method(name, private_, virtual_, typ) -> 289 | let open Method in 290 | let name = parenthesise name in 291 | let id = Identifier.Method(parent, name) in 292 | let private_ = (private_ = Private) in 293 | let virtual_ = (virtual_ = Virtual) in 294 | let type_ = read_core_type env typ in 295 | Some (Method {id; doc; private_; virtual_; type_}) 296 | | Tctf_constraint(typ1, typ2) -> 297 | let typ1 = read_core_type env typ1 in 298 | let typ2 = read_core_type env typ2 in 299 | Some (Constraint(typ1, typ2)) 300 | | Tctf_inherit cltyp -> 301 | Some (Inherit (read_class_signature env parent cltyp)) 302 | | Tctf_attribute attr -> 303 | match read_comment container attr with 304 | | None -> None 305 | | Some doc -> Some (Comment doc) 306 | 307 | and read_self_type env typ = 308 | if typ.ctyp_desc = Ttyp_any then None 309 | else Some (read_core_type env typ) 310 | 311 | and read_class_signature env parent cltyp = 312 | let open ClassType in 313 | match cltyp.cltyp_desc with 314 | | Tcty_constr(p, _, params) -> 315 | let p = Env.Path.read_class_type env p in 316 | let params = List.map (read_core_type env) params in 317 | Constr(p, params) 318 | | Tcty_signature csig -> 319 | let open ClassSignature in 320 | let self = read_self_type env csig.csig_self in 321 | let items = 322 | List.fold_left 323 | (fun rest item -> 324 | match read_class_type_field env parent item with 325 | | None -> rest 326 | | Some item -> item :: rest) 327 | [] csig.csig_fields 328 | in 329 | let items = List.rev items in 330 | Signature {self; items} 331 | | Tcty_arrow _ -> assert false 332 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 333 | | Tcty_open _ -> assert false 334 | #endif 335 | 336 | let read_class_type_declaration env parent cltd = 337 | let open ClassType in 338 | let name = parenthesise (Ident.name cltd.ci_id_class_type) in 339 | let id = Identifier.ClassType(parent, name) in 340 | let container = 341 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 342 | in 343 | let doc = read_attributes container id cltd.ci_attributes in 344 | let virtual_ = (cltd.ci_virt = Virtual) in 345 | let params = List.map read_type_parameter cltd.ci_params in 346 | let expr = read_class_signature env id cltd.ci_expr in 347 | { id; doc; virtual_; params; expr; expansion = None } 348 | 349 | let read_class_type_declarations env parent cltds = 350 | let container = 351 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 352 | in 353 | let items = 354 | List.fold_left 355 | (fun acc cltd -> 356 | let open Signature in 357 | let comments = read_comments container cltd.ci_attributes in 358 | let comments = List.map (fun com -> Comment com) comments in 359 | let cltd = read_class_type_declaration env parent cltd in 360 | (ClassType cltd) :: (List.rev_append comments acc)) 361 | [] cltds 362 | in 363 | List.rev items 364 | 365 | let rec read_class_type env parent cty = 366 | let open Class in 367 | match cty.cltyp_desc with 368 | | Tcty_constr _ | Tcty_signature _ -> 369 | ClassType (read_class_signature env parent cty) 370 | | Tcty_arrow(lbl, arg, res) -> 371 | let lbl = read_label lbl in 372 | let arg = read_core_type env arg in 373 | let res = read_class_type env parent res in 374 | Arrow(lbl, arg, res) 375 | #if OCAML_MAJOR = 4 && OCAML_MINOR >= 06 376 | | Tcty_open (_, _, _, _, cty) -> read_class_type env parent cty 377 | #endif 378 | 379 | let read_class_description env parent cld = 380 | let open Class in 381 | let name = parenthesise (Ident.name cld.ci_id_class) in 382 | let id = Identifier.Class(parent, name) in 383 | let container = 384 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 385 | in 386 | let doc = read_attributes container id cld.ci_attributes in 387 | let virtual_ = (cld.ci_virt = Virtual) in 388 | let params = List.map read_type_parameter cld.ci_params in 389 | let type_ = read_class_type env id cld.ci_expr in 390 | { id; doc; virtual_; params; type_; expansion = None } 391 | 392 | let read_class_descriptions env parent clds = 393 | let container = 394 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 395 | in 396 | let items = 397 | List.fold_left 398 | (fun acc cld -> 399 | let open Signature in 400 | let comments = read_comments container cld.ci_attributes in 401 | let comments = List.map (fun com -> Comment com) comments in 402 | let cld = read_class_description env parent cld in 403 | (Class cld) :: (List.rev_append comments acc)) 404 | [] clds 405 | in 406 | List.rev items 407 | 408 | let rec read_with_constraint env (_, frag, constr) = 409 | let open ModuleType in 410 | match constr with 411 | | Twith_type decl -> 412 | let frag = Env.Fragment.read_type frag.Location.txt in 413 | let eq = read_type_equation env decl in 414 | TypeEq(frag, eq) 415 | | Twith_module(p, _) -> 416 | let frag = Env.Fragment.read_module frag.Location.txt in 417 | let eq = read_module_equation env p in 418 | ModuleEq(frag, eq) 419 | | Twith_typesubst decl -> 420 | let frag = Env.Fragment.read_type frag.Location.txt in 421 | let eq = read_type_equation env decl in 422 | TypeSubst(frag, eq) 423 | | Twith_modsubst(p, _) -> 424 | let frag = Env.Fragment.read_module frag.Location.txt in 425 | let p = Env.Path.read_module env p in 426 | ModuleSubst(frag, p) 427 | 428 | and read_module_type env parent pos mty = 429 | let open ModuleType in 430 | match mty.mty_desc with 431 | | Tmty_ident(p, _) -> Path (Env.Path.read_module_type env p) 432 | | Tmty_signature sg -> Signature (read_signature env parent sg) 433 | | Tmty_functor(id, _, arg, res) -> 434 | let arg = 435 | match arg with 436 | | None -> None 437 | | Some arg -> 438 | let name = parenthesise (Ident.name id) in 439 | let id = Identifier.Argument(parent, pos, name) in 440 | let arg = read_module_type env id 1 arg in 441 | let expansion = 442 | match arg with 443 | | Signature _ -> Some Module.AlreadyASig 444 | | _ -> None 445 | in 446 | Some { FunctorArgument. id; expr = arg; expansion } 447 | in 448 | let env = Env.add_argument parent pos id env in 449 | let res = read_module_type env parent (pos + 1) res in 450 | Functor(arg, res) 451 | | Tmty_with(body, subs) -> 452 | let body = read_module_type env parent pos body in 453 | let subs = List.map (read_with_constraint env) subs in 454 | With(body, subs) 455 | | Tmty_typeof mexpr -> 456 | let decl = 457 | let open Module in 458 | match mexpr.mod_desc with 459 | | Tmod_ident(p, _) -> Alias (Env.Path.read_module env p) 460 | | _ -> 461 | let mty = 462 | DocOckCmi.read_module_type env parent pos mexpr.mod_type 463 | in 464 | ModuleType mty 465 | in 466 | TypeOf decl 467 | | Tmty_alias _ -> assert false 468 | 469 | and read_module_type_declaration env parent mtd = 470 | let open ModuleType in 471 | let name = parenthesise (Ident.name mtd.mtd_id) in 472 | let id = Identifier.ModuleType(parent, name) in 473 | let container = 474 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 475 | in 476 | let doc = read_attributes container id mtd.mtd_attributes in 477 | let expr = opt_map (read_module_type env id 1) mtd.mtd_type in 478 | let expansion = 479 | match expr with 480 | | Some (Signature _) -> Some Module.AlreadyASig 481 | | _ -> None 482 | in 483 | {id; doc; expr; expansion} 484 | 485 | and read_module_declaration env parent md = 486 | let open Module in 487 | let name = parenthesise (Ident.name md.md_id) in 488 | let id = Identifier.Module(parent, name) in 489 | let container = 490 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 491 | in 492 | let doc = read_attributes container id md.md_attributes in 493 | let canonical = 494 | let open Documentation in 495 | match doc with 496 | | Ok { tags; _ } -> 497 | begin match List.find (function Canonical _ -> true | _ -> false) tags with 498 | | exception Not_found -> None 499 | | Canonical(p, r) -> Some (p, r) 500 | | _ -> None 501 | end 502 | | _ -> None 503 | in 504 | let type_ = 505 | match md.md_type.mty_desc with 506 | | Tmty_alias(p, _) -> Alias (Env.Path.read_module env p) 507 | | _ -> ModuleType (read_module_type env id 1 md.md_type) 508 | in 509 | let hidden = 510 | match canonical with 511 | | Some _ -> false 512 | | None -> contains_double_underscore (Ident.name md.md_id) 513 | in 514 | let expansion = 515 | match type_ with 516 | | ModuleType (ModuleType.Signature _) -> Some AlreadyASig 517 | | _ -> None 518 | in 519 | {id; doc; type_; expansion; canonical; hidden; display_type = None} 520 | 521 | and read_module_declarations env parent mds = 522 | let container = 523 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 524 | in 525 | let items = 526 | List.fold_left 527 | (fun acc md -> 528 | let open Signature in 529 | let comments = read_comments container md.md_attributes in 530 | let comments = List.map (fun com -> Comment com) comments in 531 | let md = read_module_declaration env parent md in 532 | (Module md) :: (List.rev_append comments acc)) 533 | [] mds 534 | in 535 | List.rev items 536 | 537 | and read_module_equation env p = 538 | let open Module in 539 | Alias (Env.Path.read_module env p) 540 | 541 | and read_signature_item env parent item = 542 | let open Signature in 543 | match item.sig_desc with 544 | | Tsig_value vd -> 545 | [read_value_description env parent vd] 546 | | Tsig_type (_rec_flag, decls) -> (* TODO: handle rec flag. *) 547 | read_type_declarations env parent decls 548 | | Tsig_typext tyext -> 549 | [TypExt (read_type_extension env parent tyext)] 550 | | Tsig_exception ext -> 551 | [Exception (read_exception env parent ext)] 552 | | Tsig_module md -> 553 | [Module (read_module_declaration env parent md)] 554 | | Tsig_recmodule mds -> 555 | read_module_declarations env parent mds 556 | | Tsig_modtype mtd -> 557 | [ModuleType (read_module_type_declaration env parent mtd)] 558 | | Tsig_open _ -> [] 559 | | Tsig_include incl -> 560 | [Include (read_include env parent incl)] 561 | | Tsig_class cls -> 562 | read_class_descriptions env parent cls 563 | | Tsig_class_type cltyps -> 564 | read_class_type_declarations env parent cltyps 565 | | Tsig_attribute attr -> 566 | let container = 567 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 568 | in 569 | match read_comment container attr with 570 | | None -> [] 571 | | Some doc -> [Comment doc] 572 | 573 | and read_include env parent incl = 574 | let open Include in 575 | let container = 576 | Identifier.label_parent_of_parent (Identifier.parent_of_signature parent) 577 | in 578 | let doc = read_attributes container parent incl.incl_attributes in 579 | let expr = read_module_type env parent 1 incl.incl_mod in 580 | let decl = Module.ModuleType expr in 581 | let content = DocOckCmi.read_signature env parent incl.incl_type in 582 | let expansion = { content; resolved = false} in 583 | {parent; doc; decl; expansion} 584 | 585 | and read_signature env parent sg = 586 | let env = 587 | Env.add_signature_tree_items parent sg env 588 | in 589 | let items = 590 | List.fold_left 591 | (fun items item -> 592 | List.rev_append (read_signature_item env parent item) items) 593 | [] sg.sig_items 594 | in 595 | List.rev items 596 | 597 | let read_interface root name intf = 598 | let id = Identifier.Root(root, name) in 599 | let items = read_signature Env.empty id intf in 600 | let doc, items = 601 | let open Signature in 602 | let open Documentation in 603 | match items with 604 | | Comment (Documentation doc) :: items -> doc, items 605 | | _ -> empty, items 606 | in 607 | (id, doc, items) 608 | -------------------------------------------------------------------------------- /src/docOckCmti.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | val read_interface: 'a -> string -> Typedtree.signature -> 18 | 'a DocOckPaths.Identifier.module_ * 19 | 'a DocOckTypes.Documentation.t * 20 | 'a DocOckTypes.Signature.t 21 | 22 | val read_module_type : 'a DocOckIdentEnv.t -> 23 | 'a DocOckPaths.Identifier.signature -> int -> 24 | Typedtree.module_type -> 'a DocOckTypes.ModuleType.expr 25 | 26 | val read_value_description : 'a DocOckIdentEnv.t -> 27 | 'a DocOckPaths.Identifier.signature -> 28 | Typedtree.value_description -> 'a DocOckTypes.Signature.item 29 | 30 | val read_type_declarations : 'a DocOckIdentEnv.t -> 31 | 'a DocOckPaths.Identifier.signature -> 32 | Typedtree.type_declaration list -> 33 | 'a DocOckTypes.Signature.item list 34 | 35 | val read_module_type_declaration : 'a DocOckIdentEnv.t -> 36 | 'a DocOckPaths.Identifier.signature -> 37 | Typedtree.module_type_declaration -> 'a DocOckTypes.ModuleType.t 38 | 39 | val read_class_type_declarations : 'a DocOckIdentEnv.t -> 40 | 'a DocOckPaths.Identifier.signature -> 41 | Typedtree.class_type Typedtree.class_infos list -> 42 | 'a DocOckTypes.Signature.item list 43 | -------------------------------------------------------------------------------- /src/docOckComponentTbl.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | open DocOckComponents 20 | 21 | type ('a, 'b) tbl = 22 | { fresh: int -> ('a, 'b) tbl; 23 | find: 'a -> 'b; 24 | add: 'a -> 'b -> unit; } 25 | 26 | let make_tbl (type a) (equal : (a -> a -> bool) option) 27 | (hash : (a -> int) option) size = 28 | let make create find add = 29 | let rec fresh size = 30 | let t = create size in 31 | let find x = find t x in 32 | let add x y = add t x y in 33 | {fresh; find; add} 34 | in 35 | fresh size 36 | in 37 | match equal, hash with 38 | | None, None -> 39 | make (Hashtbl.create ?random:None) Hashtbl.find Hashtbl.add 40 | | _ -> 41 | let equal = 42 | match equal with 43 | | None -> (=) 44 | | Some eq -> eq 45 | in 46 | let hash = 47 | match hash with 48 | | None -> Hashtbl.hash 49 | | Some h -> h 50 | in 51 | let module Hash = struct 52 | type t = a 53 | let equal = equal 54 | let hash = hash 55 | end in 56 | let module Tbl = Hashtbl.Make(Hash) in 57 | make Tbl.create Tbl.find Tbl.add 58 | 59 | type 'a lookup_unit_result = 60 | | Forward_reference 61 | | Found of { root : 'a; hidden : bool } 62 | | Not_found 63 | 64 | type 'a t = 65 | { equal : ('a -> 'a -> bool) option; 66 | hash : ('a -> int) option; 67 | lookup_unit : string -> 'a lookup_unit_result; 68 | lookup_page : string -> 'a option; 69 | fetch_unit : 'a -> 'a Unit.t; 70 | fetch_page : 'a -> 'a DocOckTypes.Page.t; 71 | tbl : ('a, 'a Sig.t) tbl; 72 | page_tbl: ('a, 'a Page.t) tbl; } 73 | 74 | let create ?equal ?hash lookup_unit fetch_unit lookup_page fetch_page = 75 | let tbl = make_tbl equal hash 7 in 76 | let page_tbl = make_tbl equal hash 7 in 77 | {equal; hash; lookup_unit; fetch_unit; lookup_page; fetch_page; tbl; page_tbl} 78 | 79 | type 'a local = 80 | { t : 'a t; 81 | local : ('a Identifier.signature, 'a Sig.t) tbl option; 82 | base : 'a Identifier.signature option; } 83 | 84 | let create_local t base = 85 | let equal = 86 | match t.equal with 87 | | None -> None 88 | | Some equal -> Some (Identifier.equal ~equal) 89 | in 90 | let hash = 91 | match t.hash with 92 | | None -> None 93 | | Some hash -> Some (Identifier.hash ~hash) 94 | in 95 | let local = 96 | match base with 97 | | None -> None 98 | | Some _ -> Some (make_tbl equal hash 23) 99 | in 100 | { t; local; base; } 101 | 102 | let add_local_module_identifier (local : 'a local) id sg = 103 | let open Identifier in 104 | match local.local with 105 | | None -> () 106 | | Some tbl -> tbl.add (signature_of_module id) sg 107 | 108 | let add_local_module_type_identifier (local : 'a local) id sg = 109 | let open Identifier in 110 | match local.local with 111 | | None -> () 112 | | Some tbl -> tbl.add (signature_of_module_type id) sg 113 | 114 | let add_local_modules (local : 'a local) id mds = 115 | let open Identifier in 116 | match local.local with 117 | | None -> () 118 | | Some tbl -> 119 | List.iter 120 | (fun (name, sg) -> tbl.add (Module(id, name)) sg) 121 | mds 122 | 123 | let add_local_module_types (local : 'a local) id mtys = 124 | let open Identifier in 125 | match local.local with 126 | | None -> () 127 | | Some tbl -> 128 | List.iter 129 | (fun (name, sg) -> tbl.add (ModuleType(id, name)) sg) 130 | mtys 131 | 132 | let equals_signature (type k) eq 133 | (base : 'a Identifier.signature) (id : ('a, k) Identifier.t) = 134 | let open Identifier in 135 | match id with 136 | | Root _ as id -> 137 | Identifier.equal ~equal:eq base id 138 | | Module _ as id -> 139 | Identifier.equal ~equal:eq base id 140 | | Argument _ as id -> 141 | Identifier.equal ~equal:eq base id 142 | | ModuleType _ as id -> 143 | Identifier.equal ~equal:eq base id 144 | | Page _ -> false 145 | | Type _ -> false 146 | | CoreType _ -> false 147 | | Constructor _ -> false 148 | | Field _ -> false 149 | | Extension _ -> false 150 | | Exception _ -> false 151 | | CoreException _ -> false 152 | | Value _ -> false 153 | | Class _ -> false 154 | | ClassType _ -> false 155 | | Method _ -> false 156 | | InstanceVariable _ -> false 157 | | Label _ -> false 158 | 159 | let rec is_parent_local : type k . _ -> _ -> ('a, k) Identifier.t -> bool = 160 | fun eq base id -> 161 | let open Identifier in 162 | match id with 163 | | Root _ -> false 164 | | Page _ -> false 165 | | Module(parent, _) -> is_local eq base parent 166 | | Argument(parent, _, _) -> is_local eq base parent 167 | | ModuleType(parent, _) -> is_local eq base parent 168 | | Type(parent, _) -> is_local eq base parent 169 | | CoreType _ -> false 170 | | Constructor(parent, _) -> is_local eq base parent 171 | | Field(parent, _) -> is_local eq base parent 172 | | Extension(parent, _) -> is_local eq base parent 173 | | Exception(parent, _) -> is_local eq base parent 174 | | CoreException _ -> false 175 | | Value(parent, _) -> is_local eq base parent 176 | | Class(parent, _) -> is_local eq base parent 177 | | ClassType(parent, _) -> is_local eq base parent 178 | | Method(parent, _) -> is_local eq base parent 179 | | InstanceVariable(parent, _) -> is_local eq base parent 180 | | Label(parent, _) -> is_local eq base parent 181 | 182 | and is_local : type k ._ -> _ -> ('a, k) Identifier.t -> bool = 183 | fun eq base id -> 184 | is_parent_local eq base id 185 | || equals_signature eq base id 186 | 187 | let is_local local id = 188 | match local.base with 189 | | None -> false 190 | | Some base -> 191 | let eq = 192 | match local.t.equal with 193 | | None -> (=) 194 | | Some eq -> eq 195 | in 196 | is_local eq base id 197 | 198 | let local_module_identifier (local : 'a local) id = 199 | let open Identifier in 200 | match local.local with 201 | | None -> Sig.unresolved 202 | | Some tbl -> 203 | try 204 | tbl.find (signature_of_module id) 205 | with Not_found -> Sig.unresolved 206 | 207 | let local_module_type_identifier (local : 'a local) id = 208 | let open Identifier in 209 | match local.local with 210 | | None -> Sig.unresolved 211 | | Some tbl -> 212 | try 213 | tbl.find (signature_of_module_type id) 214 | with Not_found -> Sig.unresolved 215 | 216 | let datatype decl = 217 | let open TypeDecl in 218 | let open Representation in 219 | match decl.representation with 220 | | None -> Datatype.abstract 221 | | Some (Variant constructors) -> 222 | let open Constructor in 223 | let name = Identifier.name decl.id in 224 | let decl = 225 | Datatype.variant name 226 | (List.map (fun cstr -> Identifier.name cstr.id) constructors) 227 | in 228 | let decl = 229 | List.fold_right 230 | (fun cstr decl -> 231 | Datatype.add_documentation cstr.doc decl) 232 | constructors decl 233 | in 234 | decl 235 | | Some (Record fields) -> 236 | let open Field in 237 | let name = Identifier.name decl.id in 238 | let decl = 239 | Datatype.record name 240 | (List.map (fun field -> Identifier.name field.id) fields) 241 | in 242 | let decl = 243 | List.fold_right 244 | (fun field decl -> 245 | Datatype.add_documentation field.doc decl) 246 | fields decl 247 | in 248 | decl 249 | | Some Extensible -> Datatype.extensible 250 | 251 | let core_types = 252 | let open TypeDecl in 253 | List.map 254 | (fun decl -> (Identifier.name decl.id, datatype decl)) 255 | DocOckPredef.core_types 256 | 257 | let page tbl base = 258 | try 259 | tbl.page_tbl.find base 260 | with Not_found -> 261 | let page = tbl.fetch_page base in 262 | let t = Page.of_doc page.DocOckTypes.Page.content in 263 | tbl.page_tbl.add base t; 264 | t 265 | 266 | let page_identifier tbl : 'a Identifier.page -> _ = 267 | let open Identifier in function 268 | | Page(base, _) -> page tbl base 269 | 270 | let rec unit tbl base = 271 | try 272 | tbl.tbl.find base 273 | with Not_found -> 274 | let open Unit in 275 | let unt = tbl.fetch_unit base in 276 | let id = Identifier.signature_of_module unt.id in 277 | let local = create_local tbl (Some id) in 278 | let t = 279 | match unt.content with 280 | | Module items -> 281 | Sig.signature 282 | (fun items -> 283 | Sig.add_documentation unt.doc 284 | (signature_items local items)) 285 | items 286 | | Pack items -> 287 | Sig.signature 288 | (fun items -> 289 | Sig.add_documentation unt.doc 290 | (packed_items local items)) 291 | items 292 | in 293 | let t = Sig.set_hidden t unt.hidden in 294 | tbl.tbl.add base t; 295 | t 296 | 297 | and signature_identifier tbl = 298 | let open Identifier in function 299 | | (Root(base, _) : 'a signature) -> unit tbl base 300 | | Module(id, name) -> 301 | let parent = signature_identifier tbl id in 302 | Sig.lookup_module name parent 303 | | Argument(id, pos, _) -> 304 | let parent = signature_identifier tbl id in 305 | Sig.lookup_argument pos parent 306 | | ModuleType(id, name) -> 307 | let parent = signature_identifier tbl id in 308 | Sig.lookup_module_type name parent 309 | 310 | and module_identifier tbl = 311 | let open Identifier in function 312 | | (Root(base, _) : 'a module_) -> unit tbl base 313 | | Module(id, name) -> 314 | let parent = signature_identifier tbl id in 315 | Sig.lookup_module name parent 316 | | Argument(id, pos, _) -> 317 | let parent = signature_identifier tbl id in 318 | Sig.lookup_argument pos parent 319 | 320 | and module_type_identifier tbl = 321 | let open Identifier in function 322 | | (ModuleType(id, name) : 'a module_type) -> 323 | let parent = signature_identifier tbl id in 324 | Sig.lookup_module_type name parent 325 | 326 | and datatype_identifier tbl = 327 | let open Identifier in function 328 | | (Type(id, name) : 'a Identifier.type_)-> 329 | let parent = signature_identifier tbl id in 330 | Sig.lookup_datatype name parent 331 | | CoreType name -> List.assoc name core_types 332 | 333 | and class_signature_identifier tbl = 334 | let open Identifier in function 335 | | (Class(id, name) | ClassType(id, name) : 'a path_class_type) -> 336 | let parent = signature_identifier tbl id in 337 | Sig.lookup_class_type name parent 338 | 339 | and resolved_module_path local = 340 | let open Path.Resolved in function 341 | | Identifier (id : 'a Identifier.module_) -> 342 | if is_local local id then local_module_identifier local id 343 | else module_identifier local.t id 344 | | Subst(sub, _) -> resolved_module_type_path local sub 345 | | SubstAlias(sub, _) -> resolved_module_path local sub 346 | | Hidden p -> resolved_module_path local p 347 | | Module(p, name) -> 348 | let parent = resolved_module_path local p in 349 | Sig.lookup_module name parent 350 | | Canonical (p, _) -> resolved_module_path local p 351 | | Apply(p, arg) -> 352 | let parent = resolved_module_path local p in 353 | Sig.lookup_apply (module_path local) arg parent 354 | 355 | and resolved_module_type_path local = 356 | let open Path.Resolved in function 357 | | Identifier (id : 'a Identifier.module_type) -> 358 | if is_local local id then local_module_type_identifier local id 359 | else module_type_identifier local.t id 360 | | ModuleType(p, name) -> 361 | let parent = resolved_module_path local p in 362 | Sig.lookup_module_type name parent 363 | 364 | and resolved_class_type_path local = 365 | let open Path.Resolved in function 366 | | Identifier id -> class_signature_identifier local.t id 367 | | Class(p, name) | ClassType(p, name) -> 368 | let parent = resolved_module_path local p in 369 | Sig.lookup_class_type name parent 370 | 371 | and module_path local = 372 | let open Path in function 373 | | Root s -> begin 374 | match local.t.lookup_unit s with 375 | | Not_found -> 376 | let sg = Sig.unresolved in 377 | Sig.set_hidden sg (contains_double_underscore s) 378 | | Found {root;_} -> unit local.t root 379 | | Forward_reference -> 380 | let sg = Sig.abstract in 381 | Sig.set_hidden sg (contains_double_underscore s) 382 | end 383 | | Forward s -> begin (* FIXME? *) 384 | match local.t.lookup_unit s with 385 | | Not_found -> 386 | let sg = Sig.unresolved in 387 | Sig.set_hidden sg (contains_double_underscore s) 388 | | Found {root; _} -> unit local.t root 389 | | Forward_reference -> 390 | let sg = Sig.abstract in 391 | Sig.set_hidden sg (contains_double_underscore s) 392 | end 393 | | Resolved r -> resolved_module_path local r 394 | | Dot(p, name) -> 395 | let parent = module_path local p in 396 | Sig.lookup_module name parent 397 | | Apply(p, arg) -> 398 | let parent = module_path local p in 399 | Sig.lookup_apply (module_path local) arg parent 400 | 401 | and module_type_path local = 402 | let open Path in function 403 | | Resolved r -> resolved_module_type_path local r 404 | | Dot(p, name) -> 405 | let parent = module_path local p in 406 | Sig.lookup_module_type name parent 407 | 408 | and class_signature_path local = 409 | let open Path in function 410 | | Resolved p -> resolved_class_type_path local p 411 | | Dot(p, name) -> 412 | let parent = module_path local p in 413 | Sig.lookup_class_type name parent 414 | 415 | and class_signature_items local = 416 | let open ClassSig in 417 | let open ClassSignature in function 418 | | InstanceVariable ivar :: rest -> 419 | let open InstanceVariable in 420 | let csig = class_signature_items local rest in 421 | let csig = add_documentation ivar.doc csig in 422 | let name = Identifier.name ivar.id in 423 | add_element name Element.InstanceVariable csig 424 | | Method meth :: rest -> 425 | let open Method in 426 | let csig = class_signature_items local rest in 427 | let csig = add_documentation meth.doc csig in 428 | let name = Identifier.name meth.id in 429 | add_element name Element.Method csig 430 | | Constraint _ :: rest -> 431 | class_signature_items local rest 432 | | Inherit expr :: rest -> 433 | let csig = class_signature_items local rest in 434 | let expr = class_type_expr local expr in 435 | inherit_ expr csig 436 | | Comment comment :: rest -> 437 | let csig = class_signature_items local rest in 438 | add_comment comment csig 439 | | [] -> empty 440 | 441 | and class_signature local csig = 442 | let open ClassSignature in 443 | class_signature_items local csig.items 444 | 445 | and class_type_expr local = 446 | let open ClassType in function 447 | | Constr(p, _) -> ClassSig.constr (class_signature_path local) p 448 | | Signature csig -> ClassSig.signature (class_signature local) csig 449 | 450 | and class_decl local = 451 | let open Class in function 452 | | ClassType expr -> class_type_expr local expr 453 | | Arrow(_, _, decl) -> class_decl local decl 454 | 455 | and signature_items local = 456 | let open Sig in 457 | let open Signature in function 458 | | Module md :: rest -> 459 | let open Module in 460 | let name = Identifier.name md.id in 461 | let decl = module_decl local md.type_ in 462 | let decl = set_canonical decl md.canonical in 463 | let decl = set_hidden decl md.hidden in 464 | add_local_module_identifier local md.id decl; 465 | let sg = signature_items local rest in 466 | let sg = add_documentation md.doc sg in 467 | add_module name decl sg 468 | | ModuleType mty :: rest -> 469 | let open ModuleType in 470 | let name = Identifier.name mty.id in 471 | let expr = 472 | match mty.expr with 473 | | None -> abstract 474 | | Some expr -> module_type_expr local expr 475 | in 476 | add_local_module_type_identifier local mty.id expr; 477 | let sg = signature_items local rest in 478 | let sg = add_documentation mty.doc sg in 479 | add_module_type name expr sg 480 | | Type decl :: rest -> 481 | let open TypeDecl in 482 | let sg = signature_items local rest in 483 | let sg = add_documentation decl.doc sg in 484 | let name = Identifier.name decl.id in 485 | let decl = datatype decl in 486 | add_datatype name decl sg 487 | | TypExt ext :: rest -> 488 | let open Extension in 489 | let sg = signature_items local rest in 490 | let sg = add_documentation ext.doc sg in 491 | List.fold_right 492 | (fun cstr acc -> 493 | let open Constructor in 494 | let name = Identifier.name cstr.id in 495 | let acc = add_documentation cstr.doc acc in 496 | add_element name Element.Extension acc) 497 | ext.constructors sg 498 | | Exception exn :: rest -> 499 | let open Exception in 500 | let sg = signature_items local rest in 501 | let sg = add_documentation exn.doc sg in 502 | let name = Identifier.name exn.id in 503 | add_element name Element.Exception sg 504 | | Value v :: rest -> 505 | let open Value in 506 | let sg = signature_items local rest in 507 | let sg = add_documentation v.doc sg in 508 | let name = Identifier.name v.id in 509 | add_element name Element.Value sg 510 | | External ev :: rest -> 511 | let open External in 512 | let sg = signature_items local rest in 513 | let sg = add_documentation ev.doc sg in 514 | let name = Identifier.name ev.id in 515 | add_element name Element.Value sg 516 | | Class cl :: rest -> 517 | let open Class in 518 | let sg = signature_items local rest in 519 | let sg = add_documentation cl.doc sg in 520 | let name = Identifier.name cl.id in 521 | let expr = class_decl local cl.type_ in 522 | add_class name expr sg 523 | | ClassType clty :: rest -> 524 | let open ClassType in 525 | let sg = signature_items local rest in 526 | let sg = add_documentation clty.doc sg in 527 | let name = Identifier.name clty.id in 528 | let expr = class_type_expr local clty.expr in 529 | add_class_type name expr sg 530 | | Include incl :: rest -> 531 | let open Include in 532 | let decl = module_decl local incl.decl in 533 | add_local_modules local incl.parent (modules decl); 534 | add_local_module_types local incl.parent (module_types decl); 535 | let sg = signature_items local rest in 536 | let sg = add_documentation incl.doc sg in 537 | include_ decl sg 538 | | Comment com :: rest -> 539 | let sg = signature_items local rest in 540 | add_comment com sg 541 | | [] -> empty 542 | 543 | and module_type_expr local expr = 544 | let open Sig in 545 | let open ModuleType in 546 | let open FunctorArgument in 547 | match expr with 548 | | Path p -> path (module_type_path local) p 549 | | Signature sg -> signature (signature_items local) sg 550 | | Functor(Some{ id; expr = arg; _}, res) -> 551 | let res = module_type_expr local res in 552 | let arg = module_type_expr local arg in 553 | functor_ local.t.equal local.t.hash id arg res 554 | | Functor(None, res) -> 555 | let res = module_type_expr local res in 556 | generative res 557 | | With(body, subs) -> 558 | let body = module_type_expr local body in 559 | List.fold_left 560 | (fun body sub -> 561 | match sub with 562 | | ModuleEq(frag, decl) -> 563 | let eq = module_decl local decl in 564 | with_module frag eq body 565 | | TypeEq _ -> body 566 | | ModuleSubst(frag, _) -> 567 | with_module_subst frag body 568 | | TypeSubst(frag, _) -> 569 | with_type_subst frag body) 570 | body subs 571 | | TypeOf decl -> module_decl local decl 572 | 573 | and module_decl local decl = 574 | let open Sig in 575 | let open Module in 576 | match decl with 577 | | Alias p -> alias (module_path local) p 578 | | ModuleType expr -> module_type_expr local expr 579 | 580 | and packed_items local = 581 | let open Sig in 582 | let open Unit.Packed in function 583 | | {id; path} :: rest -> 584 | let name = Identifier.name id in 585 | let decl = alias (module_path local) path in 586 | add_local_module_identifier local id decl; 587 | let sg = packed_items local rest in 588 | add_module name decl sg 589 | | [] -> empty 590 | 591 | (* Remove local parameter from exposed versions *) 592 | 593 | let resolved_module_path tbl p = 594 | let local = create_local tbl None in 595 | resolved_module_path local p 596 | 597 | let resolved_module_type_path tbl p = 598 | let local = create_local tbl None in 599 | resolved_module_type_path local p 600 | 601 | let resolved_class_type_path tbl p = 602 | let local = create_local tbl None in 603 | resolved_class_type_path local p 604 | 605 | let module_path tbl p = 606 | let local = create_local tbl None in 607 | module_path local p 608 | 609 | type 'a with_ = 610 | { base: 'a Sig.t; 611 | tbl: 'a t; } 612 | 613 | let module_type_expr_with tbl id expr = 614 | let local = create_local tbl (Some id) in 615 | let base = module_type_expr local expr in 616 | { base; tbl } 617 | 618 | let module_type_path_with tbl path = 619 | let local = create_local tbl None in 620 | let base = module_type_path local path in 621 | { base; tbl } 622 | 623 | let rec resolved_signature_fragment wth = 624 | let open Fragment.Resolved in function 625 | | Root -> wth.base 626 | | Subst(sub, _) -> resolved_module_type_path wth.tbl sub 627 | | SubstAlias(sub, _) -> resolved_module_path wth.tbl sub 628 | | Module(p, name) -> 629 | let parent = resolved_signature_fragment wth p in 630 | Sig.lookup_module name parent 631 | 632 | let rec resolved_signature_reference tbl = 633 | let open Reference.Resolved in function 634 | | Identifier (id : 'a Identifier.signature) -> 635 | signature_identifier tbl id 636 | | SubstAlias(sub, _) -> 637 | resolved_module_path tbl sub 638 | | Module(p, name) -> 639 | let parent = resolved_signature_reference tbl p in 640 | Sig.lookup_module name parent 641 | | Canonical (p, _) -> 642 | resolved_signature_reference tbl (signature_of_module p) 643 | | ModuleType(p, name) -> 644 | let parent = resolved_signature_reference tbl p in 645 | Sig.lookup_module_type name parent 646 | 647 | and resolved_class_signature_reference tbl = 648 | let open Reference.Resolved in function 649 | | Identifier id -> class_signature_identifier tbl id 650 | | Class(p, name) | ClassType(p, name) -> 651 | let parent = resolved_signature_reference tbl p in 652 | Sig.lookup_class_type name parent 653 | 654 | and resolved_datatype_reference tbl = 655 | let open Reference.Resolved in function 656 | | Identifier id -> datatype_identifier tbl id 657 | | Type(p, name) -> 658 | let parent = resolved_signature_reference tbl p in 659 | Sig.lookup_datatype name parent 660 | 661 | and resolved_page_reference tbl : 'a Reference.Resolved.page -> _ = 662 | let open Reference.Resolved in function 663 | | Identifier id -> page_identifier tbl id 664 | 665 | let base tbl s = tbl.lookup_unit s 666 | 667 | let page_base tbl s = tbl.lookup_page s 668 | -------------------------------------------------------------------------------- /src/docOckComponentTbl.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | (** {3 Tables} *) 21 | 22 | (** The type of tables of components *) 23 | type 'a t 24 | 25 | (* FIXME: use different types for unit and page lookups. *) 26 | type 'a lookup_unit_result = 27 | | Forward_reference 28 | | Found of { root : 'a; hidden : bool } 29 | | Not_found 30 | 31 | (** Create a table of the components of units. Optionally provide 32 | equality and hash functons. *) 33 | val create: ?equal:('a -> 'a -> bool) -> ?hash:('a -> int) -> 34 | (string -> 'a lookup_unit_result) -> ('a -> 'a Unit.t) -> 35 | (string -> 'a option) -> ('a -> 'a Page.t) -> 36 | 'a t 37 | 38 | open DocOckComponents 39 | 40 | (** {3 Identifier Lookup} *) 41 | 42 | (** Lookup the components of a signature identifier *) 43 | val signature_identifier : 'a t -> 'a Identifier.signature -> 'a Sig.t 44 | 45 | (** Lookup the components of a class signature identifier *) 46 | val class_signature_identifier : 'a t -> 'a Identifier.class_signature -> 47 | 'a ClassSig.t 48 | 49 | (** Lookup the components of a datatype identifier *) 50 | val datatype_identifier : 'a t -> 'a Identifier.type_ -> 'a Datatype.t 51 | 52 | (** {3 Path Lookup} *) 53 | 54 | (** Lookup the components of a resolved module path *) 55 | val resolved_module_path : 'a t -> 'a Path.Resolved.module_ -> 'a Sig.t 56 | 57 | (** Lookup the components of a resolved module type path *) 58 | val resolved_module_type_path : 'a t -> 'a Path.Resolved.module_type -> 'a Sig.t 59 | 60 | (** Lookup the components of a resolved class type path *) 61 | val resolved_class_type_path : 'a t -> 62 | 'a Path.Resolved.class_type -> 'a ClassSig.t 63 | 64 | (** Lookup the components of a module path, needed for module 65 | applications. *) 66 | val module_path : 'a t -> 'a Path.module_ -> 'a Sig.t 67 | 68 | (** {3 Fragment Lookup} *) 69 | 70 | (** Table specialised to lookup fragments based on a module expression 71 | or path. *) 72 | type 'a with_ 73 | 74 | (** Create specialised fragment table for a module type expression *) 75 | val module_type_expr_with : 'a t -> 76 | 'a Identifier.signature -> 'a ModuleType.expr -> 'a with_ 77 | 78 | (** Create specialised fragment table for a module path *) 79 | val module_type_path_with : 'a t -> 80 | 'a Path.module_type -> 'a with_ 81 | 82 | (** Lookup the components of a resolved module fragment *) 83 | val resolved_signature_fragment : 'a with_ -> 84 | 'a Fragment.Resolved.signature -> 'a Sig.t 85 | 86 | (** {3 Reference Lookup} *) 87 | 88 | (** Lookup the components of a resolved signature reference *) 89 | val resolved_signature_reference : 'a t -> 90 | 'a Reference.Resolved.signature -> 'a Sig.t 91 | 92 | (** Lookup the components of a resolved class signature reference *) 93 | val resolved_class_signature_reference : 'a t -> 94 | 'a Reference.Resolved.class_signature -> 'a ClassSig.t 95 | 96 | (** Lookup the components of a resolved datatype reference *) 97 | val resolved_datatype_reference : 'a t -> 98 | 'a Reference.Resolved.datatype -> 'a Datatype.t 99 | 100 | val resolved_page_reference : 'a t -> 'a Reference.Resolved.page -> 'a Page.t 101 | 102 | (** {3 Root lookup} *) 103 | 104 | (** Lookup the base of a unit name *) 105 | val base : 'a t -> string -> 'a lookup_unit_result 106 | 107 | (** Lookup the base of a page name *) 108 | val page_base : 'a t -> string -> 'a option 109 | -------------------------------------------------------------------------------- /src/docOckComponents.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | module rec Sig : sig 21 | 22 | type 'a t 23 | 24 | (** {3 Parents} *) 25 | 26 | val find_parent_module : string -> 'a t -> 'a Parent.module_ 27 | 28 | val find_parent_apply : ('a Path.module_ -> 'a t) -> 'a Path.module_ -> 29 | 'a t -> 'a Parent.module_ 30 | 31 | val find_parent_module_type : string -> 'a t -> 'a Parent.module_type 32 | 33 | val find_parent_signature : string -> 'a t -> 'a Parent.signature 34 | 35 | val find_parent_class_signature : string -> 'a t -> 'a Parent.class_signature 36 | 37 | val find_parent_datatype : string -> 'a t -> 'a Parent.datatype 38 | 39 | val find_parent_sig_or_type : string -> 'a t -> 'a Parent.sig_or_type 40 | 41 | val find_parent_subst : 'a t -> 'a Parent.subst 42 | 43 | val find_parent : string -> 'a t -> 'a Parent.any 44 | 45 | (** {3 Elements} *) 46 | 47 | val find_module_element : string -> 'a t -> 'a Element.signature_module 48 | 49 | val find_apply_element : 'a t -> 'a Element.signature_module 50 | 51 | val find_module_type_element : string -> 'a t -> 'a Element.signature_module_type 52 | 53 | val find_type_element : string -> 'a t -> 'a Element.signature_type 54 | 55 | val find_constructor_element : string -> 'a t -> 'a Element.signature_constructor 56 | 57 | val find_field_element : string -> 'a t -> 'a Element.signature_field 58 | 59 | val find_extension_element : string -> 'a t -> 'a Element.signature_extension 60 | 61 | val find_exception_element : string -> 'a t -> 'a Element.signature_exception 62 | 63 | val find_value_element : string -> 'a t -> 'a Element.signature_value 64 | 65 | val find_class_element : string -> 'a t -> 'a Element.signature_class 66 | 67 | val find_class_type_element : string -> 'a t -> 'a Element.signature_class_type 68 | 69 | val find_label_element : string -> 'a t -> 'a Element.signature_label 70 | 71 | val find_element : string -> 'a t -> 'a Element.signature 72 | 73 | val find_section_title : string -> 'a t -> 'a Documentation.text 74 | 75 | (** {3 Lookup} *) 76 | 77 | val lookup_module : string -> 'a t -> 'a t 78 | 79 | val lookup_argument : int -> 'a t -> 'a t 80 | 81 | val lookup_apply : ('a Path.module_ -> 'a t) -> 'a Path.module_ -> 82 | 'a t -> 'a t 83 | 84 | val lookup_module_type : string -> 'a t -> 'a t 85 | 86 | val lookup_class_type : string -> 'a t -> 'a ClassSig.t 87 | 88 | val lookup_datatype : string -> 'a t -> 'a Datatype.t 89 | 90 | (** {3 Constructors} *) 91 | 92 | type 'a signature 93 | 94 | val empty : 'a signature 95 | 96 | val add_module : string -> 'a t -> 'a signature -> 'a signature 97 | 98 | val add_module_type : string -> 'a t -> 'a signature -> 'a signature 99 | 100 | val add_datatype : string -> 'a Datatype.t -> 'a signature -> 'a signature 101 | 102 | val add_class : string -> 'a ClassSig.t -> 'a signature -> 'a signature 103 | 104 | val add_class_type : string -> 'a ClassSig.t -> 'a signature -> 'a signature 105 | 106 | val add_element : string -> 'a Element.signature -> 'a signature -> 'a signature 107 | 108 | val add_documentation : 'a Documentation.t -> 'a signature -> 'a signature 109 | 110 | val add_comment : 'a Documentation.comment -> 'a signature -> 'a signature 111 | 112 | val include_ : 'a t -> 'a signature -> 'a signature 113 | 114 | val modules : 'a t -> (string * 'a t) list 115 | 116 | val module_types : 'a t -> (string * 'a t) list 117 | 118 | val path : ('a Path.module_type -> 'a t) -> 'a Path.module_type -> 'a t 119 | 120 | val alias : ('a Path.module_ -> 'a t) -> 'a Path.module_ -> 'a t 121 | 122 | val signature : ('b -> 'a signature) -> 'b -> 'a t 123 | 124 | val functor_ : ('a -> 'a -> bool) option -> ('a -> int) option -> 125 | 'a Identifier.module_ -> 'a t -> 'a t -> 'a t 126 | 127 | val generative : 'a t -> 'a t 128 | 129 | val abstract : 'a t 130 | 131 | val unresolved : 'a t 132 | 133 | val with_module : 'a Fragment.module_ -> 'a t -> 'a t -> 'a t 134 | 135 | val with_module_subst : 'a Fragment.module_ -> 'a t -> 'a t 136 | 137 | val with_type_subst : 'a Fragment.type_ -> 'a t -> 'a t 138 | 139 | (** {3 Aliases handling} *) 140 | 141 | val set_canonical : 142 | 'a t -> ('a Path.module_ * 'a Reference.module_) option -> 'a t 143 | 144 | val get_canonical : 145 | 'a t -> ('a Path.module_ * 'a Reference.module_) option 146 | 147 | (** {3 Hidding} *) 148 | 149 | val set_hidden : 'a t -> bool -> 'a t 150 | 151 | val get_hidden : 'a t -> bool 152 | 153 | end 154 | 155 | and Datatype : sig 156 | 157 | type +'a t 158 | 159 | (** {3 Elements} *) 160 | 161 | val find_constructor_element : string -> 'a t -> 'a Element.datatype_constructor 162 | 163 | val find_field_element : string -> 'a t -> 'a Element.datatype_field 164 | 165 | val find_label_element : string -> 'a t -> 'a Element.datatype_label 166 | 167 | val find_element : string -> 'a t -> 'a Element.datatype 168 | 169 | (** {3 Constructors} *) 170 | 171 | val add_documentation : 'a Documentation.t -> 'a t -> 'a t 172 | 173 | val abstract : 'a t 174 | 175 | val variant : string -> string list -> 'a t 176 | 177 | val record : string -> string list -> 'a t 178 | 179 | val extensible : 'a t 180 | 181 | val unresolved : 'a t 182 | 183 | end 184 | 185 | and ClassSig : sig 186 | 187 | type 'a t 188 | 189 | (** {3 Elements} *) 190 | 191 | val find_method_element : string -> 'a t -> 'a Element.class_signature_method 192 | 193 | val find_instance_variable_element : string -> 'a t -> 194 | 'a Element.class_signature_instance_variable 195 | 196 | val find_label_element : string -> 'a t -> 'a Element.class_signature_label 197 | 198 | val find_element : string -> 'a t -> 'a Element.class_signature 199 | 200 | (** {3 Constructors} *) 201 | 202 | type 'a signature 203 | 204 | val empty : 'a signature 205 | 206 | val add_element : string -> 'a Element.class_signature -> 207 | 'a signature -> 'a signature 208 | 209 | val add_documentation : 'a Documentation.t -> 'a signature -> 'a signature 210 | 211 | val add_comment : 'a Documentation.comment -> 'a signature -> 'a signature 212 | 213 | val inherit_ : 'a t -> 'a signature -> 'a signature 214 | 215 | val constr : ('a Path.class_type -> 'a t) -> 'a Path.class_type -> 216 | 'a t 217 | 218 | val signature : ('b -> 'a signature) -> 'b -> 'a t 219 | 220 | val unresolved : 'a t 221 | 222 | end 223 | 224 | and Parent : sig 225 | 226 | type kind = Kind.parent 227 | 228 | type ('a, 'b) t = 229 | | Module : 'a Sig.t -> ('a, [< kind > `Module]) t 230 | | ModuleType : 'a Sig.t -> ('a, [< kind > `ModuleType]) t 231 | | Datatype : 'a Datatype.t -> ('a, [< kind > `Type]) t 232 | | Class : 'a ClassSig.t -> ('a, [< kind > `Class]) t 233 | | ClassType : 'a ClassSig.t -> ('a, [< kind > `ClassType]) t 234 | 235 | type 'a signature = ('a, [`Module | `ModuleType]) t 236 | 237 | type 'a class_signature = ('a, [`Class |` ClassType]) t 238 | 239 | type 'a datatype = ('a, [`Type]) t 240 | 241 | type 'a module_ = ('a, [`Module]) t 242 | 243 | type 'a module_type = ('a, [`ModuleType]) t 244 | 245 | type 'a sig_or_type = ('a, [`Module | `ModuleType | `Type]) t 246 | 247 | type 'a any = ('a, kind) t 248 | 249 | type 'a subst = 250 | | Subst of 'a Path.module_type 251 | | SubstAlias of 'a Path.module_ 252 | 253 | end 254 | 255 | and Page : sig 256 | 257 | type 'a t 258 | 259 | (** {3 Elements} *) 260 | 261 | val find_label_element : string -> 'a t -> 'a Element.page_label 262 | 263 | val find_section_title : string -> 'a t -> 'a Documentation.text 264 | 265 | (** {3 Constructor} *) 266 | 267 | val of_doc : 'a Documentation.t -> 'a t 268 | end 269 | 270 | and Element : sig 271 | 272 | type kind = 273 | [ `Module | `ModuleType | `Type 274 | | `Constructor | `Field | `Extension 275 | | `Exception | `Value | `Class | `ClassType 276 | | `Method | `InstanceVariable | `Label ] 277 | 278 | type ('a, 'b) t = 279 | | Module : 280 | { canonical : ('a Path.module_ * 'a Reference.module_) option 281 | ; hidden : bool } -> ('a, [< kind > `Module]) t 282 | | ModuleType : ('a, [< kind > `ModuleType]) t 283 | | Type : ('a, [< kind > `Type]) t 284 | | Constructor : string -> ('a, [< kind > `Constructor]) t 285 | | Field : string -> ('a, [< kind > `Field]) t 286 | | Extension : ('a, [< kind > `Extension]) t 287 | | Exception : ('a, [< kind > `Exception]) t 288 | | Value : ('a, [< kind > `Value]) t 289 | | Class : ('a, [< kind > `Class]) t 290 | | ClassType : ('a, [< kind > `ClassType]) t 291 | | Method : ('a, [< kind > `Method]) t 292 | | InstanceVariable : ('a, [< kind > `InstanceVariable]) t 293 | | Label : string option -> ('a, [< kind > `Label]) t 294 | 295 | type 'a signature_module = ('a, [`Module]) t 296 | 297 | type 'a signature_module_type = ('a, [`ModuleType]) t 298 | 299 | type 'a signature_type = ('a, [`Type | `Class | `ClassType]) t 300 | 301 | type 'a signature_constructor = ('a, [`Constructor | `Extension | `Exception]) t 302 | 303 | type 'a signature_field = ('a, [`Field]) t 304 | 305 | type 'a signature_extension = ('a, [`Extension | `Exception]) t 306 | 307 | type 'a signature_exception = ('a, [`Exception]) t 308 | 309 | type 'a signature_value = ('a, [`Value]) t 310 | 311 | type 'a signature_class = ('a, [`Class]) t 312 | 313 | type 'a signature_class_type = ('a, [`Class | `ClassType]) t 314 | 315 | type 'a signature_label = ('a, [`Label]) t 316 | 317 | type 'a signature = 318 | ('a, [ `Module | `ModuleType | `Type 319 | | `Constructor | `Field | `Extension 320 | | `Exception | `Value | `Class | `ClassType | `Label ]) t 321 | 322 | type 'a datatype_constructor = ('a, [`Constructor]) t 323 | 324 | type 'a datatype_field = ('a, [`Field]) t 325 | 326 | type 'a datatype_label = ('a, [`Label]) t 327 | 328 | type 'a datatype = ('a, [ `Constructor | `Field | `Label]) t 329 | 330 | type 'a class_signature_method = ('a, [`Method]) t 331 | 332 | type 'a class_signature_instance_variable = ('a, [`InstanceVariable]) t 333 | 334 | type 'a class_signature_label = ('a, [`Label]) t 335 | 336 | type 'a class_signature = ('a, [ `Method | `InstanceVariable | `Label ]) t 337 | 338 | type 'a page_label = ('a, [`Label]) t 339 | end 340 | -------------------------------------------------------------------------------- /src/docOckExpand.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckTypes 18 | 19 | type 'a t 20 | 21 | val build_expander : ?equal:('a -> 'a -> bool) -> ?hash:('a -> int) -> 22 | (string -> 'a DocOckComponentTbl.lookup_unit_result) -> 23 | (root:'a -> 'a -> 'a Unit.t) -> 'a t 24 | 25 | val expand : 'a t -> 'a Unit.t -> 'a Unit.t 26 | -------------------------------------------------------------------------------- /src/docOckIdentEnv.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPredef 18 | 19 | module Id = DocOckPaths.Identifier 20 | module Rp = DocOckPaths.Path.Resolved 21 | 22 | type 'a type_ident = ('a, [`Type|`Class|`ClassType]) Id.t 23 | 24 | type 'a class_type_ident = ('a, [`Class|`ClassType]) Id.t 25 | 26 | type 'a t = 27 | { modules : 'a Rp.module_ Ident.tbl; 28 | module_types : 'a Id.module_type Ident.tbl; 29 | types : 'a type_ident Ident.tbl; 30 | class_types : 'a class_type_ident Ident.tbl; } 31 | 32 | let empty = 33 | { modules = Ident.empty; 34 | module_types = Ident.empty; 35 | types = Ident.empty; 36 | class_types = Ident.empty; } 37 | 38 | let builtin_idents = List.map snd Predef.builtin_idents 39 | 40 | let should_be_hidden = DocOckPaths.contains_double_underscore 41 | 42 | let add_module parent id env = 43 | let name = Ident.name id in 44 | let ident = Rp.Identifier (Id.Module(parent, name)) in 45 | let module_ = if should_be_hidden name then Rp.Hidden ident else ident in 46 | let modules = Ident.add id module_ env.modules in 47 | { env with modules } 48 | 49 | let add_argument parent arg id env = 50 | let name = Ident.name id in 51 | let ident = Rp.Identifier (Id.Argument(parent, arg, name)) in 52 | let module_ = if should_be_hidden name then Rp.Hidden ident else ident in 53 | let modules = Ident.add id module_ env.modules in 54 | { env with modules } 55 | 56 | let add_module_type parent id env = 57 | let name = Ident.name id in 58 | let identifier = Id.ModuleType(parent, name) in 59 | let module_types = Ident.add id identifier env.module_types in 60 | { env with module_types } 61 | 62 | let add_type parent id env = 63 | let name = Ident.name id in 64 | let identifier = Id.Type(parent, name) in 65 | let types = Ident.add id identifier env.types in 66 | { env with types } 67 | 68 | let add_class parent id ty_id obj_id cl_id env = 69 | let name = Ident.name id in 70 | let identifier = Id.Class(parent, name) in 71 | let add_idents tbl = 72 | Ident.add id identifier 73 | (Ident.add ty_id identifier 74 | (Ident.add obj_id identifier 75 | (Ident.add cl_id identifier tbl))) 76 | in 77 | let types = add_idents env.types in 78 | let class_types = add_idents env.class_types in 79 | { env with types; class_types } 80 | 81 | let add_class_type parent id obj_id cl_id env = 82 | let name = Ident.name id in 83 | let identifier = Id.ClassType(parent, name) in 84 | let add_idents tbl = 85 | Ident.add id identifier 86 | (Ident.add obj_id identifier 87 | (Ident.add cl_id identifier tbl)) 88 | in 89 | let types = add_idents env.types in 90 | let class_types = add_idents env.class_types in 91 | { env with types; class_types } 92 | 93 | let rec add_signature_type_items parent items env = 94 | let open Types in 95 | match items with 96 | | Sig_type(id, _, _) :: rest -> 97 | let env = add_signature_type_items parent rest env in 98 | if Btype.is_row_name (Ident.name id) then env 99 | else add_type parent id env 100 | | Sig_module(id, _, _) :: rest -> 101 | let env = add_signature_type_items parent rest env in 102 | add_module parent id env 103 | | Sig_modtype(id, _) :: rest -> 104 | let env = add_signature_type_items parent rest env in 105 | add_module_type parent id env 106 | | Sig_class(id, _, _) :: Sig_class_type(ty_id, _, _) 107 | :: Sig_type(obj_id, _, _) :: Sig_type(cl_id, _, _) :: rest -> 108 | let env = add_signature_type_items parent rest env in 109 | add_class parent id ty_id obj_id cl_id env 110 | | Sig_class _ :: _ -> assert false 111 | | Sig_class_type(id, _, _) :: Sig_type(obj_id, _, _) 112 | :: Sig_type(cl_id, _, _) :: rest -> 113 | let env = add_signature_type_items parent rest env in 114 | add_class_type parent id obj_id cl_id env 115 | | Sig_class_type _ :: _ -> assert false 116 | | (Sig_value _ | Sig_typext _) :: rest -> 117 | add_signature_type_items parent rest env 118 | | [] -> env 119 | 120 | let add_signature_tree_item parent item env = 121 | let open Typedtree in 122 | match item.sig_desc with 123 | | Tsig_type (_rec_flag, decls) -> (* TODO: remember rec_flag *) 124 | List.fold_right 125 | (fun decl env -> add_type parent decl.typ_id env) 126 | decls env 127 | | Tsig_module md -> 128 | add_module parent md.md_id env 129 | | Tsig_recmodule mds -> 130 | List.fold_right 131 | (fun md env -> add_module parent md.md_id env) 132 | mds env 133 | | Tsig_modtype mtd -> 134 | add_module_type parent mtd.mtd_id env 135 | | Tsig_include incl -> 136 | add_signature_type_items parent incl.incl_type env 137 | | Tsig_class cls -> 138 | List.fold_right 139 | (fun cld env -> 140 | add_class parent cld.ci_id_class 141 | cld.ci_id_class_type cld.ci_id_object 142 | #if OCAML_MAJOR = 4 && OCAML_MINOR < 04 143 | cld.ci_id_typesharp 144 | #else 145 | cld.ci_id_typehash 146 | #endif 147 | env) 148 | cls env 149 | | Tsig_class_type cltyps -> 150 | List.fold_right 151 | (fun clty env -> 152 | add_class_type parent clty.ci_id_class_type 153 | clty.ci_id_object 154 | #if OCAML_MAJOR = 4 && OCAML_MINOR < 04 155 | clty.ci_id_typesharp 156 | #else 157 | clty.ci_id_typehash 158 | #endif 159 | env) 160 | cltyps env 161 | | Tsig_value _ | Tsig_typext _ 162 | | Tsig_exception _ | Tsig_open _ 163 | | Tsig_attribute _ -> env 164 | 165 | let add_signature_tree_items parent sg env = 166 | let open Typedtree in 167 | List.fold_right 168 | (add_signature_tree_item parent) 169 | sg.sig_items env 170 | 171 | let add_structure_tree_item parent item env = 172 | let open Typedtree in 173 | match item.str_desc with 174 | | Tstr_type (_rec_flag, decls) -> (* TODO: remember rec_flag *) 175 | List.fold_right 176 | (fun decl env -> add_type parent decl.typ_id env) 177 | decls env 178 | | Tstr_module mb -> add_module parent mb.mb_id env 179 | | Tstr_recmodule mbs -> 180 | List.fold_right 181 | (fun mb env -> add_module parent mb.mb_id env) 182 | mbs env 183 | | Tstr_modtype mtd -> 184 | add_module_type parent mtd.mtd_id env 185 | | Tstr_include incl -> 186 | add_signature_type_items parent incl.incl_type env 187 | | Tstr_class cls -> 188 | List.fold_right 189 | (fun (cld, _) env -> 190 | add_class parent cld.ci_id_class 191 | cld.ci_id_class_type cld.ci_id_object 192 | #if OCAML_MAJOR = 4 && OCAML_MINOR < 04 193 | cld.ci_id_typesharp 194 | #else 195 | cld.ci_id_typehash 196 | #endif 197 | env) 198 | cls env 199 | | Tstr_class_type cltyps -> 200 | List.fold_right 201 | (fun (_, _, clty) env -> 202 | add_class_type parent clty.ci_id_class_type 203 | clty.ci_id_object 204 | #if OCAML_MAJOR = 4 && OCAML_MINOR < 04 205 | clty.ci_id_typesharp 206 | #else 207 | clty.ci_id_typehash 208 | #endif 209 | env) 210 | cltyps env 211 | | Tstr_eval _ | Tstr_value _ 212 | | Tstr_primitive _ | Tstr_typext _ 213 | | Tstr_exception _ | Tstr_open _ 214 | | Tstr_attribute _ -> env 215 | 216 | let add_structure_tree_items parent str env = 217 | let open Typedtree in 218 | List.fold_right 219 | (add_structure_tree_item parent) 220 | str.str_items env 221 | 222 | let find_module env id = 223 | Ident.find_same id env.modules 224 | 225 | let find_module_type env id = 226 | Ident.find_same id env.module_types 227 | 228 | let find_type env id = 229 | try 230 | Ident.find_same id env.types 231 | with Not_found -> 232 | if List.mem id builtin_idents then 233 | match core_type_identifier (Ident.name id) with 234 | | Some id -> id 235 | | None -> raise Not_found 236 | else raise Not_found 237 | 238 | let find_class_type env id = 239 | Ident.find_same id env.class_types 240 | 241 | module Path = struct 242 | 243 | open DocOckPaths.Path.Resolved 244 | open DocOckPaths.Path 245 | 246 | let read_module_ident env id = 247 | if Ident.persistent id then Root (Ident.name id) 248 | else 249 | try Resolved (find_module env id) 250 | with Not_found -> assert false 251 | 252 | let read_module_type_ident env id = 253 | try 254 | Resolved (Identifier (find_module_type env id)) 255 | with Not_found -> assert false 256 | 257 | let read_type_ident env id = 258 | try 259 | Resolved (Identifier (find_type env id)) 260 | with Not_found -> assert false 261 | 262 | let read_class_type_ident env id : 'a class_type = 263 | try 264 | Resolved (Identifier (find_class_type env id)) 265 | with Not_found -> 266 | Dot(Root "*", (Ident.name id)) 267 | (* TODO remove this hack once the fix for PR#6650 268 | is in the OCaml release *) 269 | 270 | let rec read_module env = function 271 | | Path.Pident id -> read_module_ident env id 272 | | Path.Pdot(p, s, _) -> Dot(read_module env p, s) 273 | | Path.Papply(p, arg) -> Apply(read_module env p, read_module env arg) 274 | 275 | let read_module_type env = function 276 | | Path.Pident id -> read_module_type_ident env id 277 | | Path.Pdot(p, s, _) -> Dot(read_module env p, s) 278 | | Path.Papply(_, _)-> assert false 279 | 280 | let read_class_type env = function 281 | | Path.Pident id -> read_class_type_ident env id 282 | | Path.Pdot(p, s, _) -> Dot(read_module env p, s) 283 | | Path.Papply(_, _)-> assert false 284 | 285 | let read_type env = function 286 | | Path.Pident id -> read_type_ident env id 287 | | Path.Pdot(p, s, _) -> Dot(read_module env p, s) 288 | | Path.Papply(_, _)-> assert false 289 | 290 | end 291 | 292 | module Fragment = struct 293 | 294 | open DocOckPaths.Fragment.Resolved 295 | open DocOckPaths.Fragment 296 | 297 | let rec read_module = function 298 | | Longident.Lident s -> Dot(Resolved Root, s) 299 | | Longident.Ldot(p, s) -> Dot(signature_of_module (read_module p), s) 300 | | Longident.Lapply _ -> assert false 301 | 302 | let read_type = function 303 | | Longident.Lident s -> Dot(Resolved Root, s) 304 | | Longident.Ldot(p, s) -> Dot(signature_of_module (read_module p), s) 305 | | Longident.Lapply _ -> assert false 306 | 307 | end 308 | -------------------------------------------------------------------------------- /src/docOckIdentEnv.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths.Identifier 18 | 19 | type 'a t 20 | 21 | val empty : 'a t 22 | 23 | val add_module : 'a signature -> Ident.t -> 'a t -> 'a t 24 | 25 | val add_argument : 'a signature -> int -> Ident.t -> 'a t -> 'a t 26 | 27 | val add_module_type : 'a signature -> Ident.t -> 'a t -> 'a t 28 | 29 | val add_type : 'a signature -> Ident.t -> 'a t -> 'a t 30 | 31 | val add_class : 'a signature -> Ident.t -> Ident.t -> Ident.t -> Ident.t -> 32 | 'a t -> 'a t 33 | 34 | val add_class_type : 'a signature -> Ident.t -> Ident.t -> Ident.t -> 35 | 'a t -> 'a t 36 | 37 | val add_signature_type_items : 'a signature -> Types.signature -> 38 | 'a t -> 'a t 39 | 40 | val add_signature_tree_items : 'a signature -> Typedtree.signature -> 41 | 'a t -> 'a t 42 | 43 | val add_structure_tree_items : 'a signature -> Typedtree.structure -> 44 | 'a t -> 'a t 45 | 46 | module Path : sig 47 | 48 | val read_module : 'a t -> Path.t -> 'a DocOckPaths.Path.module_ 49 | 50 | val read_module_type : 'a t -> Path.t -> 'a DocOckPaths.Path.module_type 51 | 52 | val read_type : 'a t -> Path.t -> 'a DocOckPaths.Path.type_ 53 | 54 | val read_class_type : 'a t -> Path.t -> 'a DocOckPaths.Path.class_type 55 | 56 | end 57 | 58 | 59 | module Fragment : sig 60 | 61 | val read_module : Longident.t -> 'a DocOckPaths.Fragment.module_ 62 | 63 | val read_type : Longident.t -> 'a DocOckPaths.Fragment.type_ 64 | 65 | end 66 | -------------------------------------------------------------------------------- /src/docOckLookup.ml: -------------------------------------------------------------------------------- 1 | 2 | open DocOckTypes 3 | open DocOckNameEnv 4 | 5 | class ['a] lookup = object 6 | val env = empty 7 | 8 | inherit ['a] DocOckMaps.types as super 9 | 10 | method root x = x 11 | method path_type x = x 12 | method path_module_type x = x 13 | method path_module x = x 14 | method path_class_type x = x 15 | method identifier_value x = x 16 | method identifier_type x = x 17 | method identifier_module_type x = x 18 | method identifier_module x = x 19 | method identifier_method x = x 20 | method identifier_label x = x 21 | method identifier_page x = x 22 | method identifier_instance_variable x = x 23 | method identifier_field x = x 24 | method identifier_extension x = x 25 | method identifier_exception x = x 26 | method identifier_constructor x = x 27 | method identifier_class_type x = x 28 | method identifier_class x = x 29 | method identifier_signature x = x 30 | method identifier x = x 31 | method fragment_type x = x 32 | method fragment_module x = x 33 | 34 | method reference_module x = 35 | lookup_module env x 36 | method reference_module_type x = 37 | lookup_module_type env x 38 | method reference_type x = 39 | lookup_type env x 40 | method reference_constructor x = 41 | lookup_constructor env x 42 | method reference_field x = 43 | lookup_field env x 44 | method reference_extension x = 45 | lookup_extension env x 46 | method reference_exception x = 47 | lookup_exception env x 48 | method reference_value x = 49 | lookup_value env x 50 | method reference_class x = 51 | lookup_class env x 52 | method reference_class_type x = 53 | lookup_class_type env x 54 | method reference_method x = 55 | lookup_method env x 56 | method reference_instance_variable x = 57 | lookup_instance_variable env x 58 | method reference_label x = 59 | lookup_label env x 60 | method reference_any x = 61 | lookup_element env x 62 | 63 | method super_module md = super#module_ md 64 | 65 | method! module_ md = 66 | let open Module in 67 | let env = add_module_decl_items md.type_ env in 68 | let this = {< env = env >} in 69 | this#super_module md 70 | 71 | method super_module_type mty = super#module_type mty 72 | 73 | method! module_type mty = 74 | let open ModuleType in 75 | let env = 76 | match mty.expr with 77 | | None -> env 78 | | Some expr -> add_module_type_expr_items expr env 79 | in 80 | let this = {< env = env >} in 81 | this#super_module_type mty 82 | 83 | method super_unit unt = super#unit unt 84 | 85 | method! unit unt = 86 | let open Unit in 87 | let env = add_unit unt env in 88 | let env = 89 | match unt.content with 90 | | Module items -> add_signature_items items env 91 | | Pack _ -> env 92 | in 93 | let this = {< env = env >} in 94 | this#super_unit unt 95 | 96 | method super_page page = super#page page 97 | 98 | method! page page = 99 | let env = add_page page env in 100 | let this = {< env = env >} in 101 | this#super_page page 102 | 103 | method super_class cl = super#class_ cl 104 | 105 | method! class_ cl = 106 | let open Class in 107 | let env = add_class_decl_items cl.type_ env in 108 | let this = {< env = env >} in 109 | this#super_class cl 110 | 111 | method super_class_type cltyp = super#class_type cltyp 112 | 113 | method! class_type cltyp = 114 | let open ClassType in 115 | let env = add_class_type_expr_items cltyp.expr env in 116 | let this = {< env = env >} in 117 | this#super_class_type cltyp 118 | 119 | method! documentation_text_element elt = 120 | let elt = super#documentation_text_element elt in 121 | let open Documentation in 122 | match elt with 123 | | Reference (r, None) -> 124 | let open DocOckPaths.Reference in 125 | let open Resolved in 126 | begin match r with 127 | | Element Resolved (Identifier (DocOckPaths.Identifier.Label _) 128 | | Label _ as rr) -> 129 | begin match lookup_section_title env rr with 130 | | None -> elt 131 | | txt -> Documentation.Reference (r, txt) 132 | end 133 | | _ -> elt 134 | end 135 | | otherwise -> otherwise 136 | 137 | end 138 | 139 | let lookup x = 140 | let obj = new lookup in 141 | obj#unit x 142 | 143 | let lookup_page x = 144 | let obj = new lookup in 145 | obj#page x 146 | -------------------------------------------------------------------------------- /src/docOckLookup.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | val lookup : 'a DocOckTypes.Unit.t -> 'a DocOckTypes.Unit.t 18 | 19 | val lookup_page : 'a DocOckTypes.Page.t -> 'a DocOckTypes.Page.t 20 | -------------------------------------------------------------------------------- /src/docOckNameEnv.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | type 'a t 21 | 22 | val empty : 'a t 23 | 24 | val add_page : 'a Page.t -> 'a t -> 'a t 25 | 26 | val add_unit : 'a Unit.t -> 'a t -> 'a t 27 | 28 | val add_signature_items : 'a Signature.t -> 'a t -> 'a t 29 | 30 | val add_module_type_expr_items : 'a ModuleType.expr -> 'a t -> 'a t 31 | 32 | val add_module_decl_items : 'a Module.decl -> 'a t -> 'a t 33 | 34 | val add_class_signature_items : 'a ClassSignature.t -> 'a t -> 'a t 35 | 36 | val add_class_type_expr_items : 'a ClassType.expr -> 'a t -> 'a t 37 | 38 | val add_class_decl_items : 'a Class.decl -> 'a t -> 'a t 39 | 40 | val lookup_module : 'a t -> 'a Reference.module_ -> 41 | 'a Reference.module_ 42 | 43 | val lookup_module_type : 'a t -> 'a Reference.module_type -> 44 | 'a Reference.module_type 45 | 46 | val lookup_type : 'a t -> 'a Reference.type_ -> 47 | 'a Reference.type_ 48 | 49 | val lookup_constructor : 'a t -> 'a Reference.constructor -> 50 | 'a Reference.constructor 51 | 52 | val lookup_field : 'a t -> 'a Reference.field -> 53 | 'a Reference.field 54 | 55 | val lookup_extension : 'a t -> 'a Reference.extension -> 56 | 'a Reference.extension 57 | 58 | val lookup_exception : 'a t -> 'a Reference.exception_ -> 59 | 'a Reference.exception_ 60 | 61 | val lookup_value : 'a t -> 'a Reference.value -> 62 | 'a Reference.value 63 | 64 | val lookup_class : 'a t -> 'a Reference.class_ -> 65 | 'a Reference.class_ 66 | 67 | val lookup_class_type : 'a t -> 'a Reference.class_type -> 68 | 'a Reference.class_type 69 | 70 | val lookup_method : 'a t -> 'a Reference.method_ -> 71 | 'a Reference.method_ 72 | 73 | val lookup_instance_variable : 'a t -> 'a Reference.instance_variable -> 74 | 'a Reference.instance_variable 75 | 76 | val lookup_label : 'a t -> 'a Reference.label -> 77 | 'a Reference.label 78 | 79 | val lookup_element : 'a t -> 'a Reference.any -> 80 | 'a Reference.any 81 | 82 | val lookup_section_title : 'a t -> 'a Reference.Resolved.label -> 83 | 'a Documentation.text option 84 | -------------------------------------------------------------------------------- /src/docOckPayload.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let read = 18 | let open Parsetree in function 19 | | PStr[{ pstr_desc = 20 | Pstr_eval({ pexp_desc = 21 | Pexp_constant( Parsetree.Pconst_string(str, _)); 22 | pexp_loc = loc; 23 | _ 24 | }, _) 25 | ; _ }] -> Some(str, loc) 26 | | _ -> None 27 | -------------------------------------------------------------------------------- /src/docOckPayload.mli: -------------------------------------------------------------------------------- 1 | val read : Parsetree.payload -> (string * Location.t) option 2 | -------------------------------------------------------------------------------- /src/docOckPredef.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | let empty_doc = 21 | let open Documentation in 22 | {text = []; tags = [];} 23 | 24 | let nullary_equation = 25 | let open TypeDecl.Equation in 26 | let params = [] in 27 | let private_ = false in 28 | let manifest = None in 29 | let constraints = [] in 30 | {params; private_; manifest; constraints} 31 | 32 | let covariant_equation = 33 | let open TypeDecl in 34 | let open TypeDecl.Equation in 35 | let params = [Var "'a", Some Pos] in 36 | let private_ = false in 37 | let manifest = None in 38 | let constraints = [] in 39 | {params; private_; manifest; constraints} 40 | 41 | let invariant_equation = 42 | let open TypeDecl in 43 | let open TypeDecl.Equation in 44 | let params = [Var "'a", None] in 45 | let private_ = false in 46 | let manifest = None in 47 | let constraints = [] in 48 | {params; private_; manifest; constraints} 49 | 50 | open Identifier 51 | 52 | let bool_identifier = CoreType "bool" 53 | let int_identifier = CoreType "int" 54 | let char_identifier = CoreType "char" 55 | let bytes_identifier = CoreType "bytes" 56 | let string_identifier = CoreType "string" 57 | let float_identifier = CoreType "float" 58 | let unit_identifier = CoreType "unit" 59 | let exn_identifier = CoreType "exn" 60 | let array_identifier = CoreType "array" 61 | let list_identifier = CoreType "list" 62 | let option_identifier = CoreType "option" 63 | let int32_identifier = CoreType "int32" 64 | let int64_identifier = CoreType "int64" 65 | let nativeint_identifier = CoreType "nativeint" 66 | let lazy_t_identifier = CoreType "lazy_t" 67 | let extension_constructor_identifier = CoreType "extension_constructor" 68 | let floatarray_identifier = CoreType "floatarray" 69 | 70 | 71 | let false_identifier = Constructor(bool_identifier, "false") 72 | let true_identifier = Constructor(bool_identifier, "true") 73 | let void_identifier = Constructor(unit_identifier, "()") 74 | let nil_identifier = Constructor(list_identifier, "([])") 75 | let cons_identifier = Constructor(list_identifier, "(::)") 76 | let none_identifier = Constructor(option_identifier, "None") 77 | let some_identifier = Constructor(option_identifier, "Some") 78 | 79 | let match_failure_identifier = CoreException "Match_failure" 80 | let assert_failure_identifier = CoreException "Assert_failure" 81 | let invalid_argument_identifier = CoreException "Invalid_argument" 82 | let failure_identifier = CoreException "Failure" 83 | let not_found_identifier = CoreException "Not_found" 84 | let out_of_memory_identifier = CoreException "Out_of_memory" 85 | let stack_overflow_identifier = CoreException "Stack_overflow" 86 | let sys_error_identifier = CoreException "Sys_error" 87 | let end_of_file_identifier = CoreException "End_of_file" 88 | let division_by_zero_identifier = CoreException "Division_by_zero" 89 | let sys_blocked_io_identifier = CoreException "Sys_blocked_io" 90 | let undefined_recursive_module_identifier = 91 | CoreException "Undefined_recursive_module" 92 | 93 | let core_type_identifier = function 94 | | "int" -> Some int_identifier 95 | | "char" -> Some char_identifier 96 | | "bytes" -> Some bytes_identifier 97 | | "string" -> Some string_identifier 98 | | "float" -> Some float_identifier 99 | | "bool" -> Some bool_identifier 100 | | "unit" -> Some unit_identifier 101 | | "exn" -> Some exn_identifier 102 | | "array" -> Some array_identifier 103 | | "list" -> Some list_identifier 104 | | "option" -> Some option_identifier 105 | | "int32" -> Some int32_identifier 106 | | "int64" -> Some int64_identifier 107 | | "nativeint" -> Some nativeint_identifier 108 | | "lazy_t" -> Some lazy_t_identifier 109 | | "extension_constructor" -> Some extension_constructor_identifier 110 | | "floatarray" -> Some floatarray_identifier 111 | | _ -> None 112 | 113 | let core_exception_identifier = function 114 | | "Match_failure" -> Some match_failure_identifier 115 | | "Out_of_memory" -> Some out_of_memory_identifier 116 | | "Invalid_argument" -> Some invalid_argument_identifier 117 | | "Failure" -> Some failure_identifier 118 | | "Not_found" -> Some not_found_identifier 119 | | "Sys_error" -> Some sys_error_identifier 120 | | "End_of_file" -> Some end_of_file_identifier 121 | | "Division_by_zero" -> Some division_by_zero_identifier 122 | | "Stack_overflow" -> Some stack_overflow_identifier 123 | | "Sys_blocked_io" -> Some sys_blocked_io_identifier 124 | | "Assert_failure" -> Some assert_failure_identifier 125 | | "Undefined_recursive_module" -> Some undefined_recursive_module_identifier 126 | | _ -> None 127 | 128 | let core_constructor_identifier = function 129 | | "false" -> Some false_identifier 130 | | "true" -> Some true_identifier 131 | | "()" -> Some void_identifier 132 | | "[]" -> Some nil_identifier 133 | | "([])" -> Some nil_identifier 134 | | "::" -> Some cons_identifier 135 | | "(::)" -> Some cons_identifier 136 | | "None" -> Some none_identifier 137 | | "Some" -> Some some_identifier 138 | | _ -> None 139 | 140 | open Path.Resolved 141 | open Path 142 | 143 | let bool_path = Resolved (Identifier bool_identifier) 144 | let int_path = Resolved (Identifier int_identifier) 145 | let char_path = Resolved (Identifier char_identifier) 146 | let bytes_path = Resolved (Identifier bytes_identifier) 147 | let string_path = Resolved (Identifier string_identifier) 148 | let float_path = Resolved (Identifier float_identifier) 149 | let unit_path = Resolved (Identifier unit_identifier) 150 | let exn_path = Resolved (Identifier exn_identifier) 151 | let array_path = Resolved (Identifier array_identifier) 152 | let list_path = Resolved (Identifier list_identifier) 153 | let option_path = Resolved (Identifier option_identifier) 154 | let int32_path = Resolved (Identifier int32_identifier) 155 | let int64_path = Resolved (Identifier int64_identifier) 156 | let nativeint_path = Resolved (Identifier nativeint_identifier) 157 | let lazy_t_path = Resolved (Identifier lazy_t_identifier) 158 | let extension_constructor_path = 159 | Resolved (Identifier extension_constructor_identifier) 160 | let floatarray_path = Resolved (Identifier floatarray_identifier) 161 | 162 | open Reference.Resolved 163 | open Reference 164 | 165 | let bool_reference = Resolved (Identifier bool_identifier) 166 | let int_reference = Resolved (Identifier int_identifier) 167 | let char_reference = Resolved (Identifier char_identifier) 168 | let bytes_reference = Resolved (Identifier bytes_identifier) 169 | let string_reference = Resolved (Identifier string_identifier) 170 | let float_reference = Resolved (Identifier float_identifier) 171 | let unit_reference = Resolved (Identifier unit_identifier) 172 | let exn_reference = Resolved (Identifier exn_identifier) 173 | let array_reference = Resolved (Identifier array_identifier) 174 | let list_reference = Resolved (Identifier list_identifier) 175 | let option_reference = Resolved (Identifier option_identifier) 176 | let int32_reference = Resolved (Identifier int32_identifier) 177 | let int64_reference = Resolved (Identifier int64_identifier) 178 | let nativeint_reference = Resolved (Identifier nativeint_identifier) 179 | let lazy_t_reference = Resolved (Identifier lazy_t_identifier) 180 | let extension_constructor_reference = 181 | Resolved (Identifier extension_constructor_identifier) 182 | let floatarray_reference = Resolved (Identifier floatarray_identifier) 183 | 184 | let false_reference = Resolved (Identifier false_identifier) 185 | let true_reference = Resolved (Identifier true_identifier) 186 | let void_reference = Resolved (Identifier void_identifier) 187 | let nil_reference = Resolved (Identifier nil_identifier) 188 | let cons_reference = Resolved (Identifier cons_identifier) 189 | let none_reference = Resolved (Identifier none_identifier) 190 | let some_reference = Resolved (Identifier some_identifier) 191 | 192 | let match_failure_reference = Resolved(Identifier match_failure_identifier) 193 | let assert_failure_reference = Resolved(Identifier assert_failure_identifier) 194 | let invalid_argument_reference = Resolved(Identifier invalid_argument_identifier) 195 | let failure_reference = Resolved(Identifier failure_identifier) 196 | let not_found_reference = Resolved(Identifier not_found_identifier) 197 | let out_of_memory_reference = Resolved(Identifier out_of_memory_identifier) 198 | let stack_overflow_reference = Resolved(Identifier stack_overflow_identifier) 199 | let sys_error_reference = Resolved(Identifier sys_error_identifier) 200 | let end_of_file_reference = Resolved(Identifier end_of_file_identifier) 201 | let division_by_zero_reference = Resolved(Identifier division_by_zero_identifier) 202 | let sys_blocked_io_reference = Resolved(Identifier sys_blocked_io_identifier) 203 | let undefined_recursive_module_reference = 204 | Resolved(Identifier undefined_recursive_module_identifier) 205 | 206 | let false_decl = 207 | let open TypeDecl.Constructor in 208 | let open Documentation in 209 | let doc = Ok empty_doc in 210 | let args = Tuple [] in 211 | let res = None in 212 | {id = false_identifier; doc; args; res} 213 | 214 | let true_decl = 215 | let open TypeDecl.Constructor in 216 | let open Documentation in 217 | let doc = Ok empty_doc in 218 | let args = Tuple [] in 219 | let res = None in 220 | {id = true_identifier; doc; args; res} 221 | 222 | let void_decl = 223 | let open TypeDecl.Constructor in 224 | let open Documentation in 225 | let doc = Ok empty_doc in 226 | let args = Tuple [] in 227 | let res = None in 228 | {id = void_identifier; doc; args; res} 229 | 230 | let nil_decl = 231 | let open TypeDecl.Constructor in 232 | let open Documentation in 233 | let doc = Ok empty_doc in 234 | let args = Tuple [] in 235 | let res = None in 236 | {id = nil_identifier; doc; args; res} 237 | 238 | let cons_decl = 239 | let open TypeDecl.Constructor in 240 | let open Documentation in 241 | let doc = Ok empty_doc in 242 | let head = TypeExpr.Var "'a" in 243 | let tail = TypeExpr.(Constr(list_path, [head])) in 244 | let args = Tuple [head; tail] in 245 | let res = None in 246 | {id = cons_identifier; doc; args; res} 247 | 248 | let none_decl = 249 | let open TypeDecl.Constructor in 250 | let open Documentation in 251 | let doc = Ok empty_doc in 252 | let args = Tuple [] in 253 | let res = None in 254 | {id = none_identifier; doc; args; res} 255 | 256 | let some_decl = 257 | let open TypeDecl.Constructor in 258 | let open Documentation in 259 | let doc = Ok empty_doc in 260 | let var = TypeExpr.Var "'a" in 261 | let args = Tuple [var] in 262 | let res = None in 263 | {id = some_identifier; doc; args; res} 264 | 265 | 266 | let int_decl = 267 | let open TypeDecl in 268 | let open Documentation in 269 | let id = int_identifier in 270 | let text = [Raw "The type of integer numbers."] in 271 | let doc = Ok {empty_doc with text} in 272 | let equation = nullary_equation in 273 | let representation = None in 274 | {id; doc; equation; representation} 275 | 276 | let char_decl = 277 | let open TypeDecl in 278 | let open Documentation in 279 | let id = char_identifier in 280 | let text = [Raw "The type of characters."] in 281 | let doc = Ok {empty_doc with text} in 282 | let equation = nullary_equation in 283 | let representation = None in 284 | {id; doc; equation; representation} 285 | 286 | let bytes_decl = 287 | let open TypeDecl in 288 | let open Documentation in 289 | let id = bytes_identifier in 290 | let text = [Raw "The type of (writable) byte sequences."] in 291 | let doc = Ok {empty_doc with text} in 292 | let equation = nullary_equation in 293 | let representation = None in 294 | {id; doc; equation; representation} 295 | 296 | let string_decl = 297 | let open TypeDecl in 298 | let open Documentation in 299 | let id = string_identifier in 300 | let text = [Raw "The type of (read-only) character strings."] in 301 | let doc = Ok {empty_doc with text} in 302 | let equation = nullary_equation in 303 | let representation = None in 304 | {id; doc; equation; representation} 305 | 306 | let float_decl = 307 | let open TypeDecl in 308 | let open Documentation in 309 | let id = float_identifier in 310 | let text = [Raw "The type of floating-point numbers."] in 311 | let doc = Ok {empty_doc with text} in 312 | let equation = nullary_equation in 313 | let representation = None in 314 | {id; doc; equation; representation} 315 | 316 | let bool_decl = 317 | let open TypeDecl in 318 | let open Representation in 319 | let open Documentation in 320 | let id = bool_identifier in 321 | let text = [Raw "The type of booleans (truth values)."] in 322 | let doc = Ok {empty_doc with text} in 323 | let equation = nullary_equation in 324 | let representation = Some (Variant [false_decl; true_decl]) in 325 | {id; doc; equation; representation} 326 | 327 | let unit_decl = 328 | let open TypeDecl in 329 | let open Representation in 330 | let open Documentation in 331 | let id = unit_identifier in 332 | let text = [Raw "The type of the unit value."] in 333 | let doc = Ok {empty_doc with text} in 334 | let equation = nullary_equation in 335 | let representation = Some (Variant [void_decl]) in 336 | {id; doc; equation; representation} 337 | 338 | let exn_decl = 339 | let open TypeDecl in 340 | let open Representation in 341 | let open Documentation in 342 | let id = exn_identifier in 343 | let text = [Raw "The type of exception values."] in 344 | let doc = Ok {empty_doc with text} in 345 | let equation = nullary_equation in 346 | let representation = Some Extensible in 347 | {id; doc; equation; representation} 348 | 349 | let array_decl = 350 | let open TypeDecl in 351 | let open Documentation in 352 | let id = array_identifier in 353 | let text = 354 | [Raw "The type of arrays whose elements have type "; 355 | Code "'a"; 356 | Raw "."] 357 | in 358 | let doc = Ok {empty_doc with text} in 359 | let equation = invariant_equation in 360 | let representation = None in 361 | {id; doc; equation; representation} 362 | 363 | let list_decl = 364 | let open TypeDecl in 365 | let open Representation in 366 | let open Documentation in 367 | let id = list_identifier in 368 | let text = 369 | [Raw "The type of lists whose elements have type "; 370 | Code "'a"; 371 | Raw "."] 372 | in 373 | let doc = Ok {empty_doc with text} in 374 | let equation = covariant_equation in 375 | let representation = Some (Variant [nil_decl; cons_decl]) in 376 | {id; doc; equation; representation} 377 | 378 | let option_decl = 379 | let open TypeDecl in 380 | let open Representation in 381 | let open Documentation in 382 | let id = option_identifier in 383 | let text = 384 | [Raw "The type of optional values of type "; 385 | Code "'a"; 386 | Raw "."] 387 | in 388 | let doc = Ok {empty_doc with text} in 389 | let equation = covariant_equation in 390 | let representation = Some (Variant [none_decl; some_decl]) in 391 | {id; doc; equation; representation} 392 | 393 | let int32_decl = 394 | let open TypeDecl in 395 | let open Documentation in 396 | let id = int32_identifier in 397 | let text = 398 | [Raw "The type of signed 32-bit integers. See the "; 399 | Reference(Element(Root("Int32", TModule)), None); 400 | Raw " module."] 401 | in 402 | let doc = Ok {empty_doc with text} in 403 | let equation = nullary_equation in 404 | let representation = None in 405 | {id; doc; equation; representation} 406 | 407 | let int64_decl = 408 | let open TypeDecl in 409 | let open Documentation in 410 | let id = int64_identifier in 411 | let text = 412 | [Raw "The type of signed 64-bit integers. See the "; 413 | Reference(Element(Root("Int64", TModule)), None); 414 | Raw " module."] 415 | in 416 | let doc = Ok {empty_doc with text} in 417 | let equation = nullary_equation in 418 | let representation = None in 419 | {id; doc; equation; representation} 420 | 421 | let nativeint_decl = 422 | let open TypeDecl in 423 | let open Documentation in 424 | let id = nativeint_identifier in 425 | let text = 426 | [Raw "The type of signed, platform-native integers (32 bits on \ 427 | 32-bit processors, 64 bits on 64-bit processors). See the "; 428 | Reference(Element(Root("Nativeint", TModule)), None); 429 | Raw " module."] 430 | in 431 | let doc = Ok {empty_doc with text} in 432 | let equation = nullary_equation in 433 | let representation = None in 434 | {id; doc; equation; representation} 435 | 436 | let lazy_t_decl = 437 | let open TypeDecl in 438 | let open Documentation in 439 | let id = lazy_t_identifier in 440 | let text = 441 | [Raw "This type is used to implement the "; 442 | Reference(Element(Root("Lazy", TModule)), None); 443 | Raw " module. It should not be used directly."] 444 | in 445 | let doc = Ok {empty_doc with text} in 446 | let equation = covariant_equation in 447 | let representation = None in 448 | {id; doc; equation; representation} 449 | 450 | let extension_constructor_decl = 451 | let open TypeDecl in 452 | let open Documentation in 453 | let id = extension_constructor_identifier in 454 | let text = 455 | [Raw "cf. "; 456 | Reference(Element(Root("Obj", TModule)), None); 457 | Raw " module. It should not be used directly."] 458 | in 459 | let doc = Ok {empty_doc with text} in 460 | let equation = covariant_equation in 461 | let representation = None in 462 | {id; doc; equation; representation} 463 | 464 | let floatarray_decl = 465 | let open TypeDecl in 466 | let open Documentation in 467 | let id = floatarray_identifier in 468 | let text = 469 | [Raw "This type is used to implement the "; 470 | Reference(Element(Module(Root("Array", TModule), "Floatarray")), None); 471 | Raw " module. It should not be used directly."] 472 | in 473 | let doc = Ok {empty_doc with text} in 474 | let equation = covariant_equation in 475 | let representation = None in 476 | {id; doc; equation; representation} 477 | 478 | let match_failure_decl = 479 | let open Exception in 480 | let open Documentation in 481 | let id = match_failure_identifier in 482 | let text = 483 | [Raw "Exception raised when none of the cases of a pattern matching apply. \ 484 | The arguments are the location of the "; 485 | Code "match"; 486 | Raw " keyword in the source code (file name, line number, column number)."] 487 | in 488 | let doc = Ok {empty_doc with text} in 489 | let string_expr = TypeExpr.Constr(string_path, []) in 490 | let int_expr = TypeExpr.Constr(int_path, []) in 491 | let args = 492 | TypeDecl.Constructor.Tuple [TypeExpr.Tuple[string_expr; int_expr; int_expr]] 493 | in 494 | let res = None in 495 | {id; doc; args; res} 496 | 497 | let assert_failure_decl = 498 | let open Exception in 499 | let open Documentation in 500 | let id = assert_failure_identifier in 501 | let text = 502 | [Raw "Exception raised when and assertion fails. \ 503 | The arguments are the location of the "; 504 | Code "assert"; 505 | Raw " keyword in the source code (file name, line number, column number)."] 506 | in 507 | let doc = Ok {empty_doc with text} in 508 | let string_expr = TypeExpr.Constr(string_path, []) in 509 | let int_expr = TypeExpr.Constr(int_path, []) in 510 | let args = 511 | TypeDecl.Constructor.Tuple [TypeExpr.Tuple[string_expr; int_expr; int_expr]] 512 | in 513 | let res = None in 514 | {id; doc; args; res} 515 | 516 | let invalid_argument_decl = 517 | let open Exception in 518 | let open Documentation in 519 | let id = invalid_argument_identifier in 520 | let text = 521 | [Raw "Exception raised by library functions to signal that the given \ 522 | arguments do not make sense."] 523 | in 524 | let doc = Ok {empty_doc with text} in 525 | let args = TypeDecl.Constructor.Tuple [TypeExpr.Constr(string_path, [])] in 526 | let res = None in 527 | {id; doc; args; res} 528 | 529 | let failure_decl = 530 | let open Exception in 531 | let open Documentation in 532 | let id = failure_identifier in 533 | let text = 534 | [Raw "Exception raised by library functions to signal that they are \ 535 | undefined on the given arguments."] 536 | in 537 | let doc = Ok {empty_doc with text} in 538 | let args = TypeDecl.Constructor.Tuple [TypeExpr.Constr(string_path, [])] in 539 | let res = None in 540 | {id; doc; args; res} 541 | 542 | let not_found_decl = 543 | let open Exception in 544 | let open Documentation in 545 | let id = not_found_identifier in 546 | let text = 547 | [Raw "Exception raised by search functions when the desired object \ 548 | could not be found."] 549 | in 550 | let doc = Ok {empty_doc with text} in 551 | let args = TypeDecl.Constructor.Tuple [] in 552 | let res = None in 553 | {id; doc; args; res} 554 | 555 | let out_of_memory_decl = 556 | let open Exception in 557 | let open Documentation in 558 | let id = out_of_memory_identifier in 559 | let text = 560 | [Raw "Exception raised by the garbage collector when there is \ 561 | insufficient memory to complete the computation."] 562 | in 563 | let doc = Ok {empty_doc with text} in 564 | let args = TypeDecl.Constructor.Tuple [] in 565 | let res = None in 566 | {id; doc; args; res} 567 | 568 | (* TODO: Provide reference to the OCaml manual *) 569 | let stack_overflow_decl = 570 | let open Exception in 571 | let open Documentation in 572 | let id = stack_overflow_identifier in 573 | let text = 574 | [Raw "Exception raised by the bytecode interpreter when the evaluation \ 575 | stack reaches its maximal size. This often indicates infinite or \ 576 | excessively deep recursion in the user's program. (Not fully \ 577 | implemented by the native-code compiler; see section 11.5 of \ 578 | the OCaml manual.)"] 579 | in 580 | let doc = Ok {empty_doc with text} in 581 | let args = TypeDecl.Constructor.Tuple [] in 582 | let res = None in 583 | {id; doc; args; res} 584 | 585 | let sys_error_decl = 586 | let open Exception in 587 | let open Documentation in 588 | let id = sys_error_identifier in 589 | let text = 590 | [Raw "Exception raised by the input/output functions to report an \ 591 | operating system error."] 592 | in 593 | let doc = Ok {empty_doc with text} in 594 | let args = TypeDecl.Constructor.Tuple [TypeExpr.Constr(string_path, [])] in 595 | let res = None in 596 | {id; doc; args; res} 597 | 598 | let end_of_file_decl = 599 | let open Exception in 600 | let open Documentation in 601 | let id = end_of_file_identifier in 602 | let text = 603 | [Raw "Exception raised by input functions to signal that the end of \ 604 | file has been reached."] 605 | in 606 | let doc = Ok {empty_doc with text} in 607 | let args = TypeDecl.Constructor.Tuple [] in 608 | let res = None in 609 | {id; doc; args; res} 610 | 611 | let division_by_zero_decl = 612 | let open Exception in 613 | let open Documentation in 614 | let id = division_by_zero_identifier in 615 | let text = 616 | [Raw "Exception raised by integer division and remainder operations \ 617 | when their second argument is zero."] 618 | in 619 | let doc = Ok {empty_doc with text} in 620 | let args = TypeDecl.Constructor.Tuple [] in 621 | let res = None in 622 | {id; doc; args; res} 623 | 624 | let sys_blocked_io_decl = 625 | let open Exception in 626 | let open Documentation in 627 | let id = sys_blocked_io_identifier in 628 | let text = 629 | [Raw "A special case of "; 630 | Reference(Element sys_error_reference, None); 631 | Raw " raised when no I/O is possible on a non-blocking I/O channel."] 632 | in 633 | let doc = Ok {empty_doc with text} in 634 | let args = TypeDecl.Constructor.Tuple [] in 635 | let res = None in 636 | {id; doc; args; res} 637 | 638 | (* TODO: Provide reference to the OCaml manual *) 639 | let undefined_recursive_module_decl = 640 | let open Exception in 641 | let open Documentation in 642 | let id = undefined_recursive_module_identifier in 643 | let text = 644 | [Raw "Exception raised when an ill-founded recursive module definition \ 645 | is evaluated. (See section 7.8 of the OCaml manual.) The arguments \ 646 | are the location of the definition in the source code \ 647 | (file name, line number, column number)."] 648 | in 649 | let doc = Ok {empty_doc with text} in 650 | let string_expr = TypeExpr.Constr(string_path, []) in 651 | let int_expr = TypeExpr.Constr(int_path, []) in 652 | let args = 653 | TypeDecl.Constructor.Tuple [TypeExpr.Tuple[string_expr; int_expr; int_expr]] 654 | in 655 | let res = None in 656 | {id; doc; args; res} 657 | 658 | let core_types = 659 | [int_decl; char_decl; bytes_decl; string_decl; float_decl; bool_decl; 660 | unit_decl; exn_decl; array_decl; list_decl; option_decl; int32_decl; 661 | int64_decl; nativeint_decl; lazy_t_decl; floatarray_decl] 662 | 663 | let core_exceptions = 664 | [match_failure_decl; assert_failure_decl; invalid_argument_decl; 665 | failure_decl; not_found_decl; out_of_memory_decl; stack_overflow_decl; 666 | sys_error_decl; end_of_file_decl; division_by_zero_decl; 667 | sys_blocked_io_decl; undefined_recursive_module_decl] 668 | -------------------------------------------------------------------------------- /src/docOckPredef.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | (** {3 Identifiers} *) 21 | 22 | val bool_identifier : 'a Identifier.type_ 23 | val int_identifier : 'a Identifier.type_ 24 | val char_identifier : 'a Identifier.type_ 25 | val bytes_identifier : 'a Identifier.type_ 26 | val string_identifier : 'a Identifier.type_ 27 | val float_identifier : 'a Identifier.type_ 28 | val unit_identifier : 'a Identifier.type_ 29 | val exn_identifier : 'a Identifier.type_ 30 | val array_identifier : 'a Identifier.type_ 31 | val list_identifier : 'a Identifier.type_ 32 | val option_identifier : 'a Identifier.type_ 33 | val int32_identifier : 'a Identifier.type_ 34 | val int64_identifier : 'a Identifier.type_ 35 | val nativeint_identifier : 'a Identifier.type_ 36 | val lazy_t_identifier : 'a Identifier.type_ 37 | val extension_constructor_identifier : 'a Identifier.type_ 38 | 39 | val false_identifier :'a Identifier.constructor 40 | val true_identifier :'a Identifier.constructor 41 | val void_identifier :'a Identifier.constructor 42 | val nil_identifier :'a Identifier.constructor 43 | val cons_identifier :'a Identifier.constructor 44 | val none_identifier :'a Identifier.constructor 45 | val some_identifier :'a Identifier.constructor 46 | 47 | val match_failure_identifier : 'a Identifier.exception_ 48 | val assert_failure_identifier : 'a Identifier.exception_ 49 | val invalid_argument_identifier : 'a Identifier.exception_ 50 | val failure_identifier : 'a Identifier.exception_ 51 | val not_found_identifier : 'a Identifier.exception_ 52 | val out_of_memory_identifier : 'a Identifier.exception_ 53 | val stack_overflow_identifier : 'a Identifier.exception_ 54 | val sys_error_identifier : 'a Identifier.exception_ 55 | val end_of_file_identifier : 'a Identifier.exception_ 56 | val division_by_zero_identifier : 'a Identifier.exception_ 57 | val sys_blocked_io_identifier : 'a Identifier.exception_ 58 | val undefined_recursive_module_identifier : 'a Identifier.exception_ 59 | 60 | val core_type_identifier : string -> 61 | ('a, [< Identifier.kind > `Type]) Identifier.t option 62 | val core_exception_identifier : string -> 63 | ('a, [< Identifier.kind > `Exception]) Identifier.t option 64 | val core_constructor_identifier : string -> 65 | ('a, [< Identifier.kind > `Constructor]) Identifier.t option 66 | 67 | (** {3 Paths} *) 68 | 69 | val bool_path : 'a Path.type_ 70 | val int_path : 'a Path.type_ 71 | val char_path : 'a Path.type_ 72 | val bytes_path : 'a Path.type_ 73 | val string_path : 'a Path.type_ 74 | val float_path : 'a Path.type_ 75 | val unit_path : 'a Path.type_ 76 | val exn_path : 'a Path.type_ 77 | val array_path : 'a Path.type_ 78 | val list_path : 'a Path.type_ 79 | val option_path : 'a Path.type_ 80 | val int32_path : 'a Path.type_ 81 | val int64_path : 'a Path.type_ 82 | val nativeint_path : 'a Path.type_ 83 | val lazy_t_path : 'a Path.type_ 84 | val extension_constructor_path : 'a Path.type_ 85 | 86 | (** {3 References} *) 87 | 88 | val bool_reference : 'a Reference.type_ 89 | val int_reference : 'a Reference.type_ 90 | val char_reference : 'a Reference.type_ 91 | val bytes_reference : 'a Reference.type_ 92 | val string_reference : 'a Reference.type_ 93 | val float_reference : 'a Reference.type_ 94 | val unit_reference : 'a Reference.type_ 95 | val exn_reference : 'a Reference.type_ 96 | val array_reference : 'a Reference.type_ 97 | val list_reference : 'a Reference.type_ 98 | val option_reference : 'a Reference.type_ 99 | val int32_reference : 'a Reference.type_ 100 | val int64_reference : 'a Reference.type_ 101 | val nativeint_reference : 'a Reference.type_ 102 | val lazy_t_reference : 'a Reference.type_ 103 | val extension_constructor_reference : 'a Reference.type_ 104 | 105 | val false_reference : 'a Reference.constructor 106 | val true_reference : 'a Reference.constructor 107 | val void_reference : 'a Reference.constructor 108 | val nil_reference : 'a Reference.constructor 109 | val cons_reference : 'a Reference.constructor 110 | val none_reference : 'a Reference.constructor 111 | val some_reference : 'a Reference.constructor 112 | 113 | val match_failure_reference : 'a Reference.exception_ 114 | val assert_failure_reference : 'a Reference.exception_ 115 | val invalid_argument_reference : 'a Reference.exception_ 116 | val failure_reference : 'a Reference.exception_ 117 | val not_found_reference : 'a Reference.exception_ 118 | val out_of_memory_reference : 'a Reference.exception_ 119 | val stack_overflow_reference : 'a Reference.exception_ 120 | val sys_error_reference : 'a Reference.exception_ 121 | val end_of_file_reference : 'a Reference.exception_ 122 | val division_by_zero_reference : 'a Reference.exception_ 123 | val sys_blocked_io_reference : 'a Reference.exception_ 124 | val undefined_recursive_module_reference : 'a Reference.exception_ 125 | 126 | (** {3 Declarations} *) 127 | 128 | val int_decl : 'a TypeDecl.t 129 | val char_decl : 'a TypeDecl.t 130 | val bytes_decl : 'a TypeDecl.t 131 | val string_decl : 'a TypeDecl.t 132 | val float_decl : 'a TypeDecl.t 133 | val bool_decl : 'a TypeDecl.t 134 | val unit_decl : 'a TypeDecl.t 135 | val exn_decl : 'a TypeDecl.t 136 | val array_decl : 'a TypeDecl.t 137 | val list_decl : 'a TypeDecl.t 138 | val option_decl : 'a TypeDecl.t 139 | val int32_decl : 'a TypeDecl.t 140 | val int64_decl : 'a TypeDecl.t 141 | val nativeint_decl : 'a TypeDecl.t 142 | val lazy_t_decl : 'a TypeDecl.t 143 | val extension_constructor_decl : 'a TypeDecl.t 144 | 145 | val match_failure_decl : 'a Exception.t 146 | val assert_failure_decl : 'a Exception.t 147 | val invalid_argument_decl : 'a Exception.t 148 | val failure_decl : 'a Exception.t 149 | val not_found_decl : 'a Exception.t 150 | val out_of_memory_decl : 'a Exception.t 151 | val stack_overflow_decl : 'a Exception.t 152 | val sys_error_decl : 'a Exception.t 153 | val end_of_file_decl : 'a Exception.t 154 | val division_by_zero_decl : 'a Exception.t 155 | val sys_blocked_io_decl : 'a Exception.t 156 | val undefined_recursive_module_decl : 'a Exception.t 157 | 158 | val core_types : 'a TypeDecl.t list 159 | val core_exceptions : 'a Exception.t list 160 | -------------------------------------------------------------------------------- /src/docOckResolve.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckTypes 18 | 19 | type 'a resolver 20 | 21 | (** Lazily extract the components of units. Assumes that it is safe to 22 | use {!Hashtbl.hash} and structural equality (=) on ['a]. *) 23 | val build_resolver: ?equal:('a -> 'a -> bool) -> ?hash:('a -> int) 24 | -> (string -> 'a DocOckComponentTbl.lookup_unit_result) -> ('a -> 'a Unit.t) 25 | -> (string -> 'a option) -> ('a -> 'a Page.t) 26 | -> 'a resolver 27 | 28 | (** Try to resolve all paths and references within a unit. *) 29 | val resolve : 'a resolver -> 'a Unit.t -> 'a Unit.t 30 | 31 | (** Try to resolve all paths and references within a page. *) 32 | val resolve_page : 'a resolver -> 'a Page.t -> 'a Page.t 33 | -------------------------------------------------------------------------------- /src/docOckSubst.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | 21 | class type ['a] t = object 22 | method root : 'a -> 'a 23 | inherit ['a] DocOckMaps.paths 24 | method offset_identifier_signature : 25 | 'a Identifier.signature * int -> 'a Identifier.signature * int 26 | inherit ['a] DocOckMaps.types 27 | end 28 | 29 | let signature s sg = 30 | s#signature sg 31 | 32 | let class_signature s csig = 33 | s#class_signature csig 34 | 35 | let datatype s decl = 36 | s#type_decl_representation decl 37 | 38 | let module_ s md = 39 | s#module_ md 40 | 41 | let module_type s mty = 42 | s#module_type mty 43 | 44 | let type_decl s decl = 45 | s#type_decl decl 46 | 47 | let constructor s cstr = 48 | s#type_decl_constructor cstr 49 | 50 | let field s field = 51 | s#type_decl_field field 52 | 53 | let extension s ext = 54 | s#extension ext 55 | 56 | let exception_ s exn = 57 | s#exception_ exn 58 | 59 | let value s v = 60 | s#value v 61 | 62 | let class_ s cl = 63 | s#class_ cl 64 | 65 | let class_type s cty = 66 | s#class_type cty 67 | 68 | let method_ s meth = 69 | s#method_ meth 70 | 71 | let instance_variable s inst = 72 | s#instance_variable inst 73 | 74 | let comment s com = 75 | s#documentation_comment com 76 | 77 | let documentation s doc = 78 | s#documentation doc 79 | 80 | let identifier_signature s id = 81 | s#identifier_signature id 82 | 83 | let offset_identifier_signature s idoff = 84 | s#offset_identifier_signature idoff 85 | 86 | (* TODO either expose more maps or expose argument map directly *) 87 | let identifier_module s id = 88 | s#identifier_module id 89 | 90 | let module_type_expr s expr = 91 | s#module_type_expr expr 92 | 93 | let module_expansion s expr = 94 | s#module_expansion expr 95 | 96 | class ['a] rename_signature ~equal (x : 'a Identifier.signature) 97 | (y : 'a Identifier.signature) offset : ['a] t = object 98 | 99 | inherit ['a] DocOckMaps.paths as super 100 | 101 | method root x = x 102 | 103 | method! identifier_signature id = 104 | if Identifier.equal ~equal id x then y 105 | else super#identifier_signature id 106 | 107 | method! identifier (type k) (id : ('a, k) Identifier.t) 108 | : ('a, k) Identifier.t = 109 | match id with 110 | | Identifier.Argument(parent, pos, name) -> 111 | if Identifier.equal ~equal parent x then 112 | Identifier.Argument(y, pos + offset, name) 113 | else super#identifier id 114 | | id -> super#identifier id 115 | 116 | method offset_identifier_signature (id, offset') = 117 | if Identifier.equal ~equal id x then (y, offset + offset') 118 | else (super#identifier_signature id, offset') 119 | 120 | inherit ['a] DocOckMaps.types 121 | 122 | end 123 | 124 | let rename_signature ~equal x y offset = 125 | new rename_signature ~equal x y offset 126 | 127 | class ['a] rename_class_signature ~equal 128 | (x : 'a Identifier.class_signature) 129 | (y : 'a Identifier.class_signature) : ['a] t = object (self) 130 | 131 | inherit ['a] DocOckMaps.paths as super 132 | 133 | method root x = x 134 | 135 | method! identifier_class_signature id = 136 | if Identifier.equal ~equal id x then y 137 | else super#identifier_class_signature id 138 | 139 | inherit ['a] DocOckMaps.types 140 | 141 | method offset_identifier_signature (id, offset) = 142 | (self#identifier_signature id, offset) 143 | 144 | end 145 | 146 | let rename_class_signature ~equal x y = 147 | new rename_class_signature ~equal x y 148 | 149 | class ['a] rename_datatype ~equal (x : 'a Identifier.datatype) 150 | (y : 'a Identifier.datatype) : ['a] t = object (self) 151 | 152 | inherit ['a] DocOckMaps.paths as super 153 | 154 | method root x = x 155 | 156 | method! identifier_datatype id = 157 | if Identifier.equal ~equal id x then y 158 | else super#identifier_datatype id 159 | 160 | inherit ['a] DocOckMaps.types 161 | 162 | method offset_identifier_signature (id, offset) = 163 | (self#identifier_signature id, offset) 164 | 165 | end 166 | 167 | let rename_datatype ~equal x y = 168 | new rename_datatype ~equal x y 169 | 170 | (*let module_id_path (type k) (Witness : k is_path_kind) 171 | (id : ('a, k) Identifier.t) name = 172 | let open Path.Resolved in 173 | (Module(Identifier id, name))*) 174 | 175 | class ['a] prefix ~equal ~canonical id : ['a] t = object (self) 176 | 177 | inherit ['a] DocOckMaps.paths as super 178 | 179 | method root x = x 180 | 181 | (* OCaml can't type-check this method yet, so we use magic*) 182 | method! path_resolved : type k. ('a, k) Path.Resolved.t -> 183 | ('a, k) Path.Resolved.t = 184 | fun p -> 185 | let matches id' = 186 | Identifier.equal ~equal (Identifier.signature_of_module id) id' 187 | in 188 | let open Path.Resolved in 189 | let replacement = 190 | match canonical with 191 | | None -> Identifier id 192 | | Some(path, _) -> Canonical(Identifier id, path) 193 | in 194 | match p with 195 | | Identifier (Identifier.Module(parent, name)) -> 196 | if matches parent then Obj.magic (Module(replacement, name)) 197 | else super#path_resolved p 198 | | Identifier (Identifier.ModuleType(parent, name)) -> 199 | if matches parent then Obj.magic (ModuleType(replacement, name)) 200 | else super#path_resolved p 201 | | Identifier (Identifier.Type(parent, name)) -> 202 | if matches parent then Obj.magic (Type(replacement, name)) 203 | else super#path_resolved p 204 | | Identifier (Identifier.Class(parent, name)) -> 205 | if matches parent then Obj.magic (Class(replacement, name)) 206 | else super#path_resolved p 207 | | Identifier (Identifier.ClassType(parent, name)) -> 208 | if matches parent then Obj.magic (ClassType(replacement, name)) 209 | else super#path_resolved p 210 | | _ -> super#path_resolved p 211 | 212 | method! reference_resolved : type k. ('a, k) Reference.Resolved.t -> 213 | ('a, k) Reference.Resolved.t = 214 | fun r -> 215 | let sid = Identifier.signature_of_module id in 216 | let matches id' = 217 | Identifier.equal ~equal sid id' 218 | in 219 | let open Reference.Resolved in 220 | let replacement = 221 | match canonical with 222 | | None -> Identifier id 223 | | Some(_, reference) -> Canonical(Identifier id, reference) 224 | in 225 | let sreplacement = signature_of_module replacement in 226 | let preplacement = parent_of_signature sreplacement in 227 | let lreplacement = label_parent_of_parent preplacement in 228 | match r with 229 | | Identifier (Identifier.Module(parent, name)) -> 230 | if matches parent then Module(sreplacement, name) 231 | else super#reference_resolved r 232 | | Identifier (Identifier.ModuleType(parent, name)) -> 233 | if matches parent then ModuleType(sreplacement, name) 234 | else super#reference_resolved r 235 | | Identifier (Identifier.Type(parent, name)) -> 236 | if matches parent then Type(sreplacement, name) 237 | else super#reference_resolved r 238 | | Identifier (Identifier.Extension(parent, name)) -> 239 | if matches parent then Extension(sreplacement, name) 240 | else super#reference_resolved r 241 | | Identifier (Identifier.Exception(parent, name)) -> 242 | if matches parent then Exception(sreplacement, name) 243 | else super#reference_resolved r 244 | | Identifier (Identifier.Value(parent, name)) -> 245 | if matches parent then Value(sreplacement, name) 246 | else super#reference_resolved r 247 | | Identifier (Identifier.Class(parent, name)) -> 248 | if matches parent then Class(sreplacement, name) 249 | else super#reference_resolved r 250 | | Identifier (Identifier.ClassType(parent, name)) -> 251 | if matches parent then ClassType(sreplacement, name) 252 | else super#reference_resolved r 253 | | Identifier (Identifier.Label(parent, name)) -> begin 254 | match parent with 255 | | Identifier.Root _ | Identifier.Argument _ 256 | | Identifier.Module _ | Identifier.ModuleType _ as parent -> 257 | if matches parent then Label(lreplacement, name) 258 | else super#reference_resolved r 259 | | _ -> super#reference_resolved r 260 | end 261 | | _ -> super#reference_resolved r 262 | 263 | inherit ['a] DocOckMaps.types 264 | 265 | method offset_identifier_signature (id, offset) = 266 | (self#identifier_signature id, offset) 267 | 268 | end 269 | 270 | let prefix ~equal ~canonical id = 271 | new prefix ~equal ~canonical id 272 | 273 | class ['a] strengthen path : ['a] t = object 274 | 275 | inherit ['a] DocOckMaps.types 276 | 277 | method root x = x 278 | 279 | method! documentation_comment x = x 280 | 281 | method! module_ md = 282 | if Path.Resolved.is_hidden path then md 283 | else begin 284 | let open Module in 285 | match md.type_ with 286 | | Alias p when not (Path.is_hidden p) -> md 287 | | _ -> 288 | let name = Identifier.name md.id in 289 | let path = Path.Resolved(Path.Resolved.Module(path, name)) in 290 | let type_ = Alias path in 291 | let expansion = None in 292 | { md with type_; expansion } 293 | end 294 | 295 | method! module_type x = x 296 | 297 | method! type_decl x = x 298 | 299 | method! extension x = x 300 | 301 | method! exception_ x = x 302 | 303 | method! value x = x 304 | 305 | method! external_ x = x 306 | 307 | method! class_ x = x 308 | 309 | method! class_type x = x 310 | 311 | method! include_ x = x 312 | 313 | inherit ['a] DocOckMaps.paths 314 | 315 | method offset_identifier_signature x = x 316 | 317 | method! module_type_expr x = x 318 | 319 | end 320 | 321 | let strengthen path = 322 | new strengthen path 323 | 324 | let make_lookup (type a) ~equal ~hash 325 | (items : (a Identifier.module_ * a Identifier.module_) list) = 326 | let module Hash = struct 327 | type t = a Identifier.module_ 328 | let equal = Identifier.equal ~equal 329 | let hash = Identifier.hash ~hash 330 | end in 331 | let module Tbl = Hashtbl.Make(Hash) in 332 | let tbl = Tbl.create 13 in 333 | List.iter (fun (id1, id2) -> Tbl.add tbl id1 id2) items; 334 | fun id -> 335 | match Tbl.find tbl id with 336 | | id -> Some id 337 | | exception Not_found -> None 338 | 339 | class ['a] pack ~equal ~hash 340 | (items : ('a Identifier.module_ 341 | * 'a Identifier.module_) list) : ['a] t = object (self) 342 | 343 | val lookup = make_lookup ~equal ~hash items 344 | 345 | method root x = x 346 | 347 | inherit ['a] DocOckMaps.paths as super 348 | 349 | method! identifier : type k. ('a, k) Identifier.t -> ('a, k) Identifier.t = 350 | fun id -> 351 | let open Identifier in 352 | match id with 353 | | Root _ as id -> begin 354 | match lookup id with 355 | | Some (Root _ | Module _ | Argument _ as id) -> id 356 | | None -> super#identifier id 357 | end 358 | | Module _ as id -> begin 359 | match lookup id with 360 | | Some (Root _ | Module _ | Argument _ as id) -> id 361 | | None -> super#identifier id 362 | end 363 | | Argument _ as id -> begin 364 | match lookup id with 365 | | Some (Root _ | Module _ | Argument _ as id) -> id 366 | | None -> super#identifier id 367 | end 368 | | _ -> super#identifier id 369 | 370 | inherit ['a] DocOckMaps.types 371 | 372 | method offset_identifier_signature (id, offset) = 373 | (self#identifier_signature id, offset) 374 | 375 | end 376 | 377 | let pack ~equal ~hash items = 378 | new pack ~equal ~hash items 379 | -------------------------------------------------------------------------------- /src/docOckSubst.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOckPaths 18 | open DocOckTypes 19 | 20 | type 'a t 21 | 22 | val signature : 'a t -> 'a Signature.t -> 'a Signature.t 23 | 24 | val class_signature : 'a t -> 'a ClassSignature.t -> 'a ClassSignature.t 25 | 26 | val datatype : 'a t -> 'a TypeDecl.Representation.t -> 27 | 'a TypeDecl.Representation.t 28 | 29 | val module_ : 'a t -> 'a Module.t -> 'a Module.t 30 | 31 | val module_type : 'a t -> 'a ModuleType.t -> 'a ModuleType.t 32 | 33 | val type_decl : 'a t -> 'a TypeDecl.t -> 'a TypeDecl.t 34 | 35 | val constructor : 'a t -> 'a TypeDecl.Constructor.t -> 36 | 'a TypeDecl.Constructor.t 37 | 38 | val field : 'a t -> 'a TypeDecl.Field.t -> 'a TypeDecl.Field.t 39 | 40 | val extension : 'a t -> 'a Extension.t -> 'a Extension.t 41 | 42 | val exception_ : 'a t -> 'a Exception.t -> 'a Exception.t 43 | 44 | val value : 'a t -> 'a Value.t -> 'a Value.t 45 | 46 | val class_ : 'a t -> 'a Class.t -> 'a Class.t 47 | 48 | val class_type : 'a t -> 'a ClassType.t -> 'a ClassType.t 49 | 50 | val method_ : 'a t -> 'a Method.t -> 'a Method.t 51 | 52 | val instance_variable : 'a t -> 'a InstanceVariable.t -> 53 | 'a InstanceVariable.t 54 | 55 | val comment : 'a t -> 'a Documentation.comment -> 'a Documentation.comment 56 | 57 | val documentation : 'a t -> 'a Documentation.t -> 'a Documentation.t 58 | 59 | val identifier_module : 'a t -> 'a Identifier.module_ -> 60 | 'a Identifier.module_ 61 | 62 | val identifier_signature : 'a t -> 'a Identifier.signature -> 63 | 'a Identifier.signature 64 | 65 | val offset_identifier_signature : 'a t -> 'a Identifier.signature * int -> 66 | 'a Identifier.signature * int 67 | 68 | val module_type_expr : 'a t -> 'a ModuleType.expr -> 'a ModuleType.expr 69 | 70 | val module_expansion : 'a t -> 'a Module.expansion -> 'a Module.expansion 71 | 72 | val rename_signature : equal:('a -> 'a -> bool) -> 73 | 'a Identifier.signature -> 74 | 'a Identifier.signature -> 75 | int -> 'a t 76 | 77 | val rename_class_signature : equal:('a -> 'a -> bool) -> 78 | 'a Identifier.class_signature -> 79 | 'a Identifier.class_signature -> 80 | 'a t 81 | 82 | val rename_datatype : equal:('a -> 'a -> bool) -> 83 | 'a Identifier.datatype -> 84 | 'a Identifier.datatype -> 85 | 'a t 86 | 87 | val prefix : equal:('a -> 'a -> bool) -> 88 | canonical:('a Path.module_ * 'a Reference.module_) option -> 89 | 'a Identifier.module_ -> 90 | 'a t 91 | 92 | val strengthen : 'a Path.Resolved.module_ -> 'a t 93 | 94 | val pack : equal:('a -> 'a -> bool) -> hash:('a -> int) -> 95 | ('a Identifier.module_ * 'a Identifier.module_) list -> 'a t 96 | -------------------------------------------------------------------------------- /src/docOckTypes.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Type of documentation *) 18 | 19 | open DocOckPaths 20 | 21 | (** {3 Documentation} *) 22 | 23 | module rec Documentation : sig 24 | 25 | type style = 26 | | Bold 27 | | Italic 28 | | Emphasize 29 | | Center 30 | | Left 31 | | Right 32 | | Superscript 33 | | Subscript 34 | | Custom of string 35 | 36 | type 'a reference = 37 | | Element of 'a Reference.any 38 | | Link of string 39 | | Custom of string * string 40 | 41 | type see = 42 | | Url of string 43 | | File of string 44 | | Doc of string 45 | 46 | type 'a text = 'a text_element list 47 | 48 | and 'a text_element = 49 | | Raw of string 50 | | Code of string 51 | | PreCode of string 52 | | Verbatim of string 53 | | Style of style * 'a text 54 | | List of 'a text list 55 | | Enum of 'a text list 56 | | Newline 57 | | Title of int * 'a Identifier.label option * 'a text 58 | | Reference of 'a reference * 'a text option 59 | | Target of string option * string 60 | | Special of 'a special 61 | 62 | and 'a tag = 63 | | Author of string 64 | | Version of string 65 | | See of see * 'a text 66 | | Since of string 67 | | Before of string * 'a text 68 | | Deprecated of 'a text 69 | | Param of string * 'a text 70 | | Raise of string * 'a text 71 | | Return of 'a text 72 | | Inline 73 | | Tag of string * 'a text 74 | | Canonical of 'a Path.module_ * 'a Reference.module_ 75 | 76 | and 'a special = 77 | | Modules of ('a Reference.module_ * 'a text) list 78 | | Index 79 | 80 | 81 | module Error : sig 82 | 83 | module Position : sig 84 | 85 | type t = 86 | { line: int; 87 | column: int; } 88 | 89 | end 90 | 91 | module Offset : sig 92 | 93 | type t = 94 | { start: Position.t; 95 | finish: Position.t; } 96 | 97 | end 98 | 99 | module Location : sig 100 | 101 | type t = 102 | { filename: string; 103 | start: Position.t; 104 | finish: Position.t; } 105 | 106 | end 107 | 108 | type 'a t = 109 | { origin: 'a Identifier.any; (** TODO remove this *) 110 | offset: Offset.t; 111 | location: Location.t option; 112 | message: string; } 113 | 114 | end 115 | 116 | type 'a body = 117 | { text: 'a text; 118 | tags: 'a tag list; } 119 | 120 | type 'a t = 121 | | Ok of 'a body 122 | | Error of 'a Error.t 123 | 124 | type 'a comment = 125 | | Documentation of 'a t 126 | | Stop 127 | 128 | end = Documentation 129 | 130 | (** {3 Modules} *) 131 | 132 | module rec Module : sig 133 | 134 | type 'a expansion = 135 | | AlreadyASig 136 | | Signature of 'a Signature.t 137 | | Functor of 'a FunctorArgument.t option list * 'a Signature.t 138 | 139 | type 'a decl = 140 | | Alias of 'a Path.module_ 141 | | ModuleType of 'a ModuleType.expr 142 | 143 | type 'a t = 144 | { id: 'a Identifier.module_; 145 | doc: 'a Documentation.t; 146 | type_: 'a decl; 147 | canonical : ('a Path.module_ * 'a Reference.module_) option; 148 | hidden : bool; 149 | display_type : 'a decl option; 150 | expansion: 'a expansion option; 151 | } 152 | 153 | module Equation : sig 154 | 155 | type 'a t = 'a decl 156 | 157 | end 158 | 159 | end = Module 160 | 161 | and FunctorArgument : sig 162 | type 'a t = { 163 | id : 'a Identifier.module_; 164 | expr : 'a ModuleType.expr; 165 | expansion: 'a Module.expansion option; 166 | } 167 | end = FunctorArgument 168 | 169 | (** {3 Modules Types} *) 170 | 171 | and ModuleType : sig 172 | 173 | type 'a substitution = 174 | | ModuleEq of 'a Fragment.module_ * 'a Module.Equation.t 175 | | TypeEq of 'a Fragment.type_ * 'a TypeDecl.Equation.t 176 | | ModuleSubst of 'a Fragment.module_ * 'a Path.module_ 177 | | TypeSubst of 'a Fragment.type_ * 'a TypeDecl.Equation.t 178 | 179 | type 'a expr = 180 | | Path of 'a Path.module_type 181 | | Signature of 'a Signature.t 182 | | Functor of 'a FunctorArgument.t option * 'a expr 183 | | With of 'a expr * 'a substitution list 184 | | TypeOf of 'a Module.decl 185 | 186 | type 'a t = 187 | { id: 'a Identifier.module_type; 188 | doc: 'a Documentation.t; 189 | expr: 'a expr option; 190 | expansion: 'a Module.expansion option; 191 | } 192 | 193 | end = ModuleType 194 | 195 | (** {3 Signatures} *) 196 | 197 | and Signature : sig 198 | 199 | type 'a item = 200 | | Module of 'a Module.t 201 | | ModuleType of 'a ModuleType.t 202 | | Type of 'a TypeDecl.t 203 | | TypExt of 'a Extension.t 204 | | Exception of 'a Exception.t 205 | | Value of 'a Value.t 206 | | External of 'a External.t 207 | | Class of 'a Class.t 208 | | ClassType of 'a ClassType.t 209 | | Include of 'a Include.t 210 | | Comment of 'a Documentation.comment 211 | 212 | type 'a t = 'a item list 213 | 214 | end = Signature 215 | 216 | (** {3 Includes} *) 217 | 218 | and Include : sig 219 | type 'a expansion = { 220 | resolved: bool; 221 | content: 'a Signature.t; 222 | } 223 | 224 | type 'a t = 225 | { parent: 'a Identifier.signature; 226 | doc: 'a Documentation.t; 227 | decl: 'a Module.decl; 228 | expansion: 'a expansion; } 229 | 230 | end = Include 231 | 232 | (** {3 Type Declarations} *) 233 | 234 | and TypeDecl : sig 235 | 236 | module Field : sig 237 | 238 | type 'a t = 239 | { id: 'a Identifier.field; 240 | doc: 'a Documentation.t; 241 | mutable_ : bool; 242 | type_: 'a TypeExpr.t; } 243 | 244 | end 245 | 246 | module Constructor : sig 247 | type 'a argument = 248 | | Tuple of 'a TypeExpr.t list 249 | | Record of 'a Field.t list 250 | 251 | type 'a t = 252 | { id: 'a Identifier.constructor; 253 | doc: 'a Documentation.t; 254 | args: 'a argument; 255 | res: 'a TypeExpr.t option; } 256 | 257 | end 258 | 259 | 260 | module Representation : sig 261 | 262 | type 'a t = 263 | | Variant of 'a Constructor.t list 264 | | Record of 'a Field.t list 265 | | Extensible 266 | 267 | end 268 | 269 | type variance = 270 | | Pos 271 | | Neg 272 | 273 | type param_desc = 274 | | Any 275 | | Var of string 276 | 277 | type param = param_desc * variance option 278 | 279 | module Equation : sig 280 | 281 | type 'a t = 282 | { params: param list; 283 | private_: bool; 284 | manifest: 'a TypeExpr.t option; 285 | constraints: ('a TypeExpr.t * 'a TypeExpr.t) list; } 286 | 287 | end 288 | 289 | type 'a t = 290 | { id: 'a Identifier.type_; 291 | doc: 'a Documentation.t; 292 | equation: 'a Equation.t; 293 | representation: 'a Representation.t option; } 294 | 295 | end = TypeDecl 296 | 297 | (** {3 Type extensions} *) 298 | 299 | and Extension : sig 300 | 301 | module Constructor : sig 302 | 303 | type 'a t = 304 | { id: 'a Identifier.extension; 305 | doc: 'a Documentation.t; 306 | args: 'a TypeDecl.Constructor.argument; 307 | res: 'a TypeExpr.t option; } 308 | 309 | end 310 | 311 | type 'a t = 312 | { type_path: 'a Path.type_; 313 | doc: 'a Documentation.t; 314 | type_params: TypeDecl.param list; 315 | private_: bool; 316 | constructors: 'a Constructor.t list; } 317 | 318 | end = Extension 319 | 320 | (** {3 Exception} *) 321 | and Exception : sig 322 | 323 | type 'a t = 324 | { id: 'a Identifier.exception_; 325 | doc: 'a Documentation.t; 326 | args: 'a TypeDecl.Constructor.argument; 327 | res: 'a TypeExpr.t option; } 328 | 329 | end = Exception 330 | 331 | 332 | (** {3 Values} *) 333 | 334 | and Value : sig 335 | 336 | type 'a t = 337 | { id: 'a Identifier.value; 338 | doc: 'a Documentation.t; 339 | type_: 'a TypeExpr.t; } 340 | 341 | end = Value 342 | 343 | (** {3 External values} *) 344 | 345 | and External : sig 346 | 347 | type 'a t = 348 | { id: 'a Identifier.value; 349 | doc: 'a Documentation.t; 350 | type_: 'a TypeExpr.t; 351 | primitives: string list; } 352 | 353 | end = External 354 | 355 | (** {3 Classes} *) 356 | 357 | and Class : sig 358 | 359 | type 'a decl = 360 | | ClassType of 'a ClassType.expr 361 | | Arrow of TypeExpr.label option * 'a TypeExpr.t * 'a decl 362 | 363 | type 'a t = 364 | { id: 'a Identifier.class_; 365 | doc: 'a Documentation.t; 366 | virtual_: bool; 367 | params: TypeDecl.param list; 368 | type_: 'a decl; 369 | expansion: 'a ClassSignature.t option; } 370 | 371 | end = Class 372 | 373 | (** {3 Class Types} *) 374 | 375 | and ClassType : sig 376 | 377 | type 'a expr = 378 | | Constr of 'a Path.class_type * 'a TypeExpr.t list 379 | | Signature of 'a ClassSignature.t 380 | 381 | type 'a t = 382 | { id: 'a Identifier.class_type; 383 | doc: 'a Documentation.t; 384 | virtual_: bool; 385 | params: TypeDecl.param list; 386 | expr: 'a expr; 387 | expansion: 'a ClassSignature.t option; } 388 | 389 | end = ClassType 390 | 391 | (** {3 Class Signatures} *) 392 | 393 | and ClassSignature : sig 394 | 395 | type 'a item = 396 | | Method of 'a Method.t 397 | | InstanceVariable of 'a InstanceVariable.t 398 | | Constraint of 'a TypeExpr.t * 'a TypeExpr.t 399 | | Inherit of 'a ClassType.expr 400 | | Comment of 'a Documentation.comment 401 | 402 | type 'a t = 403 | { self: 'a TypeExpr.t option; 404 | items: 'a item list; } 405 | 406 | end = ClassSignature 407 | 408 | (** {3 Methods} *) 409 | 410 | and Method : sig 411 | 412 | type 'a t = 413 | { id: 'a Identifier.method_; 414 | doc: 'a Documentation.t; 415 | private_: bool; 416 | virtual_: bool; 417 | type_: 'a TypeExpr.t; } 418 | 419 | end = Method 420 | 421 | (** {3 Instance variables} *) 422 | 423 | and InstanceVariable : sig 424 | 425 | type 'a t = 426 | { id: 'a Identifier.instance_variable; 427 | doc: 'a Documentation.t; 428 | mutable_: bool; 429 | virtual_: bool; 430 | type_: 'a TypeExpr.t; } 431 | 432 | end = InstanceVariable 433 | 434 | (** {3 Type expressions} *) 435 | 436 | and TypeExpr : sig 437 | 438 | module Variant : sig 439 | 440 | type kind = 441 | | Fixed 442 | | Closed of string list 443 | | Open 444 | 445 | type 'a element = 446 | | Type of 'a TypeExpr.t 447 | | Constructor of string * bool * 'a TypeExpr.t list 448 | 449 | type 'a t = 450 | { kind: kind; 451 | elements: 'a element list;} 452 | 453 | end 454 | 455 | module Object : sig 456 | 457 | type 'a method_ = 458 | { name: string; 459 | type_: 'a TypeExpr.t; } 460 | 461 | type 'a field = 462 | | Method of 'a method_ 463 | | Inherit of 'a TypeExpr.t 464 | 465 | type 'a t = 466 | { fields: 'a field list; 467 | open_ : bool; } 468 | 469 | end 470 | 471 | module Package : sig 472 | 473 | type 'a substitution = 'a Fragment.type_ * 'a TypeExpr.t 474 | 475 | type 'a t = 476 | { path: 'a Path.module_type; 477 | substitutions: 'a substitution list; } 478 | 479 | end 480 | 481 | type label = 482 | | Label of string 483 | | Optional of string 484 | 485 | type 'a t = 486 | | Var of string 487 | | Any 488 | | Alias of 'a t * string 489 | | Arrow of label option * 'a t * 'a t 490 | | Tuple of 'a t list 491 | | Constr of 'a Path.type_ * 'a t list 492 | | Variant of 'a TypeExpr.Variant.t 493 | | Object of 'a TypeExpr.Object.t 494 | | Class of 'a Path.class_type * 'a t list 495 | | Poly of string list * 'a t 496 | | Package of 'a TypeExpr.Package.t 497 | 498 | end = TypeExpr 499 | 500 | (** {3 Compilation units} *) 501 | 502 | module rec Unit : sig 503 | 504 | module Import : sig 505 | 506 | type 'a t = 507 | | Unresolved of string * Digest.t option 508 | | Resolved of 'a 509 | 510 | end 511 | 512 | module Source : sig 513 | 514 | type 'a t = 515 | { file: string; 516 | build_dir: string; 517 | digest: Digest.t; } 518 | 519 | end 520 | 521 | module Packed : sig 522 | 523 | type 'a item = 524 | { id: 'a Identifier.module_; 525 | path: 'a Path.module_; } 526 | 527 | type 'a t = 'a item list 528 | 529 | end 530 | 531 | type 'a content = 532 | | Module of 'a Signature.t 533 | | Pack of 'a Packed.t 534 | 535 | type 'a t = 536 | { id: 'a Identifier.module_; 537 | doc: 'a Documentation.t; 538 | digest: Digest.t; 539 | imports: 'a Import.t list; 540 | source: 'a Source.t option; 541 | interface: bool; 542 | hidden: bool; 543 | content: 'a content; 544 | expansion: 'a Signature.t option; } 545 | 546 | end = Unit 547 | 548 | module rec Page : sig 549 | type 'a t = 550 | { name: 'a Identifier.page; 551 | content: 'a Documentation.t; 552 | digest: Digest.t; } 553 | end = Page 554 | -------------------------------------------------------------------------------- /src/index.mld: -------------------------------------------------------------------------------- 1 | {1 Library doc-ock} 2 | 3 | This library defines the AST used in by odoc to represent documentation. It also 4 | implements the operations working on this AST to do: 5 | - the {{!DocOck.resolving}resolving} of paths and references 6 | - the {{!DocOck.expansion}expansion} of signatures, i.e. it performs substitutions, etc. 7 | 8 | People wanting to process [.odoc] files (eg. to add a new backend) should only 9 | need to look at {{!DocOckTypes}DocOck.Types} and {{!DocOckPaths}DocOck.Paths}. 10 | 11 | For everything else, {!DocOck} is the main entry point of the library. 12 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name docOck) 5 | (public_name doc-ock) 6 | (wrapped false) 7 | (libraries (octavius compiler-libs.common)) 8 | (preprocess (action (run ${bin:cppo} -V OCAML:${ocaml_version} ${<}))))) 9 | -------------------------------------------------------------------------------- /test/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name ocamlary) 5 | (public_name doc-ock.ocamlary) 6 | (modules (ocamlary)))) 7 | 8 | (executables 9 | ((names (testCmi testCmti testCmt)) 10 | (modules (testCmi testCmti testCmt testCommon)) 11 | (libraries (doc-ock)))) 12 | 13 | (alias 14 | ((name runtest) 15 | (deps (ocamlary.cmi)) 16 | (action (run ${exe:testCmi.exe} ${<})))) 17 | 18 | (alias 19 | ((name runtest) 20 | (deps (ocamlary.cmti)) 21 | (action (run ${exe:testCmti.exe} ${<})))) 22 | 23 | (alias 24 | ((name runtest) 25 | (deps (ocamlary.cmt)) 26 | (action (run ${exe:testCmt.exe} ${<})))) 27 | -------------------------------------------------------------------------------- /test/ocamlary.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 David Sheets 3 | * Leo White 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** An interface with all of the module system features *) 19 | 20 | module type Empty = sig type t end 21 | 22 | (** An ambiguous, misnamed module type *) 23 | module type MissingComment = sig type t end 24 | 25 | (** A plain, empty module. *) 26 | module Empty = struct end 27 | 28 | (** A plain module alias. *) 29 | module EmptyAlias = Empty 30 | 31 | (** A plain, empty module signature. *) 32 | module type EmptySig = sig end 33 | 34 | (** A plain, empty module signature alias. *) 35 | module type EmptySigAlias = EmptySig 36 | 37 | (** A plain module of a signature. *) 38 | module ModuleWithSignature = struct end 39 | 40 | (** A plain module with an alias signature. *) 41 | module ModuleWithSignatureAlias = struct end 42 | 43 | (** has type "one" *) 44 | module One = struct type one end 45 | 46 | (** There's a module in this signature. *) 47 | module type SigForMod = sig 48 | module Inner : sig 49 | module type Empty = sig end 50 | end 51 | end 52 | 53 | module type SuperSig = sig 54 | module type SubSigA = sig 55 | (** {3:SubSig A Labeled Section Header Inside of a Signature} *) 56 | 57 | type t 58 | 59 | module SubSigAMod : sig 60 | type sub_sig_a_mod 61 | end 62 | end 63 | module type SubSigB = sig 64 | (** {3:SubSig Another Labeled Section Header Inside of a Signature} *) 65 | 66 | type t 67 | end 68 | module type EmptySig = sig 69 | type not_actually_empty 70 | end 71 | module type One = sig type two end 72 | module type SuperSig = sig end 73 | end 74 | 75 | (** {!Buffer.t} *) 76 | module Buffer = struct 77 | let f _ = () 78 | end 79 | 80 | (** Unary exception constructor *) 81 | exception Kaboom of unit 82 | 83 | (** Binary exception constructor *) 84 | exception Kablam of unit * unit 85 | 86 | (** Unary exception constructor over binary tuple *) 87 | exception Kapow of (unit * unit) 88 | 89 | (** {!EmptySig} is general but {!module:EmptySig} is a module and 90 | {!exception:EmptySig} is this exception. *) 91 | exception EmptySig 92 | 93 | (** {!exception:EmptySigAlias} is this exception. *) 94 | exception EmptySigAlias 95 | 96 | (** {!a_function} is general but {!type:a_function} is this type and 97 | {!val:a_function} is the value below. *) 98 | type ('a,'b) a_function = 'a -> 'b 99 | 100 | (** 101 | @param x the [x] coordinate 102 | @return the [y] coordinate 103 | *) 104 | let a_function ~x = x 105 | 106 | let fun_fun_fun _int_fun = (fun () -> ()) 107 | 108 | let fun_maybe ?yes:_ () = 0 109 | 110 | (** @raise Not_found That's all it does *) 111 | let not_found () = raise Not_found 112 | 113 | (** @see < http://ocaml.org/ > The OCaml Web site *) 114 | let ocaml_org = "http://ocaml.org/" 115 | 116 | (** @see 'some_file' The file called [some_file] *) 117 | let some_file = "some_file" 118 | 119 | (** @see "some_doc" The document called [some_doc] *) 120 | let some_doc = "some_doc" 121 | 122 | (** 123 | This value was introduced in the Mesozoic era. 124 | @since mesozoic 125 | *) 126 | let since_mesozoic = () 127 | 128 | (** 129 | This value has had changes in 1.0.0, 1.1.0, and 1.2.0. 130 | @before 1.0.0 before 1.0.0 131 | @before 1.1.0 before 1.1.0 132 | @version 1.2.0 133 | *) 134 | let changing = () 135 | 136 | (** This value has a custom tag [foo]. 137 | @foo the body of the custom [foo] tag 138 | *) 139 | let with_foo = () 140 | 141 | (** {3 Some Operators } *) 142 | 143 | let ( ~- ) = () 144 | let ( ! ) = () 145 | let ( @ ) = () 146 | let ( $ ) = () 147 | let ( % ) = () 148 | let ( ^ ) = () 149 | let ( & ) = () 150 | let ( * ) = () 151 | let ( - ) = () 152 | let ( + ) = () 153 | let ( < ) = () 154 | let ( > ) = () 155 | let ( -? ) = () 156 | let ( / ) = () 157 | let ( -| ) = () 158 | let ( := ) = () 159 | let ( = ) = () 160 | 161 | let (land) = () 162 | 163 | (** {3 Advanced Module Stuff} *) 164 | 165 | (** This comment is for [CollectionModule]. *) 166 | module CollectionModule = struct 167 | (** This comment is for [collection]. *) 168 | type collection 169 | type element 170 | 171 | (** This comment is for [InnerModuleA]. *) 172 | module InnerModuleA = struct 173 | (** This comment is for [t]. *) 174 | type t = collection 175 | 176 | (** This comment is for [InnerModuleA']. *) 177 | module InnerModuleA' = struct 178 | (** This comment is for [t]. *) 179 | type t = (unit,unit) a_function 180 | end 181 | 182 | (** This comment is for [InnerModuleTypeA']. *) 183 | module type InnerModuleTypeA' = sig 184 | (** This comment is for [t]. *) 185 | type t = InnerModuleA'.t 186 | end 187 | end 188 | 189 | (** This comment is for [InnerModuleTypeA]. *) 190 | module type InnerModuleTypeA = InnerModuleA.InnerModuleTypeA' 191 | end 192 | 193 | (** module type of *) 194 | module type COLLECTION = module type of CollectionModule 195 | 196 | module Recollection(C : COLLECTION) : 197 | COLLECTION with type collection = C.element list and type element = C.collection = struct 198 | type collection = C.element list 199 | type element = C.collection 200 | 201 | (** This comment is for [InnerModuleA]. *) 202 | module InnerModuleA = struct 203 | (** This comment is for [t]. *) 204 | type t = collection 205 | 206 | (** This comment is for [InnerModuleA']. *) 207 | module InnerModuleA' = struct 208 | (** This comment is for [t]. *) 209 | type t = (unit,unit) a_function 210 | end 211 | 212 | (** This comment is for [InnerModuleTypeA']. *) 213 | module type InnerModuleTypeA' = sig 214 | (** This comment is for [t]. *) 215 | type t = InnerModuleA'.t 216 | end 217 | end 218 | 219 | (** This comment is for [InnerModuleTypeA]. *) 220 | module type InnerModuleTypeA = InnerModuleA.InnerModuleTypeA' 221 | end 222 | 223 | module type MMM = sig module C : COLLECTION end 224 | 225 | module type RECOLLECTION = MMM with module C = Recollection(CollectionModule) 226 | 227 | module type RecollectionModule = sig 228 | include module type of Recollection(CollectionModule) 229 | end 230 | 231 | module type A = sig 232 | type t 233 | module Q : COLLECTION 234 | end 235 | 236 | module type B = sig 237 | type t 238 | module Q : COLLECTION 239 | end 240 | 241 | module type C = sig 242 | include A 243 | include B with type t := t and module Q := Q 244 | end 245 | 246 | (* 247 | (** This comment is for [Functor]. *) 248 | module Functor(EmptyAlias : EmptySigAlias) = struct 249 | (** This comment is for [FunctorInner]. *) 250 | module FunctorInner = EmptyAlias 251 | end 252 | *) 253 | 254 | (** This comment is for [FunctorTypeOf]. *) 255 | module FunctorTypeOf(Collection : module type of CollectionModule) = struct 256 | (** This comment is for [t]. *) 257 | type t = Collection.collection 258 | end 259 | 260 | (** This comment is for [IncludeModuleType]. *) 261 | module type IncludeModuleType = sig 262 | (** This comment is for [include EmptySigAlias]. *) 263 | include EmptySigAlias 264 | end 265 | 266 | module type ToInclude = sig 267 | module IncludedA : sig 268 | type t 269 | end 270 | module type IncludedB = sig 271 | type s 272 | end 273 | end 274 | 275 | module IncludedA = struct 276 | type t 277 | end 278 | 279 | module type IncludedB = sig 280 | type s 281 | end 282 | 283 | (** {3 Advanced Type Stuff} *) 284 | 285 | (** This comment is for [record]. *) 286 | type record = { 287 | field1 : int; (** This comment is for [field1]. *) 288 | field2 : int; (** This comment is for [field2]. *) 289 | } 290 | (** This comment is also for [record]. *) 291 | 292 | type mutable_record = { 293 | mutable a : int; (** [a] is first and mutable *) 294 | b : unit; (** [b] is second and immutable *) 295 | mutable c : int; (** [c] is third and mutable *) 296 | } 297 | 298 | type universe_record = { 299 | nihilate : 'a. 'a -> unit; 300 | } 301 | 302 | (** This comment is for [variant]. *) 303 | type variant = 304 | | TagA (** This comment is for [TagA]. *) 305 | | ConstrB of int (** This comment is for [ConstrB]. *) 306 | | ConstrC of int * int (** This comment is for binary [ConstrC]. *) 307 | | ConstrD of (int * int) 308 | (** This comment is for unary [ConstrD] of binary tuple. *) 309 | (** This comment is also for [variant]. *) 310 | 311 | (** This comment is for [poly_variant]. *) 312 | type poly_variant = [ 313 | | `TagA (** This comment is for [`TagA]. *) 314 | | `ConstrB of int (** This comment is for [`ConstrB]. *) 315 | ] 316 | (** Wow! It was a polymorphic variant! *) 317 | 318 | (** This comment is for [full_gadt]. *) 319 | type (_,_) full_gadt = 320 | | Tag : (unit,unit) full_gadt 321 | | First : 'a -> ('a,unit) full_gadt 322 | | Second : 'a -> (unit,'a) full_gadt 323 | | Exist : 'a * 'b -> ('b, unit) full_gadt 324 | (** Wow! It was a GADT! *) 325 | 326 | (** This comment is for [partial_gadt]. *) 327 | type 'a partial_gadt = 328 | | AscribeTag : 'a partial_gadt 329 | | OfTag of 'a partial_gadt 330 | | ExistGadtTag : ('a -> 'b) -> 'a partial_gadt 331 | (** Wow! It was a mixed GADT! *) 332 | 333 | (** This comment is for [record_arg_gadt]. *) 334 | type _ record_arg_gadt = 335 | | With_rec : { foo : int } -> unit record_arg_gadt 336 | | With_poly_rec : { bar : 'a. 'a -> 'a } -> ('a -> 'a) record_arg_gadt (** *) 337 | (** Wow! It was a GADT with record arguments *) 338 | 339 | (** This comment is for [alias]. *) 340 | type alias = variant 341 | 342 | (** This comment is for [tuple]. *) 343 | type tuple = (alias * alias) * alias * (alias * alias) 344 | 345 | (** This comment is for [variant_alias]. *) 346 | type variant_alias = variant = 347 | | TagA 348 | | ConstrB of int 349 | | ConstrC of int * int 350 | | ConstrD of (int * int) 351 | 352 | (** This comment is for [record_alias]. *) 353 | type record_alias = record = { 354 | field1 : int; 355 | field2 : int; 356 | } 357 | 358 | (** This comment is for [poly_variant_union]. *) 359 | type poly_variant_union = [ 360 | | poly_variant 361 | | `TagC 362 | ] 363 | 364 | type 'a poly_poly_variant = [ 365 | | `TagA of 'a 366 | ] 367 | 368 | type ('a,'b) bin_poly_poly_variant = [ 369 | | `TagA of 'a 370 | | `ConstrB of 'b 371 | ] 372 | 373 | (* TODO: figure out how to spec a conjunctive type 374 | type amb_poly_variant = [ 375 | | unit poly_poly_variant 376 | | (int,unit) bin_poly_poly_variant 377 | | `TagC 378 | ] 379 | *) 380 | 381 | type 'a open_poly_variant = [> `TagA ] as 'a 382 | 383 | type 'a open_poly_variant2 = [> `ConstrB of int ] as 'a 384 | 385 | type 'a open_poly_variant_alias = 'a open_poly_variant open_poly_variant2 386 | 387 | type 'a poly_fun = ([> `ConstrB of int ] as 'a) -> 'a 388 | 389 | type 'a poly_fun_constraint = 'a -> 'a constraint 'a = [> `TagA ] 390 | 391 | type 'a closed_poly_variant = [< `One | `Two ] as 'a 392 | 393 | type 'a clopen_poly_variant = 394 | [< `One | `Two of int | `Three > `Two `Three] as 'a 395 | 396 | type nested_poly_variant = [ 397 | | `A 398 | | `B of [ 399 | | `B1 400 | | `B2 401 | ] 402 | | `C 403 | | `D of [ 404 | | `D1 of [ 405 | `D1a 406 | ] 407 | ] 408 | ] 409 | 410 | (** This comment is for [full_gadt_alias]. *) 411 | type ('a,'b) full_gadt_alias = ('a,'b) full_gadt = 412 | | Tag : (unit,unit) full_gadt_alias 413 | | First : 'a -> ('a,unit) full_gadt_alias 414 | | Second : 'a -> (unit,'a) full_gadt_alias 415 | | Exist : 'a * 'b -> ('b, unit) full_gadt_alias 416 | 417 | (** This comment is for [partial_gadt_alias]. *) 418 | type 'a partial_gadt_alias = 'a partial_gadt = 419 | | AscribeTag : 'a partial_gadt_alias 420 | | OfTag of 'a partial_gadt_alias 421 | | ExistGadtTag : ('a -> 'b) -> 'a partial_gadt_alias 422 | 423 | (** This comment is for {!exn_arrow}. *) 424 | exception Exn_arrow : unit -> exn 425 | 426 | (** This comment is for {!mutual_constr_a} and {!mutual_constr_b}. *) 427 | type mutual_constr_a = 428 | | A 429 | | B_ish of mutual_constr_b 430 | and mutual_constr_b = 431 | | B 432 | | A_ish of mutual_constr_a 433 | 434 | type rec_obj = < f : int; g : unit -> unit; h : rec_obj > 435 | 436 | type 'a open_obj = < f : int; g : unit -> unit; .. > as 'a 437 | 438 | type 'a oof = (< a : unit; .. > as 'a) -> 'a 439 | 440 | type 'a any_obj = < .. > as 'a 441 | 442 | type empty_obj = < > 443 | 444 | type one_meth = < meth: unit > 445 | 446 | (** A mystery wrapped in an ellipsis *) 447 | type ext = .. 448 | 449 | type ext += ExtA 450 | type ext += ExtB 451 | type ext += 452 | | ExtC of unit 453 | | ExtD of ext 454 | type ext += ExtE 455 | 456 | type ext += private ExtF 457 | 458 | type 'a poly_ext = .. 459 | (** 'a poly_ext *) 460 | 461 | type 'b poly_ext += Foo of 'b | Bar of 'b * 'b 462 | (** 'b poly_ext *) 463 | 464 | type 'c poly_ext += Quux of 'c 465 | 466 | module ExtMod = struct 467 | type t = .. 468 | 469 | type t += Leisureforce 470 | end 471 | 472 | type ExtMod.t += ZzzTop0 473 | (** It's got the rock *) 474 | 475 | type ExtMod.t += ZzzTop of unit 476 | (** and it packs a unit. *) 477 | 478 | (** Rotate keys on my mark... *) 479 | external launch_missiles : unit -> unit = "tetris" 480 | 481 | (** A brown paper package tied up with string*) 482 | type my_mod = (module COLLECTION) 483 | 484 | class empty_class = object val x = 0 end 485 | 486 | class one_method_class = object 487 | method go = () 488 | end 489 | 490 | class two_method_class = object 491 | method one = new one_method_class 492 | method undo = () 493 | end 494 | 495 | class ['a] param_class x = object 496 | method v : 'a = x 497 | end 498 | 499 | 500 | type my_unit_object = unit param_class 501 | 502 | type 'a my_unit_class = unit #param_class as 'a 503 | 504 | (* Test resolution of dependently typed modules *) 505 | module Dep1 = struct 506 | 507 | module type S = sig 508 | class c : object 509 | method m : int 510 | end 511 | end 512 | 513 | module X = struct 514 | module Y = struct 515 | class c = object 516 | method m = 4 517 | end 518 | end 519 | end 520 | 521 | end 522 | 523 | module Dep2 (Arg : sig module type S module X : sig module Y : S end end) = 524 | struct 525 | module A = Arg.X 526 | module B = A.Y 527 | end 528 | 529 | type dep1 = Dep2(Dep1).B.c;; 530 | 531 | module Dep3 = struct type a end 532 | 533 | module Dep4 = struct 534 | module type T = sig type b end 535 | module type S = sig 536 | module X : T 537 | module Y : sig end 538 | end 539 | module X = struct type b end 540 | end 541 | 542 | module Dep5 (Arg : sig 543 | module type T 544 | module type S = sig 545 | module X : T 546 | module Y : sig end 547 | end 548 | module X : T 549 | end) = struct 550 | module Z : Arg.S with module Y = Dep3 = struct 551 | module X = Arg.X 552 | module Y = Dep3 553 | end 554 | end 555 | 556 | type dep2 = Dep5(Dep4).Z.X.b 557 | 558 | type dep3 = Dep5(Dep4).Z.Y.a 559 | 560 | module Dep6 = struct 561 | module type S = sig type d end 562 | module type T = sig 563 | module type R = S 564 | module Y : R 565 | end 566 | module X = struct 567 | module type R = S 568 | module Y = struct type d end 569 | end 570 | end 571 | 572 | module Dep7 (Arg : sig 573 | module type S 574 | module type T = sig 575 | module type R = S 576 | module Y : R 577 | end 578 | module X : T 579 | end) = struct 580 | module M = Arg.X 581 | end 582 | 583 | type dep4 = Dep7(Dep6).M.Y.d;; 584 | 585 | module Dep8 = struct 586 | module type T = sig type t end 587 | end 588 | 589 | module Dep9(X : sig module type T end) = X 590 | 591 | module type Dep10 = Dep9(Dep8).T with type t = int 592 | 593 | module Dep11 = struct 594 | module type S = sig 595 | class c : object 596 | method m : int 597 | end 598 | end 599 | end 600 | 601 | module Dep12 = 602 | functor (Arg : sig module type S end) -> struct 603 | module type T = Arg.S 604 | end 605 | 606 | module Dep13 = struct 607 | class c = object 608 | method m = 4 609 | end 610 | end 611 | 612 | type dep5 = Dep13.c 613 | 614 | module type With1 = sig 615 | module M : sig 616 | module type S 617 | end 618 | module N : M.S 619 | end 620 | 621 | module With2 = struct 622 | module type S = sig type t end 623 | end 624 | 625 | module With3 = struct 626 | module M = With2 627 | module N = struct 628 | type t = int 629 | end 630 | end 631 | 632 | type with1 = With3.N.t 633 | 634 | module With4 = struct 635 | module N = struct 636 | type t = int 637 | end 638 | end 639 | 640 | type with2 = With4.N.t 641 | 642 | module With5 = struct 643 | module type S = sig type t end 644 | module N = struct type t = float end 645 | end 646 | 647 | module With6 = struct 648 | module type T = sig 649 | module M : sig 650 | module type S 651 | module N : S 652 | end 653 | end 654 | end 655 | 656 | module With7 (X : sig module type T end) = X 657 | 658 | module type With8 = With7(With6).T with module M = With5 and type M.N.t = With5.N.t 659 | 660 | module With9 = struct 661 | module type S = sig type t end 662 | end 663 | 664 | module With10 = struct 665 | module type T = sig 666 | module M : sig 667 | module type S 668 | end 669 | module N : M.S 670 | end 671 | end 672 | 673 | module type With11 = With7(With10).T with module M = With9 and type N.t = int 674 | 675 | module type NestedInclude1 = sig 676 | 677 | module type NestedInclude2 = sig type nested_include end 678 | 679 | end 680 | 681 | module type NestedInclude2 = sig 682 | type nested_include 683 | end 684 | 685 | type nested_include = int 686 | 687 | module DoubleInclude1 = struct 688 | module DoubleInclude2 = struct 689 | type double_include 690 | end 691 | end 692 | 693 | module DoubleInclude3 = struct 694 | include DoubleInclude1 695 | end 696 | 697 | include DoubleInclude3.DoubleInclude2 698 | 699 | module IncludeInclude1 = struct 700 | module type IncludeInclude2 = sig 701 | type include_include 702 | end 703 | end 704 | 705 | include IncludeInclude1 706 | type include_include 707 | 708 | module Caml_list = List 709 | 710 | module CanonicalTest = struct 711 | module Base__List = struct 712 | type 'a t = 'a list 713 | 714 | let id x = x 715 | end 716 | 717 | module Base__ = struct 718 | (** @canonical Ocamlary.CanonicalTest.Base.List *) 719 | module List = Base__List 720 | end 721 | 722 | module Base = struct 723 | module List = Base__.List 724 | end 725 | 726 | module Base__Tests = struct 727 | module C = struct 728 | include Base__.List 729 | end 730 | 731 | open Base__ 732 | 733 | module L = List 734 | 735 | let foo (l : int L.t) : float L.t = 736 | Caml_list.map float_of_int l 737 | 738 | (** This is just {!List.id}, or rather {!L.id} *) 739 | let bar (l : 'a List.t) : 'a List.t = 740 | L.id l 741 | 742 | (** Just seeing if {!Base__.List.t} ([Base__.List.t]) gets rewriten to 743 | {!Base.List.t} ([Base.List.t]) *) 744 | let baz (_ : 'a Base__.List.t) = () 745 | end 746 | 747 | module List_modif = struct 748 | include Base.List 749 | end 750 | end 751 | 752 | let test _ = () 753 | (** Some ref to {!CanonicalTest.Base__Tests.C.t} and {!CanonicalTest.Base__Tests.D.id}. 754 | But also to {!CanonicalTest.Base__.List} and {!CanonicalTest.Base__.List.t} *) 755 | 756 | (** {1 Aliases again} *) 757 | 758 | module Aliases = struct 759 | (** Let's imitate jst's layout. *) 760 | 761 | module Foo__A = struct 762 | type t 763 | 764 | let id t = t 765 | end 766 | 767 | module Foo__B = struct 768 | type t 769 | 770 | let id t = t 771 | end 772 | 773 | module Foo__C = struct 774 | type t 775 | 776 | let id t = t 777 | end 778 | 779 | module Foo__D = struct 780 | type t 781 | 782 | let id t = t 783 | end 784 | 785 | module Foo__E = struct 786 | type t 787 | 788 | let id t = t 789 | end 790 | 791 | module Foo__ = struct 792 | 793 | (** @canonical Ocamlary.Aliases.Foo.A *) 794 | module A = Foo__A 795 | 796 | (** @canonical Ocamlary.Aliases.Foo.B *) 797 | module B = Foo__B 798 | 799 | (** @canonical Ocamlary.Aliases.Foo.C *) 800 | module C = Foo__C 801 | 802 | (** @canonical Ocamlary.Aliases.Foo.D *) 803 | module D = Foo__D 804 | 805 | module E = Foo__E 806 | end 807 | 808 | module Foo = struct 809 | open Foo__ 810 | 811 | module A = A 812 | module B = B 813 | module C = C 814 | module D = D 815 | 816 | module E = E 817 | end 818 | 819 | module A' = Foo.A 820 | 821 | type tata = Foo.A.t 822 | type tbtb = Foo__.B.t 823 | type tete = Foo__.E.t 824 | type tata' = A'.t 825 | type tete2 = Foo.E.t 826 | 827 | module Std = struct 828 | module A = Foo.A 829 | module B = Foo.B 830 | module C = Foo.C 831 | module D = Foo.D 832 | module E = Foo.E 833 | end 834 | 835 | type stde = Std.E.t 836 | 837 | (** {3 include of Foo} 838 | 839 | Just for giggle, let's see what happens when we include {!Foo}. *) 840 | 841 | include Foo (** @inline *) 842 | 843 | type testa = A.t 844 | 845 | (** And also, let's refer to {!A.t} and {!Foo.B.id} *) 846 | 847 | module P1 = struct 848 | (** @canonical Ocamlary.Aliases.P2.Z *) 849 | module Y = struct 850 | type t 851 | 852 | let id x = x 853 | end 854 | end 855 | 856 | module P2 = struct 857 | module Z = P1.Y 858 | end 859 | 860 | module X1 = P1.Y 861 | module X2 = P2.Z 862 | 863 | type p1 = X1.t 864 | type p2 = X2.t 865 | end 866 | 867 | (** {1 New reference syntax} *) 868 | 869 | module type M = sig 870 | type t 871 | end 872 | 873 | module M = struct 874 | type t 875 | end 876 | 877 | (** Here goes: 878 | - [{!M.t}] : {!M.t} 879 | - [{!module-M.t}] : {!module-M.t} 880 | - [{!module-type-M.t}] : {!module-type-M.t} *) 881 | 882 | module Only_a_module = struct 883 | type t 884 | end 885 | 886 | (** Some here should fail: 887 | - [{!Only_a_module.t}] : {!Only_a_module.t} 888 | - [{!module-Only_a_module.t}] : {!module-Only_a_module.t} 889 | - [{!module-type-Only_a_module.t}] : {!module-type-Only_a_module.t} *) 890 | -------------------------------------------------------------------------------- /test/testCmi.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOck 18 | open TestCommon 19 | 20 | let read_file cmi = 21 | match read_cmi (fun name _ -> name) cmi with 22 | | Not_an_interface -> 23 | raise (Error(cmi, "not an interface")) 24 | | Wrong_version -> 25 | raise (Error(cmi, "wrong OCaml version")) 26 | | Corrupted -> 27 | raise (Error(cmi, "corrupted")) 28 | | Not_a_typedtree -> 29 | raise (Error(cmi, "not a typedtree")) 30 | | Not_an_implementation -> 31 | raise (Error(cmi, "not an implementation")) 32 | | Ok intf -> intf 33 | 34 | let main () = 35 | let files = get_files "cmi" in 36 | try 37 | test read_file (List.rev files); 38 | exit 0 39 | with Error(file, msg) -> 40 | prerr_endline (file ^ ": " ^ msg); 41 | exit 1 42 | 43 | let () = main () 44 | -------------------------------------------------------------------------------- /test/testCmt.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOck 18 | open TestCommon 19 | 20 | let read_file cmt = 21 | match read_cmt (fun name _ -> name) cmt with 22 | | Not_an_interface -> 23 | raise (Error(cmt, "not an interface")) 24 | | Wrong_version -> 25 | raise (Error(cmt, "wrong OCaml version")) 26 | | Corrupted -> 27 | raise (Error(cmt, "corrupted")) 28 | | Not_a_typedtree -> 29 | raise (Error(cmt, "not a typedtree")) 30 | | Not_an_implementation -> 31 | raise (Error(cmt, "not an implementation")) 32 | | Ok intf -> intf 33 | 34 | let main () = 35 | let files = get_files "cmt" in 36 | try 37 | test read_file (List.rev files); 38 | exit 0 39 | with Error(file, msg) -> 40 | prerr_endline (file ^ ": " ^ msg); 41 | exit 1 42 | 43 | let () = main () 44 | -------------------------------------------------------------------------------- /test/testCmti.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Leo White 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open DocOck 18 | open TestCommon 19 | 20 | let read_file cmti = 21 | match read_cmti (fun name _ -> name) cmti with 22 | | Not_an_interface -> 23 | raise (Error(cmti, "not an interface")) 24 | | Wrong_version -> 25 | raise (Error(cmti, "wrong OCaml version")) 26 | | Corrupted -> 27 | raise (Error(cmti, "corrupted")) 28 | | Not_a_typedtree -> 29 | raise (Error(cmti, "not a typedtree")) 30 | | Not_an_implementation -> 31 | raise (Error(cmti, "not an implementation")) 32 | | Ok intf -> intf 33 | 34 | let main () = 35 | let files = get_files "cmti" in 36 | try 37 | test read_file (List.rev files); 38 | exit 0 39 | with Error(file, msg) -> 40 | prerr_endline (file ^ ": " ^ msg); 41 | exit 1 42 | 43 | let () = main () 44 | -------------------------------------------------------------------------------- /test/testCommon.ml: -------------------------------------------------------------------------------- 1 | 2 | open DocOck 3 | open Paths 4 | open Types 5 | 6 | class ident = object 7 | method root x = x 8 | inherit [string] Maps.paths 9 | inherit [string] Maps.types 10 | end 11 | 12 | exception Error of string * string 13 | 14 | let module_name file = 15 | let base = Filename.basename file in 16 | let prefix = 17 | try 18 | let pos = String.index base '.' in 19 | String.sub base 0 pos 20 | with Not_found -> base 21 | in 22 | String.capitalize_ascii prefix 23 | 24 | let to_root file = 25 | let name = module_name file in 26 | name, Paths.contains_double_underscore name 27 | 28 | let check_identity_map file intf = 29 | let ident = new ident in 30 | let intf' = ident#unit intf in 31 | if intf != intf' then 32 | raise (Error(file, "deep identity map failed")) 33 | else () 34 | 35 | let lookup files = 36 | let names = List.map to_root files in 37 | fun file source name -> 38 | if (Identifier.name source.Unit.id) <> (module_name file) then 39 | raise (Error(file, "bad lookup during resolution")); 40 | match List.assoc name names with 41 | | hidden -> Found { root = name; hidden } 42 | | exception Not_found -> Not_found 43 | 44 | let fetch intfs = 45 | let intfs = 46 | List.map (fun (file, intf) -> (module_name file, intf)) intfs 47 | in 48 | fun file name -> 49 | try 50 | List.assoc name intfs 51 | with Not_found -> 52 | let msg = "bad fetch of " ^ name ^ " during resolution" in 53 | raise (Error(file, msg)) 54 | 55 | let resolve_file lookup fetch file intf = 56 | let resolver = build_resolver (lookup file) (fetch file) in 57 | resolve resolver intf 58 | 59 | let expand_file fetch file intf = 60 | let expander = 61 | build_expander (fun _ -> Not_found) (fun ~root:_ name -> fetch file name) 62 | in 63 | expand expander intf 64 | 65 | let test read files = 66 | let intfs = 67 | List.map (fun file -> file, read file) files 68 | in 69 | List.iter (fun (file, intf) -> check_identity_map file intf) intfs; 70 | let lookup = lookup files in 71 | let fetch = fetch intfs in 72 | let intfs' = 73 | List.map 74 | (fun (file, intf) -> file, resolve_file lookup fetch file intf) 75 | intfs 76 | in 77 | ignore 78 | (List.map (fun (file, intf) -> file, expand_file fetch file intf) intfs') 79 | 80 | let get_files kind = 81 | let files = ref [] in 82 | let add_file file = 83 | files := file :: !files 84 | in 85 | Arg.parse [] add_file ("Test doc-ock on " ^ kind ^ " files"); 86 | !files 87 | --------------------------------------------------------------------------------