(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*       Olivier Andrieu, base sur du code de Maxence Guesdon             *)
(*                                                                        *)
(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Generation of Texinfo documentation. *)

open Odoc_info
open Value
open Type
open Extension
open Exception
open Class
open Module

let esc_8bits = ref false

let info_section = ref "OCaml"

let info_entry = ref []

(** {1 Some small helper functions} *)

let puts_nl chan s =
  output_string chan s ;
  output_char chan '\n'
let puts chan s =
  output_string chan s
let nl chan =
  output_char chan '\n'

let is = function
  | None -> false
  | Some _ -> true

let pad_to n s =
  let len = String.length s in
  if len < n then s ^ String.make (n - len) ' ' else s

let indent nb_sp s =
  let c = ref 0 in
  let len = pred (String.length s) in
  for i = 0 to len do if s.[i] = '\n' then incr c done ;
  let s' = Bytes.make (succ len + (succ !c) * nb_sp ) ' ' in
  c := nb_sp ;
  for i = 0 to len do
    Bytes.set s' !c s.[i] ;
    if s.[i] = '\n' then c := !c + nb_sp ;
    incr c
  done ;
  Bytes.to_string s'

type subparts = [
  | `Module of Odoc_info.Module.t_module
  | `Module_type of Odoc_info.Module.t_module_type
  | `Class of Odoc_info.Class.t_class
  | `Class_type of Odoc_info.Class.t_class_type
  ]

type menu_data = [
  | subparts
  | `Blank
  | `Comment of string
  | `Texi of string
  | `Index of string
] list

let nothing = Verbatim ""

let module_subparts =
  let rec iter acc = function
    | [] -> List.rev acc
    (* skip aliases *)
    | Element_module { m_kind = Module_alias _ } :: n ->
        iter acc n
    | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n ->
        iter acc n
    (* keep modules, module types, classes and class types *)
    | Element_module m :: n ->
        iter (`Module m :: acc) n
    | Element_module_type mt :: n ->
        iter (`Module_type mt :: acc) n
    | Element_class c :: n ->
        iter (`Class c :: acc) n
    | Element_class_type ct :: n ->
        iter (`Class_type ct :: acc) n
    (* forget the rest *)
    | _ :: n -> iter acc n
  in
  iter []

type indices = [
  | `Type
  | `Extension
  | `Exception
  | `Value
  | `Class_att
  | `Method
  | `Class
  | `Class_type
  | `Module
  | `Module_type
]

let indices = function
  | `Type        -> "ty"
  | `Extension   -> "xt"
  | `Exception   -> "ex"
  | `Value       -> "va"
  | `Class_att   -> "ca"
  | `Method      -> "me"
  | `Class       -> "cl"
  | `Class_type  -> "ct"
  | `Module      -> "mo"
  | `Module_type -> "mt"

let indices_names = [
  "Types"           , "ty" ;
  "Extensions"      , "xt" ;
  "Exceptions"      , "ex" ;
  "Values"          , "va" ;
  "Class attributes", "ca" ;
  "Methods"         , "me" ;
  "Classes"         , "cl" ;
  "Class types"     , "ct" ;
  "Modules"         , "mo" ;
  "Module types"    , "mt" ; ]



(** Module for generating various Texinfo things (menus, xrefs, ...) *)
module Texi =
struct
  (** Associations of strings to substitute in Texinfo code. *)
  let subst_strings = [
    (Str.regexp "@", "@@") ;
    (Str.regexp "{", "@{") ;
    (Str.regexp "}", "@}") ;
    (Str.regexp "\\.\\.\\.", "@dots{}") ;
  ] @
    (if !esc_8bits
    then [
    (Str.regexp "\xE0", "@`a") ;
    (Str.regexp "\xE2", "@^a") ;
    (Str.regexp "\xE9", "@'e") ;
    (Str.regexp "\xE8", "@`e") ;
    (Str.regexp "\xEA", "@^e") ;
    (Str.regexp "\xEB", "@\"e") ;
    (Str.regexp "\xF7", "@,{c}") ;
    (Str.regexp "\xF4", "@^o") ;
    (Str.regexp "\xF6", "@\"o") ;
    (Str.regexp "\xEE", "@^i") ;
    (Str.regexp "\xEF", "@\"i") ;
    (Str.regexp "\xF9", "@`u") ;
    (Str.regexp "\xFB", "@^u") ;
    (Str.regexp "\xE6", "@ae{}" ) ;
    (Str.regexp "\xC6", "@AE{}" ) ;
    (Str.regexp "\xDF", "@ss{}" ) ;
    (Str.regexp "\xA9", "@copyright{}" ) ;
    ]
    else [])

  (** Escape the strings which would clash with Texinfo syntax. *)
  let escape s =
    List.fold_left
      (fun acc (p, r) -> Str.global_replace p r acc)
      s subst_strings

  (** Removes dots (no good for a node name). *)
  let fix_nodename s =
    Str.global_replace (Str.regexp "\\.") "/" (escape s)

  (** Generates a Texinfo menu. *)
  let generate_menu chan subpart_list =
    if subpart_list <> []
    then begin
      let menu_line part_qual name =
        let sname = Name.simple name in
        if sname = name
        then (
          puts chan (pad_to 35
                       ("* " ^ sname ^ ":: ")) ;
          puts_nl chan part_qual )
        else (
          puts chan (pad_to 35
                       ("* " ^ sname ^ ": " ^ (fix_nodename name) ^ ". " )) ;
          puts_nl chan part_qual )
      in
      puts_nl chan "@menu" ;
      List.iter
        (function
        | `Module { m_name = name } ->
            menu_line Odoc_messages.modul name
        | `Module_type { mt_name = name } ->
            menu_line Odoc_messages.module_type name
        | `Class { cl_name = name } ->
            menu_line Odoc_messages.clas name
        | `Class_type { clt_name = name } ->
            menu_line Odoc_messages.class_type name
        | `Blank -> nl chan
        | `Comment c -> puts_nl chan (escape c)
        | `Texi t -> puts_nl chan t
        | `Index ind -> Printf.fprintf chan "* %s::\n" ind)
      subpart_list ;
    puts_nl chan "@end menu"
  end

  (** cross reference to node [name] *)
  let xref ?xname name =
    "@xref{" ^ (fix_nodename name) ^
    (match xname with | None -> "" | Some s -> "," ^ s) ^
    "}."

  (** enclose the string between [\@ifinfo] tags *)
  let ifinfo s =
    String.concat "\n"
      [ "@ifinfo" ; s ; "@end ifinfo" ; "" ]

  (** [install-info] information *)
  let dirsection sec =
    "@dircategory " ^ (escape sec)

  let direntry ent =
    [ "@direntry" ] @
      (List.map escape ent) @
    [ "@end direntry" ]
end





(** {1 Generation of Texinfo code} *)

(** {2 Associations between a title number and texinfo code.} *)
let titles_and_headings = ref [
    0, ("@chapter ", "@majorheading ")  ;
    1, ("@chapter ", "@majorheading ")  ;
    2, ("@section ", "@heading ")  ;
    3, ("@subsection ", "@subheading ") ;
    4, ("@subsubsection ", "@subsubheading ")  ;
  ]

let title = fst
let heading = snd

let fallback_title =
  "@unnumberedsubsubsec "

let fallback_heading =
  "@subsubheading "

(** This class generates Texinfo code from text structures *)
class text =
  object(self)

    method escape =
      Texi.escape

    (** this method is not used here but is virtual
        in a class we will inherit later *)
    method label ?no_:(_ : bool option) (_ : string) : string =
      failwith "gni"

    (** Return the Texinfo code corresponding to the [text] parameter.*)
    method texi_of_text t =
      String.concat ""
        (List.map self#texi_of_text_element t)


    (** {2 Conversion methods}
       [texi_of_????] converts a [text_element] to a Texinfo string. *)

    (** Return the Texinfo code for the [text_element] in parameter. *)
    method texi_of_text_element = function
      | Verbatim s | Latex s -> self#texi_of_Verbatim s
      | Raw s -> self#texi_of_Raw s
      | Code s -> self#texi_of_Code s
      | CodePre s -> self#texi_of_CodePre s
      | Bold t -> self#texi_of_Bold t
      | Italic t -> self#texi_of_Italic t
      | Emphasize t -> self#texi_of_Emphasize t
      | Center t -> self#texi_of_Center t
      | Left t -> self#texi_of_Left t
      | Right t -> self#texi_of_Right t
      | List tl -> self#texi_of_List tl
      | Enum tl -> self#texi_of_Enum tl
      | Newline -> self#texi_of_Newline
      | Block t -> self#texi_of_Block t
      | Title (n, _, t) -> self#texi_of_Title n t
      | Link (s, t) -> self#texi_of_Link s t
      | Ref (name, kind, _) ->self#texi_of_Ref name kind
      | Superscript t -> self#texi_of_Superscript t
      | Subscript t -> self#texi_of_Subscript t
      | Odoc_info.Module_list _ -> ""
      | Odoc_info.Index_list -> ""
      | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t
      | Odoc_info.Target (target, code) -> self#texi_of_Target ~target ~code

    method texi_of_custom_text _ _ = ""

    method texi_of_Target ~target ~code =
      if String.lowercase_ascii target = "texi" then code else ""

    method texi_of_Verbatim s = s
    method texi_of_Raw s = self#escape s
    method texi_of_Code s = "@code{" ^ (self#escape s) ^ "}"
    method texi_of_CodePre s =
      String.concat "\n"
        [ "" ;  "@example" ; self#escape s ; "@end example" ; "" ]
    method texi_of_Bold t = "@strong{" ^ (self#texi_of_text t) ^ "}"
    method texi_of_Italic t = "@i{" ^ (self#texi_of_text t) ^ "}"
    method texi_of_Emphasize t = "@emph{" ^ (self#texi_of_text t) ^ "}"
    method texi_of_Center t =
      let sl = Str.split (Str.regexp "\n") (self#texi_of_text t) in
      String.concat ""
        ((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ])
    method texi_of_Left t =
      String.concat "\n"
        [ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ]
    method texi_of_Right t =
      String.concat "\n"
        [ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ]
    method texi_of_List tl =
      String.concat "\n"
        ( [ "" ; "@itemize" ] @
          (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @
          [ "@end itemize"; "" ] )
    method texi_of_Enum tl =
      String.concat "\n"
        ( [ "" ; "@enumerate" ] @
          (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @
          [ "@end enumerate"; "" ] )
    method texi_of_Newline = "\n"
    method texi_of_Block t =
      String.concat "\n"
        [ "@format" ; self#texi_of_text t ; "@end format" ; "" ]
    method texi_of_Title n t =
      let t_begin =
        try title @@ List.assoc n !titles_and_headings
        with Not_found -> fallback_title in
      t_begin ^ (self#texi_of_text t) ^ "\n"
    method texi_of_Link s t =
      String.concat ""
        [ "@uref{" ; s ;  "," ; self#texi_of_text t ; "}" ]
    method texi_of_Ref name kind =
      let xname =
        match kind with
        | Some RK_module ->
            Odoc_messages.modul ^ " " ^ (Name.simple name)
        | Some RK_module_type ->
            Odoc_messages.module_type ^ " " ^ (Name.simple name)
        | Some RK_class ->
            Odoc_messages.clas ^ " " ^ (Name.simple name)
        | Some RK_class_type ->
            Odoc_messages.class_type ^ " " ^ (Name.simple name)
        | _ -> ""
      in
      if xname = "" then self#escape name else Texi.xref ~xname name
    method texi_of_Superscript t =
      "^@{" ^ (self#texi_of_text t) ^ "@}"
    method texi_of_Subscript t =
      "_@{" ^ (self#texi_of_text t) ^ "@}"

    method heading n t =
      let f =
        try heading @@ List.assoc n !titles_and_headings
        with Not_found -> fallback_heading
      in
      f ^ (self#texi_of_text t) ^ "\n"

    method fixedblock t =
      Block ( ( Verbatim "@t{" :: t ) @ [ Verbatim "}" ] )

  end

exception Aliased_node

module Generator =
struct

(** This class is used to create objects which can generate a simple
    Texinfo documentation. *)
class texi =
  object (self)
    inherit text
    inherit Odoc_to_text.to_text as to_text

    (** {2 Small helper stuff.} *)

    val maxdepth = 4

    val bullet = Verbatim " @bullet{} "
    val minus  = Verbatim " @minus{} "
    val linebreak =  Verbatim "@*\n"

    val mutable indices_to_build = [ `Module ]

    (** Keep a set of nodes we create. If we try to create one
        a second time, that means it is some kind of alias, so
        don't do it, just link to the previous one *)
    val node_tbl = Hashtbl.create 37

    method node depth name =
      if Hashtbl.mem node_tbl name
      then raise Aliased_node ;
      Hashtbl.add node_tbl name () ;
      if depth <= maxdepth
      then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n")
      else nothing

    method index (ind : indices) ent =
      Verbatim
        (if !Global.with_index
        then (assert(List.mem ind indices_to_build) ;
              String.concat ""
                [ "@" ; indices ind ; "index " ;
                  Texi.escape (Name.simple ent) ; "\n" ])
        else "")


    (** Two hacks to fix linebreaks in the descriptions.*)
    method private fix_linebreaks =
      let re = Str.regexp "\n[ \t]*" in
      fun t ->
        List.map
          (function
            | Newline -> Raw "\n"
            | Raw s -> Raw (Str.global_replace re "\n" s)
            | List tel -> List (List.map self#fix_linebreaks tel)
            | Enum tel -> Enum (List.map self#fix_linebreaks tel)
            | txt -> txt) t

    method private soft_fix_linebreaks =
      let re = Str.regexp "\n[ \t]*" in
      fun ind t ->
        let rep = "\n" ^ String.make ind ' ' in
        List.map
          (function
            | Raw s -> Raw (Str.global_replace re rep s)
            | txt -> txt) t

    (** {2 [text] values generation}
       Generates [text] values out of description parts.
       Redefines some of methods of {! Odoc_to_text.to_text}. *)

    method text_of_desc = function
      | None -> []
      | Some [ Raw "" ] -> []
      | Some t -> (self#fix_linebreaks t) @ [ Newline ]

    method text_of_sees_opt see_l =
      List.concat
        (List.map
           (function
             | (See_url s, t) ->
                 [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ;
                   Raw " " ; Link (s, t) ; Newline ]
             | (See_file s, t)
             | (See_doc s, t)  ->
                 [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ;
                   Raw " " ; Raw s ] @ t @ [ Newline ])
           see_l)

    method! text_of_before l =
      List.flatten
      (List.map
        (fun x -> linebreak :: (to_text#text_of_before [x])) l)

    method text_of_params params_list =
        List.concat
          (List.map
             (fun (s, t) ->
               [ linebreak ;
                 Bold [ Raw Odoc_messages.parameters ] ;
                 Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] )
             params_list)

    method! text_of_raised_exceptions = function
      | [] -> []
      | (s, t) :: [] ->
          [ linebreak ;
            Bold [ Raw Odoc_messages.raises ] ;
            Raw " " ; Code s ; Raw " " ]
          @ t @ [ Newline ]
      | l ->
          [ linebreak ;
            Bold [ Raw Odoc_messages.raises ] ;
            Raw " :" ;
            List
              (List.map
                 (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ;
            Newline ]

    method! text_of_return_opt = function
      | None -> []
      | Some t ->
          (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ]

    method! text_of_custom c_l =
      List.flatten
        (List.rev
           (List.fold_left
              (fun acc -> fun (tag, text) ->
                try
                  let f = List.assoc tag tag_functions in
                  ( linebreak :: (f text) @ [ Newline ] ) :: acc
                with
               Not_found ->
                 Odoc_info.warning (Odoc_messages.tag_not_handled tag) ;
                 acc
              ) [] c_l))

    method! text_of_info ?(block=false) = function
      | None -> []
      | Some info ->
          let t =
            List.concat
                 [ ( match info.i_deprecated with
                 | None -> []
                 | Some t ->
                     (Raw (Odoc_messages.deprecated ^ ". ")) ::
                     (self#fix_linebreaks t)
                     @ [ Newline ; Newline ] ) ;
                   self#text_of_desc info.i_desc ;
                   if info.i_authors <> []
                   then ( linebreak ::
                          self#text_of_author_list info.i_authors )
                   else [] ;
                   if is info.i_version
                   then ( linebreak ::
                          self#text_of_version_opt info.i_version )
                   else [] ;
                   self#text_of_sees_opt info.i_sees ;
                   self#text_of_before info.i_before ;
                   if is info.i_since
                   then ( linebreak ::
                          self#text_of_since_opt info.i_since )
                   else [] ;
                   self#text_of_params info.i_params ;
                   self#text_of_raised_exceptions info.i_raised_exceptions ;
                   if is info.i_return_value
                   then ( linebreak ::
                          self#text_of_return_opt info.i_return_value )
                   else [] ;
                   self#text_of_alerts info.i_alerts ;
                   self#text_of_custom info.i_custom ;
                 ] in
          if block
          then [ Block t ]
          else (t @ [ Newline ] )

    method texi_of_info i =
      self#texi_of_text (self#text_of_info i)

    (** {2 Conversion of [module_elements] into Texinfo strings}
       The following functions convert [module_elements] and their
       description to [text] values then to Texinfo strings using the
       functions above. *)

    method text_el_of_type_expr m_name typ =
      Raw (indent 5
             (self#relative_idents m_name
                (Odoc_info.string_of_type_expr typ)))

    method! text_of_short_type_expr m_name typ =
      [ Raw (self#normal_type m_name typ) ]

    (** Return Texinfo code for a value. *)
    method texi_of_value v =
      Odoc_info.reset_type_names () ;
      let t = [ self#fixedblock
                  [ Newline ; minus ;
                    Raw ("val " ^ (Name.simple v.val_name) ^ " :\n") ;
                    self#text_el_of_type_expr
                      (Name.father v.val_name) v.val_type ] ;
                self#index `Value v.val_name ; Newline  ] @
                (self#text_of_info v.val_info) in
      self#texi_of_text t


    (** Return Texinfo code for a class attribute. *)
    method texi_of_attribute a =
      Odoc_info.reset_type_names () ;
      let t = [ self#fixedblock
                  [ Newline ; minus ;
                    Raw "val " ;
                    Raw (if a.att_virtual then "virtual " else "") ;
                    Raw (if a.att_mutable then "mutable " else "") ;
                    Raw (Name.simple a.att_value.val_name) ;
                    Raw " :\n" ;
                    self#text_el_of_type_expr
                      (Name.father a.att_value.val_name)
                      a.att_value.val_type ] ;
                self#index `Class_att a.att_value.val_name  ; Newline ] @
        (self#text_of_info a.att_value.val_info) in
      self#texi_of_text t


    (** Return Texinfo code for a class method. *)
    method texi_of_method m =
      Odoc_info.reset_type_names () ;
      let t = [ self#fixedblock
                  [ Newline ; minus ; Raw "method " ;
                    Raw (if m.met_private then "private " else "") ;
                    Raw (if m.met_virtual then "virtual " else "") ;
                    Raw (Name.simple m.met_value.val_name) ;
                    Raw " :\n" ;
                    self#text_el_of_type_expr
                      (Name.father m.met_value.val_name)
                      m.met_value.val_type ] ;
                self#index `Method m.met_value.val_name ; Newline ] @
        (self#text_of_info m.met_value.val_info) in
      self#texi_of_text t


    method string_of_type_parameters t =
      let f (tp, v) =
        Printf.sprintf "%s%s"
          (Odoc_info.string_of_variance t v)
          (Odoc_info.string_of_type_expr tp)
      in
      match t.ty_parameters with
      | [] -> ""
      | [ tv ] -> (f tv)^" "
      | l ->
          Printf.sprintf "(%s) "
            (String.concat ", " (List.map f l))

    method string_of_type_args (args:constructor_args) (ret:Types.type_expr option) =
      let f = function
        | Cstr_tuple l -> Odoc_info.string_of_type_list " * " l
        | Cstr_record l -> Odoc_info.string_of_record l
      in
      match args, ret with
      | Cstr_tuple [], None -> ""
      | args, None -> " of " ^ (f args)
      | Cstr_tuple [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r)
      | args, Some r -> " : " ^ (f args) ^
                                " -> " ^ (Odoc_info.string_of_type_expr r)

    (** Return Texinfo code for a type. *)
    method texi_of_type ty =
      Odoc_info.reset_type_names () ;
      let entry_doc = function
        | None -> [ Newline ]
        | Some t ->
          (Raw (indent 5 "\n(*\n") :: (self#soft_fix_linebreaks 8 (self#text_of_info (Some t))))
          @ [ Raw " *)" ; Newline ]
      in
      let t =
        [ self#fixedblock (
          [ Newline ; minus ; Raw "type " ;
            Raw (self#string_of_type_parameters ty) ;
            Raw (Name.simple ty.ty_name) ] @
          let priv = ty.ty_private = Asttypes.Private in
          ( match ty.ty_manifest with
          | None -> []
          | Some (Other typ) ->
              (Raw " = ") ::
              (Raw (if priv then "private " else "")) ::
              (self#text_of_short_type_expr (Name.father ty.ty_name) typ)
          | Some (Object_type l) ->
               (Raw (" = "^(if priv then "private " else "")^"{\n")) ::
               (List.flatten
                  (List.map
                     (fun r ->
                       [ Raw ("  " ^ r.of_name ^ " : ") ] @
                       (self#text_of_short_type_expr
                          (Name.father r.of_name)
                          r.of_type) @
                       [ Raw " ;" ] @
                       (entry_doc r.of_text))
                     l ) )
               @  [ Raw " }" ]
          ) @
          (
           match ty.ty_kind with
           | Type_abstract -> [ Newline ]
           | Type_variant l ->
               (Raw (" ="^(if priv then " private" else "")^"\n")) ::
               (List.flatten
                  (List.map
                     (fun constr ->
                       (Raw ("  | " ^ constr.vc_name)) ::
                       (Raw (self#string_of_type_args
                               constr.vc_args constr.vc_ret)) ::
                         (entry_doc constr.vc_text)
                         ) l ) )
           | Type_record l ->
               (Raw (" = "^(if priv then "private " else "")^"{\n")) ::
               (List.flatten
                  (List.map
                     (fun r ->
                       [ Raw ("  " ^ r.rf_name ^ " : ") ] @
                       (self#text_of_short_type_expr
                          (Name.father r.rf_name)
                          r.rf_type) @
                       [ Raw " ;" ] @
                        (entry_doc r.rf_text)
                        )
                     l ) )
               @  [ Raw " }" ]
           | Type_open -> [ Raw " = .." ; Newline ]
          ) ) ;
          self#index `Type ty.ty_name ; Newline ] @
        (self#text_of_info ty.ty_info) in
      self#texi_of_text t

    (** Return Texinfo code for a type extension. *)
    method texi_of_type_extension m_name te =
      Odoc_info.reset_type_names () ;
      let t =
        ( self#fixedblock (
            [ Newline ; minus ;
              Raw "type " ;
              Raw (match te.te_type_parameters with
                     | [] -> ""
                     | [ tp ] ->
                         Printf.sprintf "%s "
                           (Odoc_info.string_of_type_expr tp)
                     | l ->
                         Printf.sprintf "(%s) "
                           (String.concat ", "
                              (List.map Odoc_info.string_of_type_expr l))) ;
              Raw (self#relative_idents m_name te.te_type_name) ;
              Raw (" +=" ^
                      (if te.te_private = Asttypes.Private
                       then " private" else "")^"\n") ] @
              (List.flatten
                 (List.map
                    (fun x ->
                       (Raw ("  | " ^ (Name.simple x.xt_name))) ::
                         (Raw (self#string_of_type_args
                                 x.xt_args x.xt_ret)) ::
                         (match x.xt_alias with
                            | None -> []
                            | Some xa ->
                                [ Raw " = " ;
                                  Raw ( match xa.xa_xt with
                                          | None -> xa.xa_name
                                          | Some x -> x.xt_name ) ]) @
                         (match x.xt_text with
                            | None -> [ Newline ]
                            | Some t ->
                                (Raw (indent 5 "\n(* ") ::
                                   self#soft_fix_linebreaks 8
                                     (self#text_of_info (Some t))) @
                                  [ Raw " *)" ; Newline ] ) @
                         [self#index `Extension x.xt_name ] )
                    te.te_constructors ) ) ) ) ::
          (self#text_of_info te.te_info) in
        self#texi_of_text t

    (** Return Texinfo code for an exception. *)
    method texi_of_exception e =
      Odoc_info.reset_type_names () ;
      let t =
        [ self#fixedblock
            ( [ Newline ; minus ; Raw "exception " ;
                Raw (Name.simple e.ex_name) ;
                Raw (self#string_of_type_args e.ex_args e.ex_ret) ] @
              (match e.ex_alias with
              | None -> []
              | Some ea -> [ Raw " = " ; Raw
                               ( match ea.ea_ex with
                               | None -> ea.ea_name
                               | Some e -> e.ex_name ) ; ]
              ) ) ;
          self#index `Exception e.ex_name ; Newline ] @
        (self#text_of_info e.ex_info) in
      self#texi_of_text t


    (** Return the Texinfo code for the given module. *)
    method texi_of_module m =
      let is_alias = function
        | { m_kind = Module_alias _ } -> true
        | _ -> false in
      let is_alias_there = function
        | { m_kind = Module_alias { ma_module = None } } -> false
        | _ -> true in
      let resolve_alias_name = function
        | { m_kind = Module_alias { ma_name = name } } -> name
        | { m_name = name } -> name in
      let t =
        [ [ self#fixedblock
              [ Newline ; minus ; Raw "module " ;
                Raw (Name.simple m.m_name) ;
                Raw (if is_alias m
                then " = " ^ (resolve_alias_name m)
                else "" ) ] ] ;
          ( if is_alias_there m
          then [ Ref (resolve_alias_name m, Some RK_module, None) ;
                 Newline ; ]
          else [] ) ;
          ( if is_alias m
          then [ self#index `Module m.m_name ; Newline ]
          else [ Newline ] ) ;
          self#text_of_info m.m_info ]
      in
      self#texi_of_text (List.flatten t)

    (** Return the Texinfo code for the given module type. *)
    method texi_of_module_type mt =
      let is_alias = function
        | { mt_kind = Some (Module_type_alias _) } -> true
        | _ -> false in
      let is_alias_there = function
        | { mt_kind = Some (Module_type_alias { mta_module = None }) } -> false
        | _ -> true in
      let resolve_alias_name = function
        | { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name
        | { mt_name = name } -> name in
      let t =
        [ [ self#fixedblock
              [ Newline ; minus ; Raw "module type " ;
                Raw (Name.simple mt.mt_name) ;
                Raw (if is_alias mt
                then " = " ^ (resolve_alias_name mt)
                else "" ) ] ] ;
          ( if is_alias_there mt
          then [ Ref (resolve_alias_name mt, Some RK_module_type, None) ;
                 Newline ; ]
          else [] ) ;
          ( if is_alias mt
          then [ self#index `Module_type mt.mt_name ; Newline ]
          else [ Newline ] ) ;
          self#text_of_info mt.mt_info ]
      in
      self#texi_of_text (List.flatten t)

    (** Return the Texinfo code for the given included module. *)
    method texi_of_included_module im =
      let t = [ self#fixedblock
                  ( Newline :: minus :: (Raw "include ") ::
                    ( match im.im_module with
                    | None ->
                        [ Raw im.im_name ]
                    | Some (Mod { m_name = name }) ->
                        [ Raw name ; Raw "\n     " ;
                          Ref (name, Some RK_module, None) ]
                    | Some (Modtype { mt_name = name }) ->
                        [ Raw name ; Raw "\n     " ;
                          Ref (name, Some RK_module_type, None) ]
                    ) @
                   [ Newline ] @
                   (self#text_of_info im.im_info)
                  )
              ]
      in
      self#texi_of_text t

    (** Return the Texinfo code for the given class. *)
    method texi_of_class c =
      Odoc_info.reset_type_names () ;
      let t = [ self#fixedblock
                  [ Newline ; minus ; Raw "class " ;
                    Raw (Name.simple c.cl_name) ] ;
                Ref (c.cl_name, Some RK_class, None) ; Newline ;
                Newline ] @ (self#text_of_info c.cl_info) in
      self#texi_of_text t

    (** Return the Texinfo code for the given class type. *)
    method texi_of_class_type ct =
      Odoc_info.reset_type_names () ;
      let t = [ self#fixedblock
                  [ Newline ; minus ; Raw "class type " ;
                    Raw (Name.simple ct.clt_name) ] ;
                Ref (ct.clt_name, Some RK_class_type, None) ; Newline ;
                Newline ] @ (self#text_of_info ct.clt_info) in
      self#texi_of_text t

    (** Return the Texinfo code for the given class element. *)
    method texi_of_class_element _class_name class_ele =
      match class_ele with
      | Class_attribute att -> self#texi_of_attribute att
      | Class_method met -> self#texi_of_method met
      | Class_comment t -> self#texi_of_text t

    (** Return the Texinfo code for the given module element. *)
    method texi_of_module_element module_name module_ele =
      (match module_ele with
      | Element_module m -> self#texi_of_module m
      | Element_module_type mt -> self#texi_of_module_type mt
      | Element_included_module im -> self#texi_of_included_module im
      | Element_class c -> self#texi_of_class c
      | Element_class_type ct -> self#texi_of_class_type ct
      | Element_value v -> self#texi_of_value v
      | Element_type_extension te -> self#texi_of_type_extension module_name te
      | Element_exception e -> self#texi_of_exception e
      | Element_type t -> self#texi_of_type t
      | Element_module_comment t ->
          self#texi_of_text (Newline :: t @ [Newline])
      )

    (** {2 Generating methods }
       These methods write Texinfo code to an [out_channel] *)

    (** Generate the Texinfo code for the given list of inherited classes.*)
    method generate_inheritance_info chanout inher_l =
      let f inh =
        match inh.ic_class with
        | None -> (* we can't make the reference *)
            (Code inh.ic_name) ::
            (match inh.ic_text with
            | None -> []
            | Some t -> Newline :: t)
        | Some cct -> (* we can create the reference *)
            let kind =
              match cct with
              | Cl _ -> Some RK_class
              | Cltype _ -> Some RK_class_type in
            (Code inh.ic_name) ::
            (Ref (inh.ic_name, kind, None)) ::
            ( match inh.ic_text with
            | None -> []
            | Some t -> Newline :: t)
      in
      let text = [
        Bold [ Raw Odoc_messages.inherits ] ;
        List (List.map f inher_l) ; Newline ]
      in
      puts chanout (self#texi_of_text text)



    (** Generate the Texinfo code for the inherited classes
       of the given class. *)
    method generate_class_inheritance_info chanout cl =
      let rec iter_kind = function
        | Class_structure ([], _) -> ()
        | Class_structure (l, _) ->
            self#generate_inheritance_info chanout l
        | Class_constraint (k, _) -> iter_kind k
        | Class_apply _
        | Class_constr _ -> ()
      in
      iter_kind cl.cl_kind



    (** Generate the Texinfo code for the inherited classes
       of the given class type. *)
    method generate_class_type_inheritance_info chanout clt =
      match clt.clt_kind with
      | Class_signature ([], _) ->
          ()
      | Class_signature (l, _) ->
          self#generate_inheritance_info chanout l
      | Class_type _ ->
          ()

    (** Generate the Texinfo code for the given class,
       in the given out channel. *)
    method generate_for_class chanout c =
     try
      Odoc_info.reset_type_names () ;
      let depth = Name.depth c.cl_name in
      let title = [
        self#node depth c.cl_name ;
        Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ;
                                    Code c.cl_name ]) ;
        self#index `Class c.cl_name ] in
      puts chanout (self#texi_of_text title) ;

      if is c.cl_info
      then begin
        let descr = [ Title (succ depth, None,
                             [ Raw Odoc_messages.description ]) ] in
        puts chanout (self#texi_of_text descr) ;
        puts chanout (self#texi_of_info c.cl_info)
      end ;

      let intf = [ Title (succ depth, None,
                          [ Raw Odoc_messages.interface]) ] in
      puts chanout (self#texi_of_text intf);
      self#generate_class_inheritance_info chanout c ;
      List.iter
        (fun ele -> puts chanout
            (self#texi_of_class_element c.cl_name ele))
        (Class.class_elements ~trans:false c)
     with Aliased_node -> ()


    (** Generate the Texinfo code for the given class type,
       in the given out channel. *)
    method generate_for_class_type chanout ct =
     try
      Odoc_info.reset_type_names () ;
      let depth = Name.depth ct.clt_name in
      let title = [
        self#node depth ct.clt_name ;
        Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ;
                                    Code ct.clt_name ]) ;
        self#index `Class_type ct.clt_name ] in
      puts chanout (self#texi_of_text title) ;

      if is ct.clt_info
      then begin
        let descr = [ Title (succ depth, None,
                             [ Raw Odoc_messages.description ]) ] in
        puts chanout (self#texi_of_text descr) ;
        puts chanout (self#texi_of_info ct.clt_info)
      end ;

      let intf = [ Title (succ depth, None,
                          [ Raw Odoc_messages.interface ]) ] in
      puts chanout (self#texi_of_text intf) ;
      self#generate_class_type_inheritance_info chanout ct;
      List.iter
        (fun ele -> puts chanout
            (self#texi_of_class_element ct.clt_name ele))
        (Class.class_type_elements ~trans:false ct)
     with Aliased_node -> ()


    (** Generate the Texinfo code for the given module type,
       in the given out channel. *)
    method generate_for_module_type chanout mt =
     try
      let depth = Name.depth mt.mt_name in
      let title = [
        self#node depth mt.mt_name ;
        Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ;
                              Code mt.mt_name ]) ;
        self#index `Module_type mt.mt_name ; Newline ] in
      puts chanout (self#texi_of_text title) ;

      if is mt.mt_info
      then begin
        let descr = [ Title (succ depth, None,
                             [ Raw Odoc_messages.description ]) ] in
        puts chanout (self#texi_of_text descr) ;
        puts chanout (self#texi_of_info mt.mt_info)
      end ;

      let mt_ele = Module.module_type_elements ~trans:true mt in
      let subparts = module_subparts mt_ele in
      if depth < maxdepth && subparts <> []
      then begin
        let menu = Texi.ifinfo
            ( self#heading (succ depth) [ Raw "Subparts" ]) in
        puts chanout menu ;
        Texi.generate_menu chanout (subparts :> menu_data)
      end ;

      let intf = [ Title (succ depth, None,
                          [ Raw Odoc_messages.interface ]) ] in
      puts chanout (self#texi_of_text intf) ;
      List.iter
        (fun ele -> puts chanout
            (self#texi_of_module_element mt.mt_name ele))
        mt_ele ;

      (* create sub parts for modules, module types, classes and class types *)
      List.iter
        (function
          | `Module m -> self#generate_for_module chanout m
          | `Module_type mt -> self#generate_for_module_type chanout mt
          | `Class c -> self#generate_for_class chanout c
          | `Class_type ct -> self#generate_for_class_type chanout ct)
        subparts
     with Aliased_node -> ()

    (** Generate the Texinfo code for the given module,
       in the given out channel. *)
    method generate_for_module chanout m =
     try
      Odoc_info.verbose ("Generate for module " ^ m.m_name) ;
      let depth = Name.depth m.m_name in
      let title = [
        self#node depth m.m_name ;
        Title (depth, None,
               if m.m_text_only then
                 [ Raw m.m_name ]
               else
                 [ Raw (Odoc_messages.modul ^ " ") ;
                   Code m.m_name ]
              ) ;
        self#index `Module m.m_name ; Newline ] in
      puts chanout (self#texi_of_text title) ;

      if is m.m_info
      then begin
        let descr = [ Title (succ depth, None,
                             [ Raw Odoc_messages.description ]) ] in
        puts chanout (self#texi_of_text descr) ;
        puts chanout (self#texi_of_info m.m_info)
      end ;

      let m_ele = Module.module_elements ~trans:true m in
      let subparts = module_subparts m_ele in
      if depth < maxdepth && subparts <> []
      then begin
        let menu = Texi.ifinfo
            ( self#heading (succ depth) [ Raw "Subparts" ]) in
        puts chanout menu ;
        Texi.generate_menu chanout (subparts :> menu_data)
      end ;

      let intf = [ Title (succ depth, None,
                          [ Raw Odoc_messages.interface]) ] in
      puts chanout (self#texi_of_text intf) ;

      List.iter
        (fun ele -> puts chanout
            (self#texi_of_module_element m.m_name ele))
        m_ele ;

      (* create sub nodes for modules, module types, classes and class types *)
      List.iter
        (function
          | `Module m -> self#generate_for_module chanout m
          | `Module_type mt -> self#generate_for_module_type chanout mt
          | `Class c -> self#generate_for_class chanout c
          | `Class_type ct -> self#generate_for_class_type chanout ct )
        subparts
     with Aliased_node -> ()


    (** Writes the header of the TeXinfo document. *)
    method generate_texi_header chan texi_filename m_list =
      let title = match !Global.title with
      | None -> ""
      | Some s -> self#escape s in
      let filename =
        if texi_filename <> "ocamldoc.texi"
        then
          let fn = Filename.basename texi_filename in
          (if Filename.check_suffix fn ".texi"
          then Filename.chop_suffix fn ".texi"
          else fn) ^ ".info"
        else
          if title <> ""
          then title ^ ".info"
          else "doc.info"
      in
      (* write a standard Texinfo header *)
      List.iter
        (puts_nl chan)
        (List.flatten
           [ [ "\\input texinfo   @c -*-texinfo-*-" ;
               "@c %**start of header" ;
               "@setfilename " ^ filename ;
               "@settitle " ^ title ;
               "@c %**end of header" ; ] ;

             (if !Global.with_index then
               List.map
                 (fun ind ->
                   "@defcodeindex " ^ (indices ind))
                 indices_to_build
             else []) ;

             [ Texi.dirsection !info_section ] ;

             Texi.direntry
               (if !info_entry <> []
               then !info_entry
               else [ Printf.sprintf "* %s: (%s)."
                        title
                        (Filename.chop_suffix filename ".info") ]) ;

             [ "@ifinfo" ;
               "This file was generated by Ocamldoc using the Texinfo generator." ;
               "@end ifinfo" ;

               "@c no titlepage." ;

               "@node Top, , , (dir)" ;
               "@top "^ title ; ]
           ] ) ;

      (* insert the intro file *)
      begin
        match !Odoc_info.Global.intro_file with
        | None when title <> "" ->
            puts_nl chan "@ifinfo" ;
            puts_nl chan ("Documentation for " ^ title) ;
            puts_nl chan "@end ifinfo"
        | None ->
            puts_nl chan "@c no title given"
        | Some f ->
            nl chan ;
            puts_nl chan
              (self#texi_of_info
                 (Some (Odoc_info.info_of_comment_file m_list f)))
      end ;

      (* write a top menu *)
      Texi.generate_menu chan
        ((List.map (fun m -> `Module m) m_list) @
         (if !Global.with_index then
           let indices_names_to_build = List.map indices indices_to_build in
           List.rev
             (List.fold_left
                (fun acc ->
                  function (longname, shortname)
                      when List.mem shortname indices_names_to_build ->
                        (`Index (longname ^ " index")) :: acc
                    | _ -> acc)
                [ `Comment "Indices :" ; `Blank ]
                indices_names )
         else [] ))


    (** Writes the trailer of the TeXinfo document. *)
    method generate_texi_trailer chan =
      nl chan ;
      if !Global.with_index
      then
        let indices_names_to_build = List.map indices indices_to_build in
        List.iter (puts_nl chan)
          (List.flatten
             (List.map
                (fun (longname, shortname) ->
                  if List.mem shortname indices_names_to_build
                  then [ "@node " ^ longname ^ " index," ;
                         "@unnumbered " ^ longname ^ " index" ;
                         "@printindex " ^ shortname ; ]
                  else [])
                indices_names )) ;
      if !Global.with_toc
      then puts_nl chan "@contents" ;
      puts_nl chan "@bye"


    method do_index it =
      if not (List.mem it indices_to_build)
      then indices_to_build <- it :: indices_to_build

   (** Scan the whole module information to know which indices need to be build *)
    method scan_for_index : subparts -> unit = function
      | `Module m ->
          let m_ele = Module.module_elements ~trans:true m in
          List.iter self#scan_for_index_in_mod m_ele
      | `Module_type mt ->
          let m_ele = Module.module_type_elements ~trans:true mt in
          List.iter self#scan_for_index_in_mod m_ele
      | `Class c ->
          let c_ele = Class.class_elements ~trans:true c in
          List.iter self#scan_for_index_in_class c_ele
      | `Class_type ct ->
          let c_ele = Class.class_type_elements ~trans:true ct in
          List.iter self#scan_for_index_in_class c_ele

    method scan_for_index_in_mod = function
        (* no recursion *)
      | Element_value _ -> self#do_index `Value
      | Element_type_extension _ -> self#do_index `Extension
      | Element_exception _ -> self#do_index `Exception
      | Element_type _ -> self#do_index `Type
      | Element_included_module _
      | Element_module_comment _ -> ()
         (* recursion *)
      | Element_module m -> self#do_index `Module ;
          self#scan_for_index (`Module m)
      | Element_module_type mt -> self#do_index `Module_type ;
          self#scan_for_index (`Module_type mt)
      | Element_class c -> self#do_index `Class ;
          self#scan_for_index (`Class c)
      | Element_class_type ct -> self#do_index `Class_type ;
          self#scan_for_index (`Class_type ct)

    method scan_for_index_in_class = function
      | Class_attribute _ -> self#do_index `Class_att
      | Class_method _ -> self#do_index `Method
      | Class_comment _ -> ()


    (** Generate the Texinfo file from a module list,
       in the {!Odoc_info.Global.out_file} file. *)
    method generate module_list =
      Hashtbl.clear node_tbl ;
      let filename =
        if !Global.out_file = Odoc_messages.default_out_file
        then "ocamldoc.texi"
        else !Global.out_file in
      if !Global.with_index
      then List.iter self#scan_for_index
          (List.map (fun m -> `Module m) module_list) ;
      try
        let chanout = open_out
            (Filename.concat !Global.target_dir filename) in
        if !Global.with_header
        then self#generate_texi_header chanout filename module_list ;
        List.iter
          (self#generate_for_module chanout)
          module_list ;
        if !Global.with_trailer
        then self#generate_texi_trailer chanout ;
        close_out chanout
      with
      | Failure s
      | Sys_error s ->
          prerr_endline s ;
          incr Odoc_info.errors
  end
end

module type Texi_generator = module type of Generator