substitutions on first class modules (fix ocaml/odoc#75)

Author: trefis

src/html_tree.ml

@@ -124,24 +124,24 @@ module Relative_link = struct
       | "" -> suffix
       | _  -> prefix ^ "." ^ suffix
 
-    let rec _render_raw : type a. (_, _) Identifier.t -> (_, a, _) Fragment.raw -> string =
-      fun id fragment ->
+    let rec render_raw : type a. (_, a, _) Fragment.raw -> string =
+      fun fragment ->
         let open Fragment in
         match fragment with
-        | Resolved rr -> render_resolved id rr
-        | Dot (prefix, suffix) -> dot (_render_raw id prefix) suffix
+        | Resolved rr -> render_resolved rr
+        | Dot (prefix, suffix) -> dot (render_raw prefix) suffix
 
-    and render_resolved : type a. (_, _) Identifier.t -> (_, a, _) Fragment.Resolved.raw -> string =
-      fun id fragment ->
+    and render_resolved : type a. (_, a, _) Fragment.Resolved.raw -> string =
+      fun fragment ->
         let open Fragment.Resolved in
         match fragment with
         | Root -> ""
-        | Subst (_, rr) -> render_resolved id (any_sort rr)
-        | SubstAlias (_, rr) -> render_resolved id (any_sort rr)
-        | Module (rr, s) -> dot (render_resolved id rr) s
-        | Type (rr, s) -> dot (render_resolved id rr) s
-        | Class (rr, s) -> dot (render_resolved id rr) s
-        | ClassType (rr, s) -> dot (render_resolved id rr) s
+        | Subst (_, rr) -> render_resolved (any_sort rr)
+        | SubstAlias (_, rr) -> render_resolved (any_sort rr)
+        | Module (rr, s) -> dot (render_resolved rr) s
+        | Type (rr, s) -> dot (render_resolved rr) s
+        | Class (rr, s) -> dot (render_resolved rr) s
+        | ClassType (rr, s) -> dot (render_resolved rr) s
 
     let rec to_html : type a. get_package:('b -> string) -> stop_before:bool ->
       _ Identifier.signature -> ('b, a, _) Fragment.raw -> _ =
@@ -159,7 +159,7 @@ module Relative_link = struct
           end
         | Resolved rr ->
           let id = Resolved.identifier id (Obj.magic rr : (_, a) Resolved.t) in
-          let txt = render_resolved id rr in
+          let txt = render_resolved rr in
           begin match Id.href ~get_package ~stop_before id with
           | href ->
             [ a ~a:[ a_href href ] [ pcdata txt ] ]
@@ -192,6 +192,8 @@ module Relative_link = struct
     a_href (prefix ^ name ^ (if !semantic_uris then "" else "/index.html"))
 end
 
+let render_fragment = Relative_link.Of_fragment.render_raw
+
 class page_creator ?kind ~path content =
   let rec add_dotdot ~n acc =
     if n = 0 then

src/html_tree.mli

@@ -90,6 +90,8 @@ module Relative_link : sig
   val to_sub_element : kind:kind -> string -> [> `Href ] attrib
 end
 
+val render_fragment : (_, _, Fragment.sort) Fragment.raw -> string
+
 (* TODO: move to a centralized [State] module or something. Along with
    Relative_link.semantic_uris. *)
 val open_details : bool ref

src/to_html_tree.ml

@@ -747,9 +747,34 @@ and type_expr
   | Poly (polyvars, t) ->
     pcdata (String.concat ~sep:" " polyvars ^ ". ") :: type_expr ~get_package t
   | Package pkg ->
-    (* CR trefis: TODO substitutions *)
     pcdata "(" :: Markup.keyword "module " ::
-    Html_tree.Relative_link.of_path ~stop_before:false ~get_package pkg.path @ [pcdata ")"]
+    Html_tree.Relative_link.of_path ~stop_before:false ~get_package pkg.path @
+    begin match pkg.substitutions with
+    | [] -> []
+    | lst ->
+      pcdata " " :: Markup.keyword "with" :: pcdata " " ::
+      list_concat_map ~sep:(Markup.keyword " and ") lst
+        ~f:(package_subst ~get_package pkg.path)
+    end
+    @ [pcdata ")"]
+
+and package_subst
+   : 'inner 'outer. get_package:('a -> string)
+   -> 'a Path.module_type -> 'a Fragment.type_ * 'a Types.TypeExpr.t
+   -> ('inner, 'outer) text elt list
+   = fun ~get_package pkg_path (frag_typ, te) ->
+  Markup.keyword "type " ::
+  (match pkg_path with
+   | Path.Resolved rp ->
+     let base =
+       Identifier.signature_of_module_type (Path.Resolved.identifier rp)
+     in
+     Html_tree.Relative_link.of_fragment ~get_package ~base
+       (Fragment.any_sort frag_typ)
+   | _ ->
+     [ pcdata (Html_tree.render_fragment (Fragment.any_sort frag_typ)) ]) @
+  pcdata " " :: Markup.keyword "=" :: pcdata " " ::
+  type_expr ~get_package te
 
 and value ~get_package (t : _ Types.Value.t) =
   let name = Identifier.name t.id in