(***********************************************************************)
(*                             OCamldoc                                *)
(*                                                                     *)
(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)



let input_file_as_string nom =
  let chanin = open_in_bin nom in
  let len = 1024 in
  let s = String.create len in
  let buf = Buffer.create len in
  let rec iter () =
    try
      let n = input chanin s 0 len in
      if n = 0 then
        ()
      else
        (
         Buffer.add_substring buf s 0 n;
         iter ()
        )
    with
      End_of_file -> ()
  in
  iter ();
  close_in chanin;
  Buffer.contents buf

let string_of_longident li = String.concat "." (Longident.flatten li)

let string_of_type_expr t =
  Printtyp.mark_loops t;
  Printtyp.type_scheme_max ~b_reset_names: false Format.str_formatter t;
  let s = Format.flush_str_formatter () in
  s

let string_of_type_list sep type_list =
  let rec need_parent t =
    match t.Types.desc with
      Types.Tarrow _ | Types.Ttuple _ -> true
    | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
    | Types.Tconstr _ ->
        false
    | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
    | Types.Tfield _ | Types.Tnil | Types.Tvariant _ -> false
  in
  let print_one_type t =
    Printtyp.mark_loops t;
    if need_parent t then
      ( 
       Format.fprintf Format.str_formatter "(" ;
       Printtyp.type_scheme_max ~b_reset_names: false Format.str_formatter t;
       Format.fprintf Format.str_formatter ")"
      )
    else
      Printtyp.type_scheme_max ~b_reset_names: false Format.str_formatter t
  in
  begin match type_list with
    [] -> ()
  | [ty] -> print_one_type ty
  | ty :: tyl ->
      Format.fprintf Format.str_formatter "@[<hov 2>";
      print_one_type ty;
      List.iter
        (fun t -> Format.fprintf Format.str_formatter "@,%s" sep; print_one_type t)
        tyl;
      Format.fprintf Format.str_formatter "@]"
  end;
  Format.flush_str_formatter()

(** Return the given module type where methods and vals have been removed
   from the signatures. Used when we don't want to print a too long module type.*)
let simpl_module_type t =
  let rec iter t =
    match t with
      Types.Tmty_ident p -> t
    | Types.Tmty_signature _ -> Types.Tmty_signature []
    | Types.Tmty_functor (id, mt1, mt2) ->
        Types.Tmty_functor (id, iter mt1, iter mt2)
  in
  iter t

let string_of_module_type ?(complete=false) t =
  let t2 = if complete then t else simpl_module_type t in
  Printtyp.modtype Format.str_formatter t2;
  let s = Format.flush_str_formatter () in
  s


(** Return the given class type where methods and vals have been removed
   from the signatures. Used when we don't want to print a too long class type.*)
let simpl_class_type t =
  let rec iter t =
    match t with
      Types.Tcty_constr (p,texp_list,ct) -> t
    | Types.Tcty_signature cs ->
        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
           quand on affichera le type *)
        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
        Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with 
                                                  Types.desc = Types.Tobject (tnil, ref None) };
                               Types.cty_vars = Types.Vars.empty ;
                               Types.cty_concr = Types.Concr.empty ;
                             }
    | Types.Tcty_fun (l, texp, ct) ->
        let new_ct = iter ct in
        Types.Tcty_fun (l, texp, new_ct)
  in
  iter t

let string_of_class_type ?(complete=false) t = 
  let t2 = if complete then t else simpl_class_type t in
  (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *)
  Printtyp.class_type Format.str_formatter t2;
  let s = Format.flush_str_formatter () in
  s

let get_fields type_expr =
  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in
  List.fold_left
    (fun acc -> fun (label, field_kind, typ) ->
      match field_kind with
        Types.Fabsent ->
          acc
      | _ ->
          if label = "*dummy method*" then
            acc
          else
            acc @ [label, typ]
    )
    []
    fields

let rec string_of_text t =
  let rec iter t_ele = 
    match t_ele with
      | Odoc_types.Raw s
      | Odoc_types.Code s
      | Odoc_types.CodePre s
      | Odoc_types.Verbatim s -> s
      | Odoc_types.Bold t 
      | Odoc_types.Italic t
      | Odoc_types.Center t
      | Odoc_types.Left t
      | Odoc_types.Right t
      | Odoc_types.Emphasize t -> string_of_text t
      | Odoc_types.List l ->
          (String.concat ""
             (List.map (fun t -> "\n- "^(string_of_text t)) l))^
          "\n"
      | Odoc_types.Enum l ->
          let rec f n = function
              [] -> "\n"
            | t :: q ->
                "\n"^(string_of_int n)^". "^(string_of_text t)^
                (f (n + 1) q)
          in
          f 1 l
      | Odoc_types.Newline -> "\n"
      | Odoc_types.Block t -> "\t"^(string_of_text t)^"\n"
      | Odoc_types.Title (_, _, t) -> "\n"^(string_of_text t)^"\n"
      | Odoc_types.Latex s -> "{% "^s^" %}"
      | Odoc_types.Link (s, t) ->
          "["^s^"]"^(string_of_text t)
      | Odoc_types.Ref (name, _) ->
          iter (Odoc_types.Code name)
      | Odoc_types.Superscript t ->
          "^{"^(string_of_text t)^"}"
      | Odoc_types.Subscript t ->
          "^{"^(string_of_text t)^"}"
  in
  String.concat "" (List.map iter t)

let string_of_author_list l =
  match l with
    [] ->
      ""
  | _ ->
      "* "^Odoc_messages.authors^":\n"^
      (String.concat ", " l)^
      "\n"

let string_of_version_opt v_opt =
  match v_opt with
    None -> ""
  | Some v -> Odoc_messages.version^": "^v^"\n"

let string_of_since_opt s_opt =
  match s_opt with
    None -> ""
  | Some s -> Odoc_messages.since^" "^s^"\n"

let string_of_raised_exceptions l =
  match l with
    [] -> ""
  | (s, t) :: [] -> Odoc_messages.raises^" "^s^" "^(string_of_text t)^"\n"
  | _ ->
      Odoc_messages.raises^"\n"^
      (String.concat ""
         (List.map
            (fun (ex, desc) -> "- "^ex^" "^(string_of_text desc)^"\n")
            l
         )
      )^"\n"

let string_of_see (see_ref, t) =
  let t_ref = 
    match see_ref with
      Odoc_types.See_url s -> [ Odoc_types.Link (s, t) ]
    | Odoc_types.See_file s -> (Odoc_types.Code s) :: (Odoc_types.Raw " ") :: t
    | Odoc_types.See_doc s -> (Odoc_types.Italic [Odoc_types.Raw s]) :: (Odoc_types.Raw " ") :: t
  in
  string_of_text t_ref

let string_of_sees l =
  match l with
    [] -> ""
  | see :: [] -> Odoc_messages.see_also^" "^(string_of_see see)^" \n"
  | _ ->
      Odoc_messages.see_also^"\n"^
      (String.concat ""
         (List.map
            (fun see -> "- "^(string_of_see see)^"\n")
            l
         )
      )^"\n"

let string_of_return_opt return_opt =
  match return_opt with
    None -> ""
  | Some s -> Odoc_messages.returns^" "^(string_of_text s)^"\n"

let string_of_info i =
  let module M = Odoc_types in
  (match i.M.i_deprecated with
    None -> ""
  | Some d -> Odoc_messages.deprecated^"! "^(string_of_text d)^"\n")^
  (match i.M.i_desc with
    None -> "" 
  | Some d when d = [Odoc_types.Raw ""] -> ""
  | Some d -> (string_of_text d)^"\n"
  )^
  (string_of_author_list i.M.i_authors)^
  (string_of_version_opt i.M.i_version)^
  (string_of_since_opt i.M.i_since)^
  (string_of_raised_exceptions i.M.i_raised_exceptions)^
  (string_of_return_opt i.M.i_return_value)

let apply_opt f v_opt =
  match v_opt with
    None -> None
  | Some v -> Some (f v)

let string_of_date ?(hour=true) d = 
  let add_0 s = if String.length s < 2 then "0"^s else s in
  let t = Unix.localtime d in
  (string_of_int (t.Unix.tm_year + 1900))^"-"^
  (add_0 (string_of_int (t.Unix.tm_mon + 1)))^"-"^
  (add_0 (string_of_int t.Unix.tm_mday))^
  (
   if hour then 
     " "^
     (add_0 (string_of_int t.Unix.tm_hour))^":"^
     (add_0 (string_of_int t.Unix.tm_min))
   else
     ""
  )


let rec text_list_concat sep l =
  match l with
    [] -> []
  | [t] -> t
  | t :: q ->
      t @ (sep :: (text_list_concat sep q))

let rec text_no_title_no_list t =
  let rec iter t_ele = 
    match t_ele with
    | Odoc_types.Title (_,_,t) -> text_no_title_no_list t
    | Odoc_types.List l
    | Odoc_types.Enum l -> 
        (Odoc_types.Raw " ") ::
        (text_list_concat
           (Odoc_types.Raw ", ") 
           (List.map text_no_title_no_list l))
    | Odoc_types.Raw _
    | Odoc_types.Code _
    | Odoc_types.CodePre _
    | Odoc_types.Verbatim _
    | Odoc_types.Ref _ -> [t_ele]
    | Odoc_types.Newline ->  [Odoc_types.Newline]
    | Odoc_types.Block t -> [Odoc_types.Block (text_no_title_no_list t)]
    | Odoc_types.Bold t -> [Odoc_types.Bold (text_no_title_no_list t)]
    | Odoc_types.Italic t -> [Odoc_types.Italic (text_no_title_no_list t)]
    | Odoc_types.Center t -> [Odoc_types.Center (text_no_title_no_list t)]
    | Odoc_types.Left t -> [Odoc_types.Left (text_no_title_no_list t)]
    | Odoc_types.Right t -> [Odoc_types.Right (text_no_title_no_list t)]
    | Odoc_types.Emphasize t -> [Odoc_types.Emphasize (text_no_title_no_list t)]
    | Odoc_types.Latex s -> [Odoc_types.Latex s]
    | Odoc_types.Link (s, t) -> [Odoc_types.Link (s, (text_no_title_no_list t))]
    | Odoc_types.Superscript t -> [Odoc_types.Superscript (text_no_title_no_list t)]
    | Odoc_types.Subscript t -> [Odoc_types.Subscript (text_no_title_no_list t)]
  in
  List.flatten (List.map iter t)

let get_titles_in_text t =
  let l = ref [] in
  let rec iter_ele ele =
    match ele with
    | Odoc_types.Title (n,lopt,t) -> l := (n,lopt,t) :: !l
    | Odoc_types.List l
    | Odoc_types.Enum l -> List.iter iter_text l        
    | Odoc_types.Raw _
    | Odoc_types.Code _
    | Odoc_types.CodePre _
    | Odoc_types.Verbatim _
    | Odoc_types.Ref _ -> ()
    | Odoc_types.Newline ->  ()
    | Odoc_types.Block t
    | Odoc_types.Bold t
    | Odoc_types.Italic t
    | Odoc_types.Center t
    | Odoc_types.Left t
    | Odoc_types.Right t
    | Odoc_types.Emphasize t -> iter_text t
    | Odoc_types.Latex s -> ()
    | Odoc_types.Link (_, t)
    | Odoc_types.Superscript t 
    | Odoc_types.Subscript t  -> iter_text t
  and iter_text te = 
    List.iter iter_ele te
  in
  iter_text t;
  List.rev !l


(*********************************************************)
let rec get_before_dot s =
  try
    let len = String.length s in
    let n = String.index s '.' in
    if n + 1 >= len then
      (* le point est le dernier caractère *)
      (true, s, "")
    else
      match s.[n+1] with
        ' ' | '\n' | '\r' | '\t' ->
          (true, String.sub s 0 (n+1),
           String.sub s (n+1) (len - n - 1))
      | _ ->
          let b, s2, s_after = get_before_dot (String.sub s (n + 1) (len - n - 1)) in
          (b, (String.sub s 0 (n+1))^s2, s_after)
  with
    Not_found -> (false, s, "")

let rec first_sentence_text t =
  match t with
    [] -> (false, [], [])
  | ele :: q ->
      let (stop, ele2, ele3_opt) = first_sentence_text_ele ele in
      if stop then 
        (stop, [ele2], 
         match ele3_opt with None -> q | Some e -> e :: q)
      else
        let (stop2, q2, rest) = first_sentence_text q in
        (stop2, ele2 :: q2, rest)


and first_sentence_text_ele text_ele =
  match text_ele with
  | Odoc_types.Raw s -> 
      let b, s2, s_after = get_before_dot s in
      (b, Odoc_types.Raw s2, Some (Odoc_types.Raw s_after))
  | Odoc_types.Code _ 
  | Odoc_types.CodePre _ 
  | Odoc_types.Verbatim _ -> (false, text_ele, None)
  | Odoc_types.Bold t ->
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Bold t2, Some (Odoc_types.Bold t3))
  | Odoc_types.Italic t ->
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Italic t2, Some (Odoc_types.Italic t3))
  | Odoc_types.Center t ->
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Center t2, Some (Odoc_types.Center t3))
  | Odoc_types.Left t ->
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Left t2, Some (Odoc_types.Left t3))
  | Odoc_types.Right t ->
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Right t2, Some (Odoc_types.Right t3))
  | Odoc_types.Emphasize t ->
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Emphasize t2, Some (Odoc_types.Emphasize t3))
  | Odoc_types.Block t -> 
      let (b, t2, t3) = first_sentence_text t in
      (b, Odoc_types.Block t2, Some (Odoc_types.Block t3))
  | Odoc_types.Title (n, l_opt, t) ->
      let (b, t2, t3) = first_sentence_text t in
      (b, 
       Odoc_types.Title (n, l_opt, t2), 
       Some (Odoc_types.Title (n, l_opt, t3)))
  | Odoc_types.Newline ->
      (true, Odoc_types.Raw "", Some Odoc_types.Newline)
  | Odoc_types.List _
  | Odoc_types.Enum _
  | Odoc_types.Latex _
  | Odoc_types.Link _ 
  | Odoc_types.Ref _ 
  | Odoc_types.Superscript _ 
  | Odoc_types.Subscript _ -> (false, text_ele, None)


let first_sentence_of_text t = 
  let (_,t2,_) = first_sentence_text t in 
  t2

let first_sentence_and_rest_of_text t =
  let (_,t1, t2) = first_sentence_text t in
  (t1, t2)

(*********************************************************)

let create_index_lists elements string_of_ele =
  let rec f current acc0 acc1 acc2 = function
      [] -> (acc0 :: acc1) @ [acc2]
    | ele :: q ->
        let s = string_of_ele ele in
        match s with
          "" -> f current acc0 acc1 (acc2 @ [ele]) q
        | _ ->
            let first = Char.uppercase s.[0] in
            match first with
              'A' .. 'Z' ->
                if current = first then
                  f current acc0 acc1 (acc2 @ [ele]) q
                else
                  f first acc0 (acc1 @ [acc2]) [ele] q
            | _ ->
                f current (acc0 @ [ele]) acc1 acc2 q
  in
  f '_' [] [] [] elements


(*** for labels *)

let is_optional = Btype.is_optional
let label_name = Btype.label_name

let remove_option typ =
  let rec iter t =
    match t with
    | Types.Tconstr (p,tlist,_) ->
        (
         match p with
           Path.Pident id when Ident.name id = "option" ->
             (
              match tlist with
                [t2] -> t2.Types.desc
              | _ -> t
             )
         | _ -> t
        )
    | Types.Tvar
    | Types.Tunivar
    | Types.Tpoly _
    | Types.Tarrow _ 
    | Types.Ttuple _ 
    | Types.Tobject _
    | Types.Tfield _
    | Types.Tnil 
    | Types.Tvariant _ -> t
    | Types.Tlink t2
    | Types.Tsubst t2 -> iter t2.Types.desc
  in
  { typ with Types.desc = iter typ.Types.desc }
