syntax/typeable_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 Type
  11   open Base
  12   open Camlp4.PreCast
  13   include Base.InContext(L)
  14
  15   let classname = "Typeable"
  16
  17   let mkName : name -> string =
  18     let file_name, sl, _, _, _, _, _, _ = Loc.to_tuple loc in
  19       Printf.sprintf "%s_%d_%f_%s"
  20         file_name sl (Unix.gettimeofday ())
  21
  22   let gen ?eq ctxt ((tname,_,_,_,_) as decl : Type.decl) _ =
  23     let paramList =
  24       List.fold_right
  25         (fun (p,_) cdr ->
  26              <:expr< [ $uid:NameMap.find p ctxt.argmap$.type_rep :: $cdr$ ] >>)
  27         ctxt.params
  28       <:expr< [] >>
  29     in <:module_expr< struct type a = $atype ctxt decl$;
  30           value type_rep = TypeRep.mkFresh $str:mkName tname$ $paramList$; end >>
  31
  32   let tup ctxt ts mexpr expr =
  33       let params =
  34         expr_list
  35           (List.map (fun t -> <:expr< let module M = $expr ctxt t$
  36                                        in $mexpr$ >>) ts) in
  37         <:module_expr< Defaults(struct type a = $atype_expr ctxt (`Tuple ts)$;
  38                                        value type_rep = Typeable.TypeRep.mkTuple $params$; end) >>
  39
  40   let instance = object(self)
  41     inherit make_module_expr ~classname ~allow_private:true
  42
  43     method tuple ctxt ts = tup ctxt ts <:expr< M.type_rep >> (self#expr)
  44     method sum = gen
  45     method record = gen
  46     method variant ctxt decl (_,tags) =
  47     let tags, extends =
  48       List.fold_left
  49         (fun (tags, extends) -> function
  50            | Tag (l, None)  -> <:expr< [ ($str:l$, None) :: $tags$ ] >>, extends
  51            | Tag (l,Some t) ->
  52                <:expr< [ ($str:l$, Some $mproject (self#expr ctxt t) "type_rep"$) :: $tags$ ] >>,
  53                extends
  54            | Extends t ->
  55                tags,
  56                <:expr< [ $mproject (self#expr ctxt t) "type_rep"$ :: $extends$ ] >>)
  57         (<:expr< [] >>, <:expr< [] >>) tags in
  58       <:module_expr< Defaults(
  59         struct type a = $atype ctxt decl$;
  60                value type_rep = Typeable.TypeRep.mkPolyv $tags$ $extends$;
  61         end) >>
  62   end
  63 end
  64
  65 let _ = Base.register "Typeable"
  66   ((fun (loc, context, decls) ->
  67      let module M = InContext(struct let loc = loc end) in
  68        M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname
  69          ~default_module:"Defaults" ()),
  70   (fun (loc, context, decls) ->
  71      let module M = InContext(struct let loc = loc end) in
  72        M.gen_sigs ~context ~decls ~classname:M.classname))