syntax/dump_class.ml

   1 (*pp camlp4orf *)
   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
   8 module InContext (L : Base.Loc) =
   9 struct
  10   open Base
  11   open Utils
  12   open Type
  13   open Camlp4.PreCast
  14   include Base.InContext(L)
  15
  16   let classname = "Dump"
  17
  18   let wrap ~atype ~dumpers ~undump =
  19     <:module_expr< struct type a = $atype$;
  20                           value to_buffer buffer = fun [ $list:dumpers$ ];
  21                           value from_stream stream = $undump$; end >>
  22
  23   let instance = object (self)
  24     inherit make_module_expr ~classname ~allow_private:false
  25
  26     method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr * Ast.expr =
  27       List.fold_right
  28         (fun (id,t) (p,u) ->
  29            <:expr< do { $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:id$; $p$ } >>,
  30            <:expr< let $lid:id$ = $mproject (self#expr ctxt t) "from_stream"$ stream in $u$ >>)
  31         exprs (<:expr<>>, <:expr< $tuple_expr (List.map (fun (id,_) -> <:expr< $lid:id$ >>) exprs)$>>)
  32
  33     method tuple ctxt ts =
  34       let atype = atype_expr ctxt (`Tuple ts)
  35       and dumpers, undump =
  36         let n = List.length ts in
  37         let pinner, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) ts) in
  38         let patt, expr = tuple n in
  39           [ <:match_case< $patt$ -> $pinner$ >> ], undump in
  40         <:module_expr< Defaults( $wrap ~atype ~dumpers ~undump$) >>
  41
  42     method polycase ctxt tagspec n : Ast.match_case * Ast.match_case =
  43       let dumpn = <:expr< Dump_int.to_buffer buffer $`int:n$ >> in
  44         match tagspec with
  45           | Tag (name, args) -> (match args with
  46               | None   -> <:match_case< `$name$ -> $dumpn$ >>,
  47                           <:match_case< $`int:n$ -> `$name$ >>
  48               | Some e -> <:match_case< `$name$ x -> do { $dumpn$;
  49                                          $mproject (self#expr ctxt e) "to_buffer"$ buffer x } >>,
  50                           <:match_case< $`int:n$ ->
  51                                         `$name$ ($mproject (self#expr ctxt e) "from_stream"$ stream) >>)
  52           | Extends t ->
  53               let patt, guard, cast = cast_pattern ctxt t in
  54                 <:match_case< $patt$ when $guard$ ->
  55                                do { $dumpn$; $mproject (self#expr ctxt t) "to_buffer"$ buffer $cast$ } >>,
  56                 <:match_case< $`int:n$ -> ($mproject (self#expr ctxt t) "from_stream"$ stream :> a) >>
  57
  58     method case ctxt (ctor,args) n =
  59       match args with
  60         | [] -> (<:match_case< $uid:ctor$ -> Dump_int.to_buffer buffer $`int:n$ >>,
  61                  <:match_case< $`int:n$ -> $uid:ctor$ >>)
  62         | _ ->
  63         let nargs = List.length args in
  64         let patt, exp = tuple nargs in
  65         let dump, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) args) in
  66         <:match_case< $uid:ctor$ $patt$ ->
  67                       do { Dump_int.to_buffer buffer $`int:n$;
  68                       $dump$ } >>,
  69         <:match_case< $`int:n$ -> let $patt$ = $undump$ in $uid:ctor$ $exp$  >>
  70
  71     method field ctxt : Type.field -> Ast.expr * Ast.expr = function
  72       | (name, _, `Mutable) ->
  73           raise (Underivable ("Dump cannot be derived for record types with mutable fields ("^name^")"))
  74       | (name, ([], t), _) ->
  75           <:expr< $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:name$ >>,
  76           <:expr< $mproject (self#expr ctxt t) "from_stream"$ stream >>
  77       | f -> raise (Underivable ("Dump cannot be derived for record types with polymorphic fields"))
  78
  79     method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands =
  80       let msg = "Dump: unexpected tag %d at character %d when deserialising " ^ tname in
  81       let dumpers, undumpers =
  82         List.split (List.mapn (self#case ctxt) summands) in
  83         wrap ~atype:(atype ctxt decl) ~dumpers
  84           ~undump:<:expr< match Dump_int.from_stream stream with [ $list:undumpers$
  85                                 | n -> raise (Dump_error
  86                                                 (Printf.sprintf $str:msg$ n
  87                                                    (Stream.count stream))) ] >>
  88
  89     method record ?eq ctxt decl fields =
  90        let dumpers, undumpers =
  91          List.split (List.map (self#field ctxt) fields) in
  92        let undump =
  93          List.fold_right2
  94            (fun (field,_,_) undumper e ->
  95               <:expr< let $lid:field$ = $undumper$ in $e$ >>)
  96            fields
  97            undumpers
  98            (record_expression fields) in
  99          wrap ~atype:(atype ctxt decl) ~undump
 100                ~dumpers:[ <:match_case< $record_pattern fields$ -> $List.fold_left1 seq dumpers$ >>]
 101
 102     method variant ctxt decl (_, tags) =
 103       let msg = "Dump: unexpected tag %d at character %d when deserialising polymorphic variant" in
 104       let dumpers, undumpers =
 105         List.split (List.mapn (self#polycase ctxt) tags) in
 106         wrap ~atype:(atype ctxt decl) ~dumpers:(dumpers @ [ <:match_case< _ -> assert False >>])
 107           ~undump:<:expr< match Dump_int.from_stream stream with [ $list:undumpers$
 108                                 | n -> raise (Dump_error
 109                                                 (Printf.sprintf $str:msg$ n
 110                                                    (Stream.count stream))) ] >>
 111   end
 112 end
 113
 114 let _ = Base.register "Dump"
 115   ((fun (loc, context, decls) ->
 116      let module M = InContext(struct let loc = loc end) in
 117        M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname
 118          ~default_module:"Defaults" ()),
 119    (fun (loc, context, decls) ->
 120       let module M = InContext(struct let loc = loc end) in
 121         M.gen_sigs ~context ~decls ~classname:M.classname))