l4/pkg/ocaml/ocaml/contrib/ocamldoc/odoc_str.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: odoc_str.ml 8927 2008-07-23 08:55:36Z guesdon $ *)
  13
  14 (** The functions to get a string from different kinds of elements (types, modules, ...). *)
  15
  16 module Name = Odoc_name
  17
  18 let string_of_variance t (co,cn) =
  19   if t.Odoc_type.ty_kind = Odoc_type.Type_abstract &&
  20     t.Odoc_type.ty_manifest = None
  21   then
  22     match (co, cn) with
  23       (true, false) -> "+"
  24     | (false, true) -> "-"
  25     | _ -> ""
  26   else
  27     ""
  28 let rec is_arrow_type t =
  29   match t.Types.desc with
  30     Types.Tarrow _ -> true
  31   | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
  32   | Types.Ttuple _
  33   | Types.Tconstr _
  34   | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
  35   | Types.Tfield _ | Types.Tnil | Types.Tvariant _ -> false
  36
  37 let raw_string_of_type_list sep type_list =
  38   let buf = Buffer.create 256 in
  39   let fmt = Format.formatter_of_buffer buf in
  40   let rec need_parent t =
  41     match t.Types.desc with
  42       Types.Tarrow _ | Types.Ttuple _ -> true
  43     | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
  44     | Types.Tconstr _ ->
  45         false
  46     | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
  47     | Types.Tfield _ | Types.Tnil | Types.Tvariant _ -> false
  48   in
  49   let print_one_type variance t =
  50     Printtyp.mark_loops t;
  51     if need_parent t then
  52       (
  53        Format.fprintf fmt "(%s" variance;
  54        Printtyp.type_scheme_max ~b_reset_names: false fmt t;
  55        Format.fprintf fmt ")"
  56       )
  57     else
  58       (
  59        Format.fprintf fmt "%s" variance;
  60        Printtyp.type_scheme_max ~b_reset_names: false fmt t
  61       )
  62   in
  63   begin match type_list with
  64     [] -> ()
  65   | [(variance, ty)] -> print_one_type variance ty
  66   | (variance, ty) :: tyl ->
  67       Format.fprintf fmt "@[<hov 2>";
  68       print_one_type variance ty;
  69       List.iter
  70         (fun (variance, t) ->
  71           Format.fprintf fmt "@,%s" sep;
  72           print_one_type variance t
  73         )
  74         tyl;
  75       Format.fprintf fmt "@]"
  76   end;
  77   Format.pp_print_flush fmt ();
  78   Buffer.contents buf
  79
  80 let string_of_type_list ?par sep type_list =
  81   let par =
  82     match par with
  83     | Some b -> b
  84     | None ->
  85         match type_list with
  86           [] | [_] -> false
  87         | _ -> true
  88   in
  89   Printf.sprintf "%s%s%s"
  90     (if par then "(" else "")
  91     (raw_string_of_type_list sep (List.map (fun t -> ("", t)) type_list))
  92     (if par then ")" else "")
  93
  94 let string_of_type_param_list t =
  95   let par =
  96     match t.Odoc_type.ty_parameters with
  97       [] | [_] -> false
  98     | _ -> true
  99   in
 100   Printf.sprintf "%s%s%s"
 101     (if par then "(" else "")
 102     (raw_string_of_type_list ", "
 103        (List.map
 104           (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ))
 105           t.Odoc_type.ty_parameters
 106        )
 107     )
 108     (if par then ")" else "")
 109
 110 let string_of_class_type_param_list l =
 111   let par =
 112     match l with
 113       [] | [_] -> false
 114     | _ -> true
 115   in
 116   Printf.sprintf "%s%s%s"
 117     (if par then "[" else "")
 118     (raw_string_of_type_list ", "
 119        (List.map
 120           (fun typ -> ("", typ))
 121           l
 122        )
 123     )
 124     (if par then "]" else "")
 125
 126 let string_of_class_params c =
 127   let b = Buffer.create 256 in
 128   let rec iter = function
 129       Types.Tcty_fun (label, t, ctype) ->
 130         let parent = is_arrow_type t in
 131         Printf.bprintf b "%s%s%s%s -> "
 132           (
 133            match label with
 134              "" -> ""
 135            | s -> s^":"
 136           )
 137           (if parent then "(" else "")
 138           (Odoc_print.string_of_type_expr
 139              (if Odoc_misc.is_optional label then
 140                Odoc_misc.remove_option t
 141              else
 142                t
 143              )
 144           )
 145           (if parent then ")" else "");
 146         iter ctype
 147     | Types.Tcty_signature _
 148     | Types.Tcty_constr _ -> ()
 149   in
 150   iter c.Odoc_class.cl_type;
 151   Buffer.contents b
 152
 153 let bool_of_private = function
 154   | Asttypes.Private -> true
 155   | _ -> false
 156
 157 let string_of_type t =
 158   let module M = Odoc_type in
 159   "type "^
 160   (String.concat ""
 161      (List.map
 162         (fun (p, co, cn) ->
 163           (string_of_variance t (co, cn))^
 164           (Odoc_print.string_of_type_expr p)^" "
 165         )
 166         t.M.ty_parameters
 167      )
 168   )^
 169   let priv = bool_of_private (t.M.ty_private) in
 170   (Name.simple t.M.ty_name)^" "^
 171   (match t.M.ty_manifest with
 172     None -> ""
 173   | Some typ ->
 174      "= " ^ (if priv then "private " else "" ) ^
 175        (Odoc_print.string_of_type_expr typ)^" "
 176   )^
 177   (match t.M.ty_kind with
 178     M.Type_abstract ->
 179       ""
 180   | M.Type_variant l ->
 181       "="^(if priv then " private" else "")^"\n"^
 182       (String.concat ""
 183          (List.map
 184             (fun cons ->
 185               "  | "^cons.M.vc_name^
 186               (match cons.M.vc_args with
 187                 [] -> ""
 188               | l ->
 189                   " of "^(String.concat " * "
 190                             (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))
 191               )^
 192               (match cons.M.vc_text with
 193                 None ->
 194                   ""
 195               | Some t ->
 196                   "(* "^(Odoc_misc.string_of_text t)^" *)"
 197               )^"\n"
 198             )
 199             l
 200          )
 201       )
 202   | M.Type_record l ->
 203       "= "^(if priv then "private " else "")^"{\n"^
 204       (String.concat ""
 205          (List.map
 206             (fun record ->
 207               "   "^(if record.M.rf_mutable then "mutable " else "")^
 208               record.M.rf_name^" : "^(Odoc_print.string_of_type_expr record.M.rf_type)^";"^
 209               (match record.M.rf_text with
 210                 None ->
 211                   ""
 212               | Some t ->
 213                   "(* "^(Odoc_misc.string_of_text t)^" *)"
 214               )^"\n"
 215             )
 216             l
 217          )
 218       )^
 219       "}\n"
 220   )^
 221   (match t.M.ty_info with
 222     None -> ""
 223   | Some info -> Odoc_misc.string_of_info info)
 224
 225 let string_of_exception e =
 226   let module M = Odoc_exception in
 227   "exception "^(Name.simple e.M.ex_name)^
 228   (match e.M.ex_args with
 229     [] -> ""
 230   | _ ->" : "^
 231       (String.concat " -> "
 232          (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") e.M.ex_args)
 233       )
 234   )^
 235   (match e.M.ex_alias with
 236     None -> ""
 237   | Some ea ->
 238       " = "^
 239       (match ea.M.ea_ex with
 240         None -> ea.M.ea_name
 241       | Some e2 -> e2.M.ex_name
 242       )
 243   )^"\n"^
 244   (match e.M.ex_info with
 245     None -> ""
 246   | Some i -> Odoc_misc.string_of_info i)
 247
 248 let string_of_value v =
 249   let module M = Odoc_value in
 250   "val "^(Name.simple v.M.val_name)^" : "^
 251   (Odoc_print.string_of_type_expr v.M.val_type)^"\n"^
 252   (match v.M.val_info with
 253     None -> ""
 254   | Some i -> Odoc_misc.string_of_info i)
 255
 256 let string_of_attribute a =
 257   let module M = Odoc_value in
 258   "val "^
 259   (if a.M.att_virtual then "virtual " else "")^
 260   (if a.M.att_mutable then Odoc_messages.mutab^" " else "")^
 261   (Name.simple a.M.att_value.M.val_name)^" : "^
 262   (Odoc_print.string_of_type_expr a.M.att_value.M.val_type)^"\n"^
 263   (match a.M.att_value.M.val_info with
 264     None -> ""
 265   | Some i -> Odoc_misc.string_of_info i)
 266
 267 let string_of_method m =
 268   let module M = Odoc_value in
 269   "method "^
 270   (if m.M.met_private then Odoc_messages.privat^" " else "")^
 271   (Name.simple m.M.met_value.M.val_name)^" : "^
 272   (Odoc_print.string_of_type_expr m.M.met_value.M.val_type)^"\n"^
 273   (match m.M.met_value.M.val_info with
 274     None -> ""
 275   | Some i -> Odoc_misc.string_of_info i)
 276
 277 (* eof $Id: odoc_str.ml 8927 2008-07-23 08:55:36Z guesdon $ *)