Fix for github issue 1001

src/document/generator.ml

@@ -26,6 +26,8 @@ let tag tag t = O.span ~attr:tag t
 let label t =
   match t with
   | Odoc_model.Lang.TypeExpr.Label s -> tag "label" (O.txt s)
+  | RawOptional _s ->
+      tag "error" (O.txt "Error: RawOptional found during rendering")
   | Optional s -> tag "optlabel" (O.txt "?" ++ O.txt s)
 
 let type_var tv = tag "type-var" (O.txt tv)

src/loader/cmi.ml

@@ -452,14 +452,18 @@ let rec read_type_expr env typ =
             if name = "_" then Any
             else Var name
       | Tarrow(lbl, arg, res, _) ->
-          let arg =
-            if Btype.is_optional lbl then
+          let lbl = read_label lbl in
+          let lbl,arg =
+            match lbl with
+            | Some (Optional s) -> (
               match Compat.get_desc arg with
-              | Tconstr(_option, [arg], _) -> read_type_expr env arg
-              | _ -> assert false
-            else read_type_expr env arg
+              | Tconstr(_option, [arg], _) ->
+                lbl, read_type_expr env arg (* Unwrap option if possible *)
+              | _ ->
+                (Some (RawOptional s), read_type_expr env arg)) (* If not, mark is as wrapped *)
+            | _ ->
+              lbl, read_type_expr env arg
           in
-          let lbl = read_label lbl in
           let res = read_type_expr env res in
             Arrow(lbl, arg, res)
       | Ttuple typs ->
@@ -936,16 +940,18 @@ let rec read_class_type env parent params =
   | Cty_constr _ | Cty_signature _ as cty ->
       ClassType (read_class_signature env parent params cty)
   | Cty_arrow(lbl, arg, cty) ->
-      let arg =
-        if Btype.is_optional lbl then
+      let lbl = read_label lbl in
+      let lbl, arg =
+        match lbl with
+        | Some (Optional s) -> (
           match Compat.get_desc arg with
-          | Tconstr(path, [arg], _)
-            when OCamlPath.same path Predef.path_option ->
-              read_type_expr env arg
-          | _ -> assert false
-        else read_type_expr env arg
+          | Tconstr(_option, [arg], _) ->
+            lbl, read_type_expr env arg (* Unwrap option if possible *)
+          | _ ->
+            (Some (RawOptional s), read_type_expr env arg)) (* If not, mark is as wrapped *)
+        | _ ->
+          lbl, read_type_expr env arg
       in
-      let lbl = read_label lbl in
       let cty = read_class_type env parent params cty in
         Arrow(lbl, arg, cty)
 

src/model/lang.ml

@@ -431,7 +431,7 @@ and TypeExpr : sig
     type t = { path : Path.ModuleType.t; substitutions : substitution list }
   end
 
-  type label = Label of string | Optional of string
+  type label = Label of string | RawOptional of string | Optional of string
 
   type t =
     | Var of string

src/model_desc/lang_desc.ml

@@ -610,7 +610,9 @@ and typeexpr_label =
   let open Lang.TypeExpr in
   Variant
     (function
-    | Label x -> C ("Label", x, string) | Optional x -> C ("Optional", x, string))
+    | Label x -> C ("Label", x, string)
+    | RawOptional x -> C ("RawOptional", x, string)
+    | Optional x -> C ("Optional", x, string))
 
 and typeexpr_t =
   let open Lang.TypeExpr in

src/xref2/compile.ml

@@ -858,14 +858,51 @@ and type_expression_package env parent p =
               }))
   | Error _ -> { p with path = Lang_of.(Path.module_type (empty ()) cp) }
 
+and handle_arrow :
+    Env.t ->
+    Id.Id.label_parent ->
+    TypeExpr.label option ->
+    TypeExpr.t ->
+    TypeExpr.t ->
+    TypeExpr.t =
+ fun env parent lbl t1 t2 ->
+  let t2' = type_expression env parent t2 in
+  match lbl with
+  | Some (Optional _ | Label _) | None ->
+      Arrow (lbl, type_expression env parent t1, t2')
+  | Some (RawOptional s) -> (
+      (* s is definitely an option type, but not _obviously_ so. *)
+      match Component.Of_Lang.(type_expression (empty ()) t1) with
+      | Constr (p, _ts) -> (
+          (* This handles only the simplest case *)
+          let find_option t =
+            match Tools.resolve_type env t with
+            | Ok (_, `FType (_n, decl)) -> (
+                match decl.equation.manifest with
+                | Some (Constr (`Resolved (`CoreType n), [ t ]))
+                  when Names.TypeName.to_string n = "option" ->
+                    let t = Lang_of.(type_expr (empty ()) parent t) in
+                    Some t
+                | Some _ -> None
+                | None -> None)
+            | Ok (_, `CoreType _) -> None
+            | Ok (_, (`FClass _ | `FClassType _ | `FType_removed _)) -> None
+            | Error _ -> None
+          in
+          match find_option p with
+          | Some t1 ->
+              Arrow (Some (Optional s), type_expression env parent t1, t2')
+          | None ->
+              Arrow (Some (RawOptional s), type_expression env parent t1, t2'))
+      | _ -> Arrow (Some (RawOptional s), type_expression env parent t1, t2'))
+
 and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ =
  fun env parent texpr ->
   let open TypeExpr in
   match texpr with
   | Var _ | Any -> texpr
   | Alias (t, str) -> Alias (type_expression env parent t, str)
-  | Arrow (lbl, t1, t2) ->
-      Arrow (lbl, type_expression env parent t1, type_expression env parent t2)
+  | Arrow (lbl, t1, t2) -> handle_arrow env parent lbl t1 t2
   | Tuple ts -> Tuple (List.map (type_expression env parent) ts)
   | Constr (path, ts') -> (
       let cp = Component.Of_Lang.(type_path (empty ()) path) in

src/xref2/component.ml

@@ -1078,6 +1078,7 @@ module Fmt = struct
   and type_expr_label ppf l =
     match l with
     | Some (Odoc_model.Lang.TypeExpr.Label l) -> Format.fprintf ppf "%s:" l
+    | Some (RawOptional o) -> Format.fprintf ppf "?(%s):" o
     | Some (Optional o) -> Format.fprintf ppf "?%s:" o
     | None -> ()
 

test/xref2/github_issue_1001.t/run.t

@@ -1,30 +1,28 @@
   $ ocamlc -c -bin-annot test.ml
   $ odoc compile test.cmt
-  odoc: internal error, uncaught exception:
-        File "src/loader/cmi.ml", line 459, characters 21-27: Assertion failed
-        Raised at Odoc_loader__Cmi.read_type_expr in file "src/loader/cmi.ml", line 459, characters 21-33
-        Called from Odoc_loader__Cmt.read_pattern in file "src/loader/cmt.ml", line 50, characters 22-57
-        Called from Odoc_loader__Cmt.read_value_bindings.(fun) in file "src/loader/cmt.ml", line 106, characters 18-50
-        Called from Stdlib__List.fold_left in file "list.ml", line 123, characters 24-34
-        Called from Odoc_loader__Cmt.read_value_bindings in file "src/loader/cmt.ml", line 100, characters 4-401
-        Called from Odoc_loader__Cmt.read_structure.(fun) in file "src/loader/cmt.ml", line 609, characters 24-61
-        Called from Stdlib__List.fold_left in file "list.ml", line 123, characters 24-34
-        Called from Odoc_loader__Cmt.read_structure in file "src/loader/cmt.ml", line 607, characters 4-127
-        Called from Odoc_loader__Cmt.read_implementation in file "src/loader/cmt.ml", line 624, characters 4-124
-        Called from Odoc_loader.read_cmt in file "src/loader/odoc_loader.ml", line 181, characters 12-71
-        Called from Odoc_loader.wrap_errors.(fun) in file "src/loader/odoc_loader.ml", line 248, characters 10-14
-        Called from Odoc_model__Error.catch in file "src/model/error.ml", line 54, characters 21-27
-        Called from Odoc_model__Error.catch_warnings.(fun) in file "src/model/error.ml", line 89, characters 18-22
-        Called from Odoc_model__Error.with_ref in file "src/model/error.ml", line 67, characters 12-16
-        Re-raised at Odoc_model__Error.with_ref in file "src/model/error.ml", line 72, characters 4-11
-        Called from Odoc_odoc__Compile.resolve_and_substitute in file "src/odoc/compile.ml", line 133, characters 8-76
-        Called from Odoc_model__Error.catch in file "src/model/error.ml", line 54, characters 21-27
-        Called from Odoc_model__Error.catch_warnings.(fun) in file "src/model/error.ml", line 89, characters 18-22
-        Called from Odoc_model__Error.with_ref in file "src/model/error.ml", line 67, characters 12-16
-        Re-raised at Odoc_model__Error.with_ref in file "src/model/error.ml", line 72, characters 4-11
-        Called from Odoc_odoc__Compile.compile.(fun) in file "src/odoc/compile.ml", line 354, characters 6-216
-        Called from Cmdliner_term.app.(fun) in file "cmdliner_term.ml", line 24, characters 19-24
-        Called from Cmdliner_term.app.(fun) in file "cmdliner_term.ml", line 22, characters 12-19
-        Called from Cmdliner_eval.run_parser in file "cmdliner_eval.ml", line 35, characters 37-44
-  [2]
+  $ odoc link test.odoc
+  $ odoc html-generate -o html test.odocl
+  $ odoc support-files -o html
 
+We should have an 'Optional' argument (as opposed to a 'RawOptional' one)
+
+  $ odoc_print -r f test.odocl
+  {
+    "id": { "`Value": [ { "`Root": [ "None", "Test" ] }, "f" ] },
+    "source_loc": "None",
+    "doc": { "elements": [], "suppress_warnings": "false" },
+    "type_": {
+      "Arrow": [
+        { "Some": { "Optional": "optional" } },
+        { "Constr": [ { "`Resolved": { "`CoreType": "int" } }, [] ] },
+        {
+          "Arrow": [
+            "None",
+            { "Constr": [ { "`Resolved": { "`CoreType": "unit" } }, [] ] },
+            { "Var": "a" }
+          ]
+        }
+      ]
+    },
+    "value": "Abstract"
+  }