lib/deriving_Show.ml

   1 (* Copyright Jeremy Yallop 2007.
   2    This file is free software, distributed under the MIT license.
   3    See the file COPYING for details.
   4 *)
   5
   6 module Deriving_Show =
   7 struct
   8 (** Show **)
   9 module type Show = sig
  10   type a
  11   val format : Format.formatter -> a -> unit
  12   val format_list : Format.formatter -> a list -> unit
  13   val show : a -> string
  14   val show_list : a list -> string
  15 end
  16
  17 module type SimpleFormatter =
  18 sig
  19   type a
  20   val format : Format.formatter -> a -> unit
  21 end
  22
  23 module ShowFormatterDefault (S : SimpleFormatter) =
  24 struct
  25   include S
  26   let format_list formatter items =
  27     let rec writeItems formatter = function
  28       | []      -> ()
  29       | [x]     -> S.format formatter x;
  30       | x :: xs -> Format.fprintf formatter "%a;@;%a" S.format x writeItems xs
  31     in
  32       Format.fprintf formatter "@[<hov 1>[%a]@]" writeItems items
  33 end
  34
  35 module ShowDefaults'
  36   (S : (sig
  37           type a
  38           val format : Format.formatter -> a -> unit
  39           val format_list : Format.formatter -> a list -> unit
  40         end)) : Show with type a = S.a =
  41 struct
  42   include S
  43   let showFormatted f item =
  44     let b = Buffer.create 16 in
  45     let formatter = Format.formatter_of_buffer b in
  46       Format.fprintf formatter "@[<hov 0>%a@]@?" f item;
  47       Buffer.sub b 0 (Buffer.length b)
  48
  49   (* Warning: do not eta-reduce either of the following *)
  50   let show item = showFormatted S.format item
  51   let show_list items = showFormatted S.format_list items
  52 end
  53
  54 module Defaults (S : SimpleFormatter) : Show with type a = S.a =
  55   ShowDefaults' (ShowFormatterDefault (S))
  56
  57 module Show_unprintable (S : sig type a end) (*: Show with type a = S.a *) =
  58   Defaults (struct
  59               type a = S.a
  60               let format formatter _ = Format.pp_print_string formatter "..."
  61             end)
  62
  63 (* instance Show a => Show [a] *)
  64 module Show_list (S : Show) : Show with type a = S.a list =
  65   Defaults (struct
  66               type a = S.a list
  67               let format = S.format_list
  68             end)
  69
  70 (* instance Show a => Show (a option) *)
  71 module Show_option (S : Show) : Show with type a = S.a option =
  72   Defaults (struct
  73               type a = S.a option
  74               let format formatter = function
  75                 | None   -> Format.fprintf formatter "@[None@]"
  76                 | Some s -> Format.fprintf formatter "@[Some@;<1 2>(%a)@]" S.format s
  77             end)
  78
  79 (* instance Show a => Show (a array) *)
  80 module Show_array (S : Show) : Show with type a = S.a array =
  81   Defaults (struct
  82               type a = S.a array
  83               let format formatter obj =
  84                 let writeItems formatter items =
  85                   let length = Array.length items in
  86                     for i = 0 to length - 2 do
  87                       Format.fprintf formatter "@[%a;@;@]" S.format (Array.get items i)
  88                     done;
  89                     if length <> 0 then
  90                       S.format formatter (Array.get items (length -1));
  91                 in
  92                   Format.fprintf formatter "@[[|%a|]@]" writeItems obj
  93             end)
  94
  95 module Show_map
  96   (O : Map.OrderedType)
  97   (K : Show with type a = O.t)
  98   (V : Show)
  99   : Show with type a = V.a Map.Make(O).t =
 100 Defaults(
 101   struct
 102     module M = Map.Make(O)
 103     type a = V.a M.t
 104     let format formatter map =
 105       Format.pp_open_box formatter 0;
 106       Format.pp_print_string formatter "{";
 107       M.iter (fun key value ->
 108                 Format.pp_open_box formatter 0;
 109                 K.format formatter key;
 110                 Format.pp_print_string formatter " => ";
 111                 V.format formatter value;
 112                 Format.pp_close_box formatter ();
 113              ) map;
 114       Format.pp_print_string formatter "}";
 115       Format.pp_close_box formatter ();
 116
 117   end)
 118
 119 module Show_set
 120   (O : Set.OrderedType)
 121   (K : Show with type a = O.t)
 122   : Show with type a = Set.Make(O).t =
 123 Defaults(
 124   struct
 125     module S = Set.Make(O)
 126     type a = S.t
 127     let format formatter set =
 128       Format.pp_open_box formatter 0;
 129       Format.pp_print_string formatter "{";
 130       S.iter (fun elt ->
 131                 Format.pp_open_box formatter 0;
 132                 K.format formatter elt;
 133                 Format.pp_close_box formatter ();
 134              ) set;
 135       Format.pp_print_string formatter "}";
 136       Format.pp_close_box formatter ();
 137   end)
 138
 139 module Show_bool = Defaults (struct
 140   type a = bool
 141   let format formatter item =
 142     match item with
 143       | true  -> Format.pp_print_string formatter "true"
 144       | false -> Format.pp_print_string formatter "false"
 145 end)
 146
 147 module Show_integer (S : sig type t val to_string : t -> string end) = Defaults (struct
 148   type a = S.t
 149   let format formatter item = Format.pp_print_string formatter (S.to_string item)
 150 end)
 151
 152 module Show_int32 = Show_integer(Int32)
 153 module Show_int64 = Show_integer(Int64)
 154 module Show_nativeint = Show_integer(Nativeint)
 155
 156 module Show_char = Defaults (struct
 157   type a = char
 158   let format formatter item = Format.pp_print_string formatter ("'" ^ Char.escaped item ^ "'")
 159 end)
 160
 161 module Show_int = Defaults (struct
 162   type a = int
 163   let format formatter item = Format.pp_print_string formatter (string_of_int item)
 164 end)
 165
 166 module Show_num = Defaults (struct
 167   type a = Num.num
 168   let format formatter item = Format.pp_print_string formatter (Num.string_of_num item)
 169 end)
 170
 171 module Show_float = Defaults(struct
 172     type a = float
 173     let format formatter item = Format.pp_print_string formatter (string_of_float item)
 174 end)
 175
 176 module Show_string = Defaults (struct
 177   type a = string
 178   let format formatter item =
 179     Format.pp_print_char formatter '"';
 180     Format.pp_print_string formatter (String.escaped item);
 181     Format.pp_print_char formatter '"'
 182 end)
 183
 184 module Show_unit = Defaults(struct
 185   type a = unit
 186   let format formatter () = Format.pp_print_string formatter "()"
 187 end)
 188
 189 end
 190 include Deriving_Show
 191
 192 type open_flag = Pervasives.open_flag  =
 193                  | Open_rdonly
 194                  | Open_wronly
 195                  | Open_append
 196                  | Open_creat
 197                  | Open_trunc
 198                  | Open_excl
 199                  | Open_binary
 200                  | Open_text
 201                  | Open_nonblock
 202                      deriving (Show)
 203
 204 type fpclass = Pervasives.fpclass =
 205                | FP_normal
 206                | FP_subnormal
 207                | FP_zero
 208                | FP_infinite
 209                | FP_nan
 210                    deriving (Show)
 211
 212 type 'a ref = 'a Pervasives.ref = { mutable contents : 'a; }
 213     deriving (Show)
 214