/usr/lib/ocaml/deriving/show_class.ml is in libderiving-ocsigen-ocaml-dev 0.7.1-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | (* Copyright Jeremy Yallop 2007.
This file is free software, distributed under the MIT license.
See the file COPYING for details.
*)
open Pa_deriving_common
open Utils
module Description : Defs.ClassDescription = struct
let classname = "Show"
let default_module = Some "Defaults"
let runtimename = "Deriving_Show"
let alpha = Some "Show_unprintable"
let allow_private = true
let predefs = [
["int" ], ["Deriving_Show";"int"];
["bool" ], ["Deriving_Show";"bool"];
["unit" ], ["Deriving_Show";"unit"];
["char" ], ["Deriving_Show";"char"];
["int32" ], ["Deriving_Show";"int32"];
["Int32";"t"], ["Deriving_Show";"int32"];
["int64" ], ["Deriving_Show";"int64"];
["Int64";"t"], ["Deriving_Show";"int64"];
["nativeint"], ["Deriving_Show";"nativeint"];
["float" ], ["Deriving_Show";"float"];
["num" ], ["Deriving_num" ;"num"];
["string" ], ["Deriving_Show";"string"];
["list" ], ["Deriving_Show";"list"];
["ref" ], ["Deriving_Show";"ref"];
["option" ], ["Deriving_Show";"option"];
["array" ], ["Deriving_Show";"array"];
]
let depends = []
end
module Builder(Generator : Defs.Generator) = struct
open Generator.Loc
open Camlp4.PreCast
open Description
module Helpers = Generator.AstHelpers
let wrap formatter =
[ <:str_item< let format formatter : a -> unit = function $list:formatter$ >> ]
let in_a_box box i e =
<:expr<
Format.$lid:box$ formatter $`int:i$;
$e$;
Format.pp_close_box formatter () >>
let in_paren e =
<:expr<
Format.pp_print_string formatter "(";
$e$;
Format.pp_print_string formatter ")" >>
let in_hovbox ?(indent = 0) = in_a_box "pp_open_hovbox" indent
and in_box ?(indent = 0) = in_a_box "pp_open_box" indent
let generator = (object (self)
inherit Generator.generator
method proxy () =
None, [ <:ident< format >>;
<:ident< format_list >>;
<:ident< show >>;
<:ident< show_list >>; ]
method nargs ctxt tvars args =
match tvars, args with
| [id], [ty] ->
<:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >>
| id::ids, ty::tys ->
let format_expr id ty =
<:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >> in
let format_expr' id ty =
<:expr< Format.pp_print_string formatter ",";
Format.pp_print_space formatter ();
$format_expr id ty$>> in
let exprs = format_expr id ty :: List.map2 format_expr' ids tys in
in_paren (in_hovbox ~indent:1 (Helpers.seq_list exprs))
| _ -> assert false
method tuple ctxt args =
let tvars, tpatt, _ = Helpers.tuple (List.length args) in
wrap [ <:match_case< $tpatt$ -> $self#nargs ctxt tvars args$ >> ]
method case ctxt (name, args) =
match args with
| [] ->
<:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >>
| _ ->
let tvars, patt, exp = Helpers.tuple (List.length args) in
let format_expr =
<:expr< Format.pp_print_string formatter $str:name$;
Format.pp_print_break formatter 1 2;
$self#nargs ctxt tvars args$ >> in
<:match_case< $uid:name$ $patt$ -> $in_hovbox format_expr$ >>
method sum ?eq ctxt tname params constraints summands =
wrap (List.map (self#case ctxt) summands)
method gsum ?eq ctxt tname params constraints gsummands =
let summands = List.map (fun (name, args, _) -> (name, args)) gsummands in
wrap (List.map (self#case ctxt) summands)
method field ctxt (name, ty, mut) =
<:expr< Format.pp_print_string formatter $str:name ^ " = "$;
$self#call_poly_expr ctxt ty "format"$ formatter $lid:name$ >>
method record ?eq ctxt tname params constraints fields =
let format_fields =
List.fold_left1
(fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>)
(List.map (self#field ctxt) fields) in
let format_record =
<:expr<
Format.pp_print_char formatter '{';
$format_fields$;
Format.pp_print_char formatter '}'; >> in
wrap [ <:match_case< $Helpers.record_pattern fields$ -> $in_hovbox format_record$ >>]
method polycase ctxt has_guard : Pa_deriving_common.Type.tagspec -> Ast.match_case = function
| Type.Tag (name, []) ->
let format_expr =
<:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$ >> in
<:match_case< `$uid:name$ -> $format_expr$ >>
| Type.Tag (name, es) ->
let format_expr =
<:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$;
$self#call_expr ctxt (`Tuple es) "format"$ formatter x >> in
<:match_case< `$uid:name$ x -> $in_hovbox format_expr$ >>
| Type.Extends t ->
let patt, guard, cast = Generator.cast_pattern ctxt t in
let format_expr =
<:expr< $self#call_expr ctxt t "format"$ formatter $cast$ >> in
if guard <> <:expr< >> then has_guard := true;
<:match_case< $patt$ when $guard$ -> $in_hovbox format_expr$ >>
method variant ctxt tname params constraints (_,tags) =
let has_guard = ref false in
let body = List.map (self#polycase ctxt has_guard) tags in
wrap (if !has_guard
then body @ [ <:match_case< _ -> assert false >> ]
else body)
end :> Generator.generator)
let generate = Generator.generate generator
let generate_sigs = Generator.generate_sigs generator
end
include Base.RegisterClass(Description)(Builder)
|