Format long signature

src/document/ML.ml

@@ -4,7 +4,7 @@ open O.Infix
 
 module ML = Generator.Make (struct
   module Obj = struct
-    let close_tag_closed = ">"
+    let close_tag_closed = " >"
 
     let close_tag_extendable = ".. >"
 
@@ -18,11 +18,11 @@ module ML = Generator.Make (struct
   module Type = struct
     let annotation_separator = " : "
 
-    let handle_params name args = O.span (args ++ O.txt " " ++ name)
+    let handle_params name args = O.span (args ++ O.sp ++ name)
 
     let handle_constructor_params = handle_params
 
-    let handle_substitution_params = handle_params
+    let handle_substitution_params name args = O.span (args ++ O.txt " " ++ name)
 
     let handle_format_params p = p
 
@@ -37,7 +37,7 @@ module ML = Generator.Make (struct
     end
 
     module Tuple = struct
-      let element_separator = " * "
+      let element_separator = O.sp ++ O.txt "* "
 
       let always_parenthesize = false
     end

src/document/codefmt.ml

@@ -3,23 +3,36 @@ open Types
 type out = Source.t
 
 module State = struct
-  type t = { context : (out * Source.tag) Stack.t; mutable current : out }
+  type t = {
+    context : (out * Source.tag) Stack.t;
+    mutable current : out;
+    mutable ignore_all : int;
+  }
 
-  let create () = { context = Stack.create (); current = [] }
+  let create () = { context = Stack.create (); current = []; ignore_all = 0 }
 
-  let push state elt = state.current <- elt :: state.current
+  let push state elt =
+    if state.ignore_all = 0 then state.current <- elt :: state.current
+
+  let push_ignore state = state.ignore_all <- state.ignore_all + 1
+
+  let pop_ignore state =
+    state.ignore_all <-
+      (if state.ignore_all > 0 then state.ignore_all - 1 else 0)
 
   let enter state tag =
-    let previous_elt = state.current in
-    Stack.push (previous_elt, tag) state.context;
-    state.current <- [];
-    ()
+    if state.ignore_all = 0 then (
+      let previous_elt = state.current in
+      Stack.push (previous_elt, tag) state.context;
+      state.current <- [];
+      ())
 
   let leave state =
-    let current_elt = List.rev state.current in
-    let previous_elt, tag = Stack.pop state.context in
-    state.current <- Tag (tag, current_elt) :: previous_elt;
-    ()
+    if state.ignore_all = 0 then (
+      let current_elt = List.rev state.current in
+      let previous_elt, tag = Stack.pop state.context in
+      state.current <- Tag (tag, current_elt) :: previous_elt;
+      ())
 
   let rec flush state =
     if Stack.is_empty state.context then List.rev state.current
@@ -36,6 +49,7 @@ module Tag = struct
   type Format.stag +=
     | Elt of Inline.t
     | Tag of Source.tag
+    | Ignore
 
   let setup_tags formatter state0 =
     let stag_functions =
@@ -44,11 +58,13 @@ module Tag = struct
         | Tag tag -> State.enter state0 tag; ""
         | Format.String_tag "" -> State.enter state0 None; ""
         | Format.String_tag tag -> State.enter state0 (Some tag); ""
+        | Ignore -> State.push_ignore state0; ""
         | _ -> ""
       and mark_close_stag = function
         | Elt _ -> ""
         | Tag _
         | Format.String_tag _ -> State.leave state0; ""
+        | Ignore -> State.pop_ignore state0; ""
         | _ -> ""
       in {Format.
         print_open_stag = (fun _ -> ());
@@ -62,8 +78,13 @@ module Tag = struct
 
   let elt ppf elt =
     Format.pp_open_stag ppf (Elt elt);
+    Format.pp_print_as ppf (Utils.compute_length_inline elt) "";
     Format.pp_close_stag ppf ()
 
+  let ignore ppf txt =
+    Format.pp_open_stag ppf Ignore;
+    Format.fprintf ppf "%t" txt;
+    Format.pp_close_stag ppf ()
 end
 *)
 
@@ -73,15 +94,19 @@ module Tag = struct
   let setup_tags formatter state0 =
     let tag_functions =
       let get_tag s =
-        let prefix_tag = "tag:" in
+        let prefix_tag = "tag:" and prefix_ignore = "ignore-tag" in
         let l = String.length prefix_tag in
         if String.length s > l && String.sub s 0 l = prefix_tag then
           let elt : Inline.t = Marshal.from_string s l in
           `Elt elt
+        else if s = prefix_ignore then `Ignore
         else `String s
       in
       let mark_open_tag s =
         match get_tag s with
+        | `Ignore ->
+            State.push_ignore state0;
+            ""
         | `Elt elt ->
             State.push state0 (Elt elt);
             ""
@@ -93,6 +118,9 @@ module Tag = struct
             ""
       and mark_close_tag s =
         match get_tag s with
+        | `Ignore ->
+            State.pop_ignore state0;
+            ""
         | `Elt _ -> ""
         | `String _ ->
             State.leave state0;
@@ -110,15 +138,20 @@ module Tag = struct
     ()
 
   let elt ppf (elt : Inline.t) =
-    Format.fprintf ppf "@{<tag:%s>@}" (Marshal.to_string elt [])
+    Format.fprintf ppf "@{<tag:%s>%t@}" (Marshal.to_string elt []) (fun fmt ->
+        Format.pp_print_as fmt (Utils.compute_length_inline elt) "")
+
+  let ignore ppf txt = Format.fprintf ppf "@{<ignore-tag>%t@}" txt
 end
 [@@alert "-deprecated--deprecated"]
 
+type t = Format.formatter -> unit
+
 let make () =
   let open Inline in
   let state0 = State.create () in
   let push elt = State.push state0 (Elt elt) in
-  let push_text s = push [ inline @@ Text s ] in
+  let push_text s = if state0.ignore_all = 0 then push [ inline @@ Text s ] in
 
   let formatter =
     let out_string s i j = push_text (String.sub s i j) in
@@ -137,6 +170,7 @@ let make () =
    * in
    * let formatter = Format.formatter_of_out_functions out_functions in *)
   Tag.setup_tags formatter state0;
+  Format.pp_set_margin formatter 80;
   ( (fun () ->
       Format.pp_print_flush formatter ();
       State.flush state0),
@@ -148,11 +182,11 @@ let spf fmt =
 
 let pf = Format.fprintf
 
-(** Transitory hackish API *)
+let elt t ppf = Tag.elt ppf t
 
-let elt = Tag.elt
+let entity e ppf = elt [ inline @@ Inline.Entity e ] ppf
 
-let entity e ppf = elt ppf [ inline @@ Inline.Entity e ]
+let ignore t ppf = Tag.ignore ppf t
 
 let ( ++ ) f g ppf =
   f ppf;
@@ -170,8 +204,6 @@ let cut = break 0 0
 
 let sp = break 1 0
 
-let ( ! ) (pp : _ Fmt.t) x ppf = pp ppf x
-
 let rec list ?sep ~f = function
   | [] -> noop
   | [ x ] -> f x
@@ -180,7 +212,11 @@ let rec list ?sep ~f = function
       let tl = list ?sep ~f xs in
       match sep with None -> hd ++ tl | Some sep -> hd ++ sep ++ tl)
 
-let render f = spf "@[%t@]" (span f)
+let box_hv t ppf = pf ppf "@[<hv 2>%t@]" t
+
+let box_hv_no_indent t ppf = pf ppf "@[<hv 0>%t@]" t
+
+let render f = spf "@[<hv 2>%t@]" (span f)
 
 let code ?attr f = [ inline ?attr @@ Inline.Source (render f) ]
 
@@ -191,7 +227,5 @@ let codeblock ?attr f = [ block ?attr @@ Block.Source (render f) ]
 let keyword keyword ppf = pf ppf "@{<keyword>%s@}" keyword
 
 module Infix = struct
-  let ( ! ) = ( ! )
-
   let ( ++ ) = ( ++ )
 end

src/document/codefmt.mli

@@ -0,0 +1,39 @@
+open Types
+
+type t
+
+val elt : Inline.t -> t
+
+val entity : Inline.entity -> t
+
+val ignore : t -> t
+
+val span : ?attr:string -> t -> t
+
+val txt : string -> t
+
+val noop : t
+
+val cut : t
+
+val sp : t
+
+val list : ?sep:t -> f:('a -> t) -> 'a list -> t
+
+val box_hv : t -> t
+
+val box_hv_no_indent : t -> t
+
+val render : t -> Source.t
+
+val code : ?attr:string list -> t -> Inline.t
+
+val documentedSrc : t -> DocumentedSrc.t
+
+val codeblock : ?attr:Class.t -> t -> Block.t
+
+val keyword : string -> t
+
+module Infix : sig
+  val ( ++ ) : t -> t -> t
+end

src/document/dune

@@ -3,4 +3,4 @@
  (public_name odoc.document)
  (instrumentation
   (backend bisect_ppx))
- (libraries odoc_model fmt fpath))
+ (libraries odoc_model fpath))