syntax/show_class.ml

   1 (*pp camlp4of *)
   2
   3 (* Copyright Jeremy Yallop 2007.
   4    This file is free software, distributed under the MIT license.
   5    See the file COPYING for details.
   6 *)
   7 module InContext (L : Base.Loc) =
   8 struct
   9   open Base
  10   open Utils
  11   open Type
  12   open Camlp4.PreCast
  13   include Base.InContext(L)
  14
  15   let classname = "Show"
  16
  17   let wrap (ctxt:Base.context) (decl : Type.decl) matches = <:module_expr<
  18   struct type a = $atype ctxt decl$
  19          let format formatter = function $list:matches$ end >>
  20
  21   let in_a_box box e =
  22     <:expr<
  23       Format.$lid:box$ formatter 0;
  24       $e$;
  25       Format.pp_close_box formatter () >>
  26
  27   let in_hovbox = in_a_box "pp_open_hovbox" and in_box = in_a_box "pp_open_box"
  28
  29
  30   let instance = object (self)
  31     inherit make_module_expr ~classname ~allow_private:true
  32
  33     method polycase ctxt : Type.tagspec -> Ast.match_case = function
  34       | Tag (name, None) ->
  35           <:match_case< `$uid:name$ ->
  36                         Format.pp_print_string formatter $str:"`" ^ name ^" "$ >>
  37       | Tag (name, Some e) ->
  38           <:match_case< `$uid:name$ x ->
  39                          $in_hovbox <:expr<
  40                             Format.pp_print_string formatter $str:"`" ^ name ^" "$;
  41                             $mproject (self#expr ctxt e) "format"$ formatter x >>$ >>
  42       | Extends t ->
  43           let patt, guard, cast = cast_pattern ctxt t in
  44             <:match_case<
  45               $patt$ when $guard$ ->
  46               $in_hovbox <:expr< $mproject (self#expr ctxt t) "format"$ formatter $cast$ >>$ >>
  47
  48     method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr =
  49       match exprs with
  50         | [id,t] ->
  51               <:expr< $mproject (self#expr ctxt t) "format"$ formatter $lid:id$ >>
  52         | exprs ->
  53             let fmt =
  54               "@[<hov 1>("^ String.concat ",@;" (List.map (fun _ -> "%a") exprs) ^")@]" in
  55               List.fold_left
  56                 (fun f (id, t) ->
  57                    <:expr< $f$ $mproject (self#expr ctxt t) "format"$ $lid:id$ >>)
  58                 <:expr< Format.fprintf formatter $str:fmt$ >>
  59                 exprs
  60
  61     method tuple ctxt args =
  62       let n = List.length args in
  63       let tpatt, _ = tuple n in
  64       <:module_expr< Defaults (struct type a = $atype_expr ctxt (`Tuple args)$
  65                             let format formatter $tpatt$ =
  66                               $self#nargs ctxt
  67                                 (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ end) >>
  68
  69     method case ctxt : Type.summand -> Ast.match_case =
  70       fun (name, args) ->
  71         match args with
  72           | [] -> <:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >>
  73           | _ ->
  74               let patt, exp = tuple (List.length args) in
  75                 <:match_case<
  76                   $uid:name$ $patt$ ->
  77                   $in_hovbox <:expr<
  78                     Format.pp_print_string formatter $str:name$;
  79                 Format.pp_print_break formatter 1 2;
  80                 $self#nargs ctxt (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ >>$ >>
  81
  82     method field ctxt : Type.field -> Ast.expr = function
  83       | (name, ([], t), _) -> <:expr< Format.pp_print_string formatter $str:name ^ " ="$;
  84                                       $mproject (self#expr ctxt t) "format"$ formatter $lid:name$ >>
  85       | f -> raise (Underivable ("Show cannot be derived for record types with polymorphic fields"))
  86
  87     method sum ?eq ctxt decl summands = wrap ctxt decl (List.map (self#case ctxt) summands)
  88
  89     method record ?eq ctxt decl fields = wrap ctxt decl [ <:match_case<
  90       $record_pattern fields$ -> $in_hovbox
  91        <:expr<
  92           Format.pp_print_char formatter '{';
  93           $List.fold_left1
  94             (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>)
  95             (List.map (self#field ctxt) fields)$;
  96           Format.pp_print_char formatter '}'; >>$ >>]
  97
  98     method variant ctxt decl (_,tags) = wrap ctxt decl (List.map (self#polycase ctxt) tags
  99                                                         @ [ <:match_case< _ -> assert false >> ])
 100   end
 101 end
 102
 103 let _ = Base.register "Show"
 104   ((fun (loc, context, decls) ->
 105       let module M = InContext(struct let loc = loc end) in
 106         M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname
 107           ~default_module:"Defaults" ()),
 108    (fun (loc, context, decls) ->
 109       let module M = InContext(struct let loc = loc end) in
 110         M.gen_sigs ~classname:M.classname ~context ~decls))