3 (* Copyright Jeremy Yallop 2007.
4 This file is free software, distributed under the MIT license.
5 See the file COPYING for details.
7 module InContext
(L
: Base.Loc
) =
13 include Base.InContext
(L
)
15 let classname = "Show"
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 >>
23 Format.$lid
:box$ formatter
0;
25 Format.pp_close_box formatter
() >>
27 let in_hovbox = in_a_box "pp_open_hovbox" and in_box
= in_a_box "pp_open_box"
30 let instance = object (self
)
31 inherit make_module_expr ~
classname ~allow_private
:true
33 method polycase ctxt
: Type.tagspec
-> Ast.match_case
= function
35 <:match_case
< `$uid
:name$
->
36 Format.pp_print_string formatter $str
:"`" ^ name ^
" "$
>>
37 | Tag
(name
, Some e
) ->
38 <:match_case
< `$uid
:name$ x
->
40 Format.pp_print_string formatter $str
:"`" ^ name ^
" "$
;
41 $mproject
(self#expr ctxt e
) "format"$ formatter x
>>$
>>
43 let patt, guard
, cast
= cast_pattern ctxt t
in
45 $
patt$
when $guard$
->
46 $
in_hovbox <:expr
< $mproject
(self#expr ctxt t
) "format"$ formatter $cast$
>>$
>>
48 method nargs ctxt
(exprs
: (name
* Type.expr
) list
) : Ast.expr
=
52 <:expr< $mproject (self#expr ctxt t) "format"$ formatter $lid:id$ >>
56 "@[<hov 1>("^
String.concat
",@;" (List.map
(fun _
-> "%a") exprs
) ^
")@]" in
59 <:expr
< $f$ $mproject
(self#expr ctxt t
) "format"$ $lid
:id$
>>)
60 <:expr
< Format.fprintf formatter $str
:fmt$
>>
63 method tuple ctxt args
=
64 let n = List.length args
in
65 let tpatt, _
= tuple
n in
66 <:module_expr
< Defaults
(struct type a
= $atype_expr ctxt
(`Tuple args
)$
67 let format formatter $
tpatt$
=
69 (List.mapn
(fun t
n -> Printf.sprintf
"v%d" n, t
) args
)$
end) >>
71 method case ctxt
: Type.summand
-> Ast.match_case
=
74 | [] -> <:match_case
< $uid
:name$
-> Format.pp_print_string formatter $str
:name$
>>
76 let patt, exp
= tuple
(List.length args
) in
80 Format.pp_print_string formatter $str
:name$
;
81 Format.pp_print_break formatter
1 2;
82 $self#nargs ctxt
(List.mapn
(fun t
n -> Printf.sprintf
"v%d" n, t
) args
)$
>>$
>>
84 method field ctxt
: Type.field
-> Ast.expr
= function
85 | (name
, ([], t
), _
) -> <:expr
< Format.pp_print_string formatter $str
:name ^
" ="$
;
86 $mproject
(self#expr ctxt t
) "format"$ formatter $lid
:name$
>>
87 | f
-> raise
(Underivable
("Show cannot be derived for record types with polymorphic fields"))
89 method sum ?eq ctxt decl summands
= wrap ctxt decl
(List.map
(self#case ctxt
) summands
)
91 method record ?eq ctxt decl fields
= wrap ctxt decl
[ <:match_case
<
92 $record_pattern fields$
-> $
in_hovbox
94 Format.pp_print_char formatter '
{'
;
96 (fun l r
-> <:expr
< $l$
; Format.pp_print_string formatter
"; "; $r$
>>)
97 (List.map
(self#field ctxt
) fields
)$
;
98 Format.pp_print_char formatter '
}'
; >>$
>>]
100 method variant ctxt decl
(_
,tags
) = wrap ctxt decl
(List.map
(self#polycase ctxt
) tags
101 @ [ <:match_case
< _
-> assert false >> ])
105 let _ = Base.register
"Show"
106 ((fun (loc
, context
, decls
) ->
107 let module M
= InContext
(struct let loc = loc end) in
108 M.generate ~context ~decls ~make_module_expr
:M.instance#rhs ~
classname:M.classname
109 ~default_module
:"Defaults" ()),
110 (fun (loc, context
, decls
) ->
111 let module M
= InContext
(struct let loc = loc end) in
112 M.gen_sigs ~
classname:M.classname ~context ~decls
))