ocamldoc/odoc_misc.ml

   1 (***********************************************************************)
   2 (*                             OCamldoc                                *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13
  14 let no_blanks s =
  15   let len = String.length s in
  16   let buf = Buffer.create len in
  17   for i = 0 to len - 1 do
  18     match s.[i] with
  19       ' ' | '\n' | '\t' | '\r' -> ()
  20     | c -> Buffer.add_char buf c
  21   done;
  22   Buffer.contents buf
  23
  24 let input_file_as_string nom =
  25   let chanin = open_in_bin nom in
  26   let len = 1024 in
  27   let s = String.create len in
  28   let buf = Buffer.create len in
  29   let rec iter () =
  30     try
  31       let n = input chanin s 0 len in
  32       if n = 0 then
  33         ()
  34       else
  35         (
  36          Buffer.add_substring buf s 0 n;
  37          iter ()
  38         )
  39     with
  40       End_of_file -> ()
  41   in
  42   iter ();
  43   close_in chanin;
  44   Buffer.contents buf
  45
  46 let split_string s chars =
  47   let len = String.length s in
  48   let rec iter acc pos =
  49     if pos >= len then
  50       match acc with
  51         "" -> []
  52       | _ -> [acc]
  53     else
  54       if List.mem s.[pos] chars then
  55         match acc with
  56           "" -> iter "" (pos + 1)
  57         | _ -> acc :: (iter "" (pos + 1))
  58       else
  59         iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
  60   in
  61   iter "" 0
  62
  63 let split_with_blanks s = split_string s [' ' ; '\n' ; '\r' ; '\t' ]
  64
  65 let list_concat sep =
  66   let rec iter = function
  67       [] -> []
  68     | [h] -> [h]
  69     | h :: q -> h :: sep :: q
  70   in
  71   iter
  72
  73 let rec string_of_longident li =
  74   match li with
  75   | Longident.Lident s -> s
  76   | Longident.Ldot(li, s) -> string_of_longident li ^ "." ^ s
  77   | Longident.Lapply(l1, l2) ->
  78       string_of_longident l1 ^ "(" ^ string_of_longident l2 ^ ")"
  79
  80 let get_fields type_expr =
  81   let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in
  82   List.fold_left
  83     (fun acc -> fun (label, field_kind, typ) ->
  84       match field_kind with
  85         Types.Fabsent ->
  86           acc
  87       | _ ->
  88           if label = "*dummy method*" then
  89             acc
  90           else
  91             acc @ [label, typ]
  92     )
  93     []
  94     fields
  95
  96 let rec string_of_text t =
  97   let rec iter t_ele =
  98     match t_ele with
  99       | Odoc_types.Raw s
 100       | Odoc_types.Code s
 101       | Odoc_types.CodePre s
 102       | Odoc_types.Verbatim s -> s
 103       | Odoc_types.Bold t
 104       | Odoc_types.Italic t
 105       | Odoc_types.Center t
 106       | Odoc_types.Left t
 107       | Odoc_types.Right t
 108       | Odoc_types.Emphasize t -> string_of_text t
 109       | Odoc_types.List l ->
 110           (String.concat ""
 111              (List.map (fun t -> "\n- "^(string_of_text t)) l))^
 112           "\n"
 113       | Odoc_types.Enum l ->
 114           let rec f n = function
 115               [] -> "\n"
 116             | t :: q ->
 117                 "\n"^(string_of_int n)^". "^(string_of_text t)^
 118                 (f (n + 1) q)
 119           in
 120           f 1 l
 121       | Odoc_types.Newline -> "\n"
 122       | Odoc_types.Block t -> "\t"^(string_of_text t)^"\n"
 123       | Odoc_types.Title (_, _, t) -> "\n"^(string_of_text t)^"\n"
 124       | Odoc_types.Latex s -> "{% "^s^" %}"
 125       | Odoc_types.Link (s, t) ->
 126           "["^s^"]"^(string_of_text t)
 127       | Odoc_types.Ref (name, _) ->
 128           iter (Odoc_types.Code name)
 129       | Odoc_types.Superscript t ->
 130           "^{"^(string_of_text t)^"}"
 131       | Odoc_types.Subscript t ->
 132           "^{"^(string_of_text t)^"}"
 133       | Odoc_types.Module_list l ->
 134           string_of_text
 135             (list_concat (Odoc_types.Raw ", ")
 136                (List.map (fun s -> Odoc_types.Code s) l)
 137             )
 138       | Odoc_types.Index_list ->
 139           ""
 140       | Odoc_types.Custom (_, t) -> string_of_text t
 141   in
 142   String.concat "" (List.map iter t)
 143
 144 let string_of_author_list l =
 145   match l with
 146     [] ->
 147       ""
 148   | _ ->
 149       "* "^Odoc_messages.authors^":\n"^
 150       (String.concat ", " l)^
 151       "\n"
 152
 153 let string_of_version_opt v_opt =
 154   match v_opt with
 155     None -> ""
 156   | Some v -> Odoc_messages.version^": "^v^"\n"
 157
 158 let string_of_since_opt s_opt =
 159   match s_opt with
 160     None -> ""
 161   | Some s -> Odoc_messages.since^" "^s^"\n"
 162
 163 let string_of_raised_exceptions l =
 164   match l with
 165     [] -> ""
 166   | (s, t) :: [] -> Odoc_messages.raises^" "^s^" "^(string_of_text t)^"\n"
 167   | _ ->
 168       Odoc_messages.raises^"\n"^
 169       (String.concat ""
 170          (List.map
 171             (fun (ex, desc) -> "- "^ex^" "^(string_of_text desc)^"\n")
 172             l
 173          )
 174       )^"\n"
 175
 176 let string_of_see (see_ref, t) =
 177   let t_ref =
 178     match see_ref with
 179       Odoc_types.See_url s -> [ Odoc_types.Link (s, t) ]
 180     | Odoc_types.See_file s -> (Odoc_types.Code s) :: (Odoc_types.Raw " ") :: t
 181     | Odoc_types.See_doc s -> (Odoc_types.Italic [Odoc_types.Raw s]) :: (Odoc_types.Raw " ") :: t
 182   in
 183   string_of_text t_ref
 184
 185 let string_of_sees l =
 186   match l with
 187     [] -> ""
 188   | see :: [] -> Odoc_messages.see_also^" "^(string_of_see see)^" \n"
 189   | _ ->
 190       Odoc_messages.see_also^"\n"^
 191       (String.concat ""
 192          (List.map
 193             (fun see -> "- "^(string_of_see see)^"\n")
 194             l
 195          )
 196       )^"\n"
 197
 198 let string_of_return_opt return_opt =
 199   match return_opt with
 200     None -> ""
 201   | Some s -> Odoc_messages.returns^" "^(string_of_text s)^"\n"
 202
 203 let string_of_info i =
 204   let module M = Odoc_types in
 205   (match i.M.i_deprecated with
 206     None -> ""
 207   | Some d -> Odoc_messages.deprecated^"! "^(string_of_text d)^"\n")^
 208   (match i.M.i_desc with
 209     None -> ""
 210   | Some d when d = [Odoc_types.Raw ""] -> ""
 211   | Some d -> (string_of_text d)^"\n"
 212   )^
 213   (string_of_author_list i.M.i_authors)^
 214   (string_of_version_opt i.M.i_version)^
 215   (string_of_since_opt i.M.i_since)^
 216   (string_of_raised_exceptions i.M.i_raised_exceptions)^
 217   (string_of_return_opt i.M.i_return_value)
 218
 219 let apply_opt f v_opt =
 220   match v_opt with
 221     None -> None
 222   | Some v -> Some (f v)
 223
 224 let string_of_date ?(hour=true) d =
 225   let add_0 s = if String.length s < 2 then "0"^s else s in
 226   let t = Unix.localtime d in
 227   (string_of_int (t.Unix.tm_year + 1900))^"-"^
 228   (add_0 (string_of_int (t.Unix.tm_mon + 1)))^"-"^
 229   (add_0 (string_of_int t.Unix.tm_mday))^
 230   (
 231    if hour then
 232      " "^
 233      (add_0 (string_of_int t.Unix.tm_hour))^":"^
 234      (add_0 (string_of_int t.Unix.tm_min))
 235    else
 236      ""
 237   )
 238
 239
 240 let rec text_list_concat sep l =
 241   match l with
 242     [] -> []
 243   | [t] -> t
 244   | t :: q ->
 245       t @ (sep :: (text_list_concat sep q))
 246
 247 let rec text_no_title_no_list t =
 248   let rec iter t_ele =
 249     match t_ele with
 250     | Odoc_types.Title (_,_,t) -> text_no_title_no_list t
 251     | Odoc_types.List l
 252     | Odoc_types.Enum l ->
 253         (Odoc_types.Raw " ") ::
 254         (text_list_concat
 255            (Odoc_types.Raw ", ")
 256            (List.map text_no_title_no_list l))
 257     | Odoc_types.Raw _
 258     | Odoc_types.Code _
 259     | Odoc_types.CodePre _
 260     | Odoc_types.Verbatim _
 261     | Odoc_types.Ref _ -> [t_ele]
 262     | Odoc_types.Newline ->  [Odoc_types.Newline]
 263     | Odoc_types.Block t -> [Odoc_types.Block (text_no_title_no_list t)]
 264     | Odoc_types.Bold t -> [Odoc_types.Bold (text_no_title_no_list t)]
 265     | Odoc_types.Italic t -> [Odoc_types.Italic (text_no_title_no_list t)]
 266     | Odoc_types.Center t -> [Odoc_types.Center (text_no_title_no_list t)]
 267     | Odoc_types.Left t -> [Odoc_types.Left (text_no_title_no_list t)]
 268     | Odoc_types.Right t -> [Odoc_types.Right (text_no_title_no_list t)]
 269     | Odoc_types.Emphasize t -> [Odoc_types.Emphasize (text_no_title_no_list t)]
 270     | Odoc_types.Latex s -> [Odoc_types.Latex s]
 271     | Odoc_types.Link (s, t) -> [Odoc_types.Link (s, (text_no_title_no_list t))]
 272     | Odoc_types.Superscript t -> [Odoc_types.Superscript (text_no_title_no_list t)]
 273     | Odoc_types.Subscript t -> [Odoc_types.Subscript (text_no_title_no_list t)]
 274     | Odoc_types.Module_list l ->
 275         list_concat (Odoc_types.Raw ", ")
 276           (List.map
 277              (fun s -> Odoc_types.Ref (s, Some Odoc_types.RK_module))
 278              l
 279           )
 280     | Odoc_types.Index_list -> []
 281     | Odoc_types.Custom (s,t) -> [Odoc_types.Custom (s, text_no_title_no_list t)]
 282   in
 283   List.flatten (List.map iter t)
 284
 285 let get_titles_in_text t =
 286   let l = ref [] in
 287   let rec iter_ele ele =
 288     match ele with
 289     | Odoc_types.Title (n,lopt,t) -> l := (n,lopt,t) :: !l
 290     | Odoc_types.List l
 291     | Odoc_types.Enum l -> List.iter iter_text l
 292     | Odoc_types.Raw _
 293     | Odoc_types.Code _
 294     | Odoc_types.CodePre _
 295     | Odoc_types.Verbatim _
 296     | Odoc_types.Ref _ -> ()
 297     | Odoc_types.Newline ->  ()
 298     | Odoc_types.Block t
 299     | Odoc_types.Bold t
 300     | Odoc_types.Italic t
 301     | Odoc_types.Center t
 302     | Odoc_types.Left t
 303     | Odoc_types.Right t
 304     | Odoc_types.Emphasize t -> iter_text t
 305     | Odoc_types.Latex s -> ()
 306     | Odoc_types.Link (_, t)
 307     | Odoc_types.Superscript t
 308     | Odoc_types.Subscript t  -> iter_text t
 309     | Odoc_types.Module_list _ -> ()
 310     | Odoc_types.Index_list -> ()
 311     | Odoc_types.Custom (_, t) -> iter_text t
 312   and iter_text te =
 313     List.iter iter_ele te
 314   in
 315   iter_text t;
 316   List.rev !l
 317
 318 let text_concat (sep : Odoc_types.text) l =
 319   let rec iter = function
 320       [] -> []
 321     | [last] -> last
 322     | h :: q -> h @ sep @ (iter q)
 323   in
 324   iter l
 325
 326 (*********************************************************)
 327 let rec get_before_dot s =
 328   try
 329     let len = String.length s in
 330     let n = String.index s '.' in
 331     if n + 1 >= len then
 332       (* le point est le dernier caractère *)
 333       (true, s, "")
 334     else
 335       match s.[n+1] with
 336         ' ' | '\n' | '\r' | '\t' ->
 337           (true, String.sub s 0 (n+1),
 338            String.sub s (n+1) (len - n - 1))
 339       | _ ->
 340           let b, s2, s_after = get_before_dot (String.sub s (n + 1) (len - n - 1)) in
 341           (b, (String.sub s 0 (n+1))^s2, s_after)
 342   with
 343     Not_found -> (false, s, "")
 344
 345 let rec first_sentence_text t =
 346   match t with
 347     [] -> (false, [], [])
 348   | ele :: q ->
 349       let (stop, ele2, ele3_opt) = first_sentence_text_ele ele in
 350       if stop then
 351         (stop, [ele2],
 352          match ele3_opt with None -> q | Some e -> e :: q)
 353       else
 354         let (stop2, q2, rest) = first_sentence_text q in
 355         (stop2, ele2 :: q2, rest)
 356
 357
 358 and first_sentence_text_ele text_ele =
 359   match text_ele with
 360   | Odoc_types.Raw s ->
 361       let b, s2, s_after = get_before_dot s in
 362       (b, Odoc_types.Raw s2, Some (Odoc_types.Raw s_after))
 363   | Odoc_types.Code _
 364   | Odoc_types.CodePre _
 365   | Odoc_types.Verbatim _ -> (false, text_ele, None)
 366   | Odoc_types.Bold t ->
 367       let (b, t2, t3) = first_sentence_text t in
 368       (b, Odoc_types.Bold t2, Some (Odoc_types.Bold t3))
 369   | Odoc_types.Italic t ->
 370       let (b, t2, t3) = first_sentence_text t in
 371       (b, Odoc_types.Italic t2, Some (Odoc_types.Italic t3))
 372   | Odoc_types.Center t ->
 373       let (b, t2, t3) = first_sentence_text t in
 374       (b, Odoc_types.Center t2, Some (Odoc_types.Center t3))
 375   | Odoc_types.Left t ->
 376       let (b, t2, t3) = first_sentence_text t in
 377       (b, Odoc_types.Left t2, Some (Odoc_types.Left t3))
 378   | Odoc_types.Right t ->
 379       let (b, t2, t3) = first_sentence_text t in
 380       (b, Odoc_types.Right t2, Some (Odoc_types.Right t3))
 381   | Odoc_types.Emphasize t ->
 382       let (b, t2, t3) = first_sentence_text t in
 383       (b, Odoc_types.Emphasize t2, Some (Odoc_types.Emphasize t3))
 384   | Odoc_types.Block t ->
 385       let (b, t2, t3) = first_sentence_text t in
 386       (b, Odoc_types.Block t2, Some (Odoc_types.Block t3))
 387   | Odoc_types.Title (n, l_opt, t) ->
 388       let (b, t2, t3) = first_sentence_text t in
 389       (b,
 390        Odoc_types.Title (n, l_opt, t2),
 391        Some (Odoc_types.Title (n, l_opt, t3)))
 392   | Odoc_types.Newline ->
 393       (true, Odoc_types.Raw "", Some Odoc_types.Newline)
 394   | Odoc_types.List _
 395   | Odoc_types.Enum _
 396   | Odoc_types.Latex _
 397   | Odoc_types.Link _
 398   | Odoc_types.Ref _
 399   | Odoc_types.Superscript _
 400   | Odoc_types.Subscript _
 401   | Odoc_types.Module_list _
 402   | Odoc_types.Index_list -> (false, text_ele, None)
 403   | Odoc_types.Custom _ -> (false, text_ele, None)
 404
 405 let first_sentence_of_text t =
 406   let (_,t2,_) = first_sentence_text t in
 407   t2
 408
 409 let first_sentence_and_rest_of_text t =
 410   let (_,t1, t2) = first_sentence_text t in
 411   (t1, t2)
 412
 413 let remove_ending_newline s =
 414   let len = String.length s in
 415   if len <= 0 then
 416     s
 417   else
 418     match s.[len-1] with
 419       '\n' -> String.sub s 0 (len-1)
 420     | _ -> s
 421
 422 let search_string_backward ~pat =
 423   let lenp = String.length pat in
 424   let rec iter s =
 425     let len = String.length s in
 426     match compare len lenp with
 427       -1 -> raise Not_found
 428     | 0 -> if pat = s then 0 else raise Not_found
 429     | _ ->
 430         let pos = len - lenp in
 431         let s2 = String.sub s pos lenp in
 432         if s2 = pat then
 433           pos
 434         else
 435           iter (String.sub s 0 pos)
 436   in
 437   fun ~s -> iter s
 438
 439
 440
 441 (*********************************************************)
 442
 443 let create_index_lists elements string_of_ele =
 444   let rec f current acc0 acc1 acc2 = function
 445       [] -> (acc0 :: acc1) @ [acc2]
 446     | ele :: q ->
 447         let s = string_of_ele ele in
 448         match s with
 449           "" -> f current acc0 acc1 (acc2 @ [ele]) q
 450         | _ ->
 451             let first = Char.uppercase s.[0] in
 452             match first with
 453               'A' .. 'Z' ->
 454                 if current = first then
 455                   f current acc0 acc1 (acc2 @ [ele]) q
 456                 else
 457                   f first acc0 (acc1 @ [acc2]) [ele] q
 458             | _ ->
 459                 f current (acc0 @ [ele]) acc1 acc2 q
 460   in
 461   f '_' [] [] [] elements
 462
 463
 464 (*** for labels *)
 465
 466 let is_optional = Btype.is_optional
 467 let label_name = Btype.label_name
 468
 469 let remove_option typ =
 470   let rec iter t =
 471     match t with
 472     | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
 473     | Types.Tconstr _
 474     | Types.Tvar
 475     | Types.Tunivar
 476     | Types.Tpoly _
 477     | Types.Tarrow _
 478     | Types.Ttuple _
 479     | Types.Tobject _
 480     | Types.Tfield _
 481     | Types.Tnil
 482     | Types.Tvariant _ -> t
 483     | Types.Tlink t2
 484     | Types.Tsubst t2 -> iter t2.Types.desc
 485   in
 486   { typ with Types.desc = iter typ.Types.desc }