syntax/show_class.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 open Pa_deriving_common.Defs
   7
   8 module Description : ClassDescription = struct
   9   let classname = "Show"
  10   let runtimename = "Deriving_Show"
  11   let default_module = Some "Defaults"
  12   let allow_private = true
  13   let predefs = [
  14     ["int"      ], "int";
  15     ["bool"     ], "bool";
  16     ["unit"     ], "unit";
  17     ["char"     ], "char";
  18     ["int32"    ], "int32";
  19     ["Int32";"t"], "int32";
  20     ["int64"    ], "int64";
  21     ["Int64";"t"], "int64";
  22     ["nativeint"], "nativeint";
  23     ["float"    ], "float";
  24     ["num"], "num";
  25     ["string"   ], "string";
  26     ["list"     ], "list";
  27     ["ref"      ], "ref";
  28     ["option"   ], "option";
  29     ["array"    ], "array";
  30   ]
  31   let depends = []
  32 end
  33
  34 module InContext (L : Loc) : Class = struct
  35
  36   open Pa_deriving_common.Base
  37   open Pa_deriving_common.Utils
  38   open Pa_deriving_common.Type
  39   open Camlp4.PreCast
  40
  41   open L
  42   module Helpers = Pa_deriving_common.Base.InContext(L)(Description)
  43   open Helpers
  44   open Description
  45
  46   let wrap formatter =
  47     [ <:str_item< let format formatter = function $list:formatter$ >> ]
  48
  49   let in_a_box box i e =
  50     <:expr<
  51       Format.$lid:box$ formatter $`int:i$;
  52       $e$;
  53       Format.pp_close_box formatter () >>
  54
  55   let in_paren e =
  56     <:expr<
  57       Format.pp_print_string formatter "(";
  58       $e$;
  59       Format.pp_print_string formatter ")" >>
  60
  61   let in_hovbox ?(indent = 0) = in_a_box "pp_open_hovbox" indent
  62   and in_box ?(indent = 0) = in_a_box "pp_open_box" indent
  63
  64   let instance = object (self)
  65
  66     inherit make_module_expr
  67
  68
  69     method nargs ctxt tvars args =
  70       match tvars, args with
  71       | id::ids, ty::tys ->
  72           let format_expr id ty =
  73             <:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >> in
  74           let format_expr' id ty =
  75             <:expr< Format.pp_print_string formatter ",";
  76                     Format.pp_print_space formatter ();
  77                     $format_expr id ty$>> in
  78           let exprs = format_expr id ty :: List.map2 format_expr' ids tys in
  79           in_paren (in_hovbox ~indent:1 (seq_list exprs))
  80       | _ -> assert false
  81
  82     method tuple ctxt args =
  83       let n = List.length args in
  84       let tvars, tpatt, _ = tuple n in
  85       wrap [ <:match_case< $tpatt$ -> $self#nargs ctxt tvars args$ >> ]
  86
  87
  88     method case ctxt (name, args) =
  89       match args with
  90       | [] ->
  91           <:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >>
  92       | _ ->
  93           let tvars, patt, exp = tuple (List.length args) in
  94           let format_expr =
  95             <:expr< Format.pp_print_string formatter $str:name$;
  96                     Format.pp_print_break formatter 1 2;
  97                     $self#nargs ctxt tvars args$ >> in
  98           <:match_case< $uid:name$ $patt$ -> $in_hovbox format_expr$ >>
  99
 100     method sum ?eq ctxt tname params constraints summands =
 101       wrap (List.map (self#case ctxt) summands)
 102
 103
 104     method field ctxt (name, (vars, ty), mut) =
 105       if vars <> [] then
 106         raise (Underivable (classname ^ " cannot be derived for record types "
 107                             ^ "with polymorphic fields"));
 108       <:expr< Format.pp_print_string formatter $str:name ^ " = "$;
 109               $self#call_expr ctxt ty "format"$ formatter $lid:name$ >>
 110
 111     method record ?eq ctxt tname params constraints fields =
 112       let format_fields =
 113         List.fold_left1
 114           (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>)
 115           (List.map (self#field ctxt) fields) in
 116       let format_record =
 117         <:expr<
 118           Format.pp_print_char formatter '{';
 119           $format_fields$;
 120           Format.pp_print_char formatter '}'; >> in
 121       wrap [ <:match_case< $record_pattern fields$ -> $in_hovbox format_record$ >>]
 122
 123     method polycase ctxt : Pa_deriving_common.Type.tagspec -> Ast.match_case = function
 124       | Tag (name, []) ->
 125           let format_expr =
 126             <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$ >> in
 127           <:match_case< `$uid:name$ -> $format_expr$ >>
 128       | Tag (name, es) ->
 129           let format_expr =
 130             <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$;
 131                     $self#call_expr ctxt (`Tuple es) "format"$ formatter x >> in
 132           <:match_case< `$uid:name$ x -> $in_hovbox format_expr$ >>
 133       | Extends t ->
 134           let patt, guard, cast = cast_pattern ctxt.argmap t in
 135           let format_expr =
 136             <:expr< $self#call_expr ctxt t "format"$ formatter $cast$ >> in
 137           <:match_case< $patt$ when $guard$ -> $in_hovbox format_expr$ >>
 138
 139     method variant ctxt tname params constraints (_,tags) =
 140       wrap (List.map (self#polycase ctxt) tags @ [ <:match_case< _ -> assert false >> ])
 141
 142   end
 143
 144   let make_module_expr = instance#rhs
 145   let generate = default_generate ~make_module_expr ~make_module_type
 146   let generate_sigs = default_generate_sigs ~make_module_sig
 147   let generate_expr = instance#expr
 148
 149 end
 150
 151 module Show = Pa_deriving_common.Base.Register(Description)(InContext)