syntax/bounded_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
   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 = "Bounded"
  17
  18   let instance = object (self)
  19     inherit make_module_expr ~classname ~allow_private:false
  20
  21     method tuple ctxt ts =
  22     let minBounds, maxBounds =
  23       List.split (List.map
  24                     (fun t -> let e = self#expr ctxt t in
  25                        <:expr< let module M = $e$ in M.min_bound >>,
  26                        <:expr< let module M = $e$ in M.max_bound >>) ts) in
  27     <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$
  28                           let min_bound = $tuple_expr minBounds$
  29                           let max_bound = $tuple_expr maxBounds$ end >>
  30
  31     method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands =
  32     let names = ListLabels.map summands
  33         ~f:(function
  34               | (name,[]) -> name
  35               | (name,_) -> raise (Underivable ("Bounded cannot be derived for the type "^
  36                                                   tname ^" because the constructor "^
  37                                                   name^" is not nullary"))) in
  38         <:module_expr< struct type a = $atype ctxt decl$
  39                        let min_bound = $uid:List.hd names$
  40                        and max_bound = $uid:List.last names$ end >>
  41
  42     method variant ctxt decl (_, tags) =
  43     let names = ListLabels.map tags
  44         ~f:(function
  45               | Tag (name, None) -> name
  46              | Tag (name, _) -> raise (Underivable ("Bounded cannot be derived because the tag "^
  47                                                       name^" is not nullary"))
  48              | _ -> raise (Underivable ("Bounded cannot be derived for this "
  49                                         ^"polymorphic variant type"))) in
  50       <:module_expr< struct type a = $atype ctxt decl$
  51                      let min_bound = `$List.hd names$
  52                      and max_bound = `$List.last names$ end >>
  53
  54   (* should perhaps implement this one *)
  55   method record ?eq _ (tname,_,_,_,_) = raise (Underivable ("Bounded cannot be derived for record types (i.e. "^
  56                                                      tname^")"))
  57   end
  58 end
  59
  60 let _ = Base.register "Bounded"
  61   ((fun (loc, context, decls) ->
  62      let module M = InContext(struct let loc = loc end) in
  63        M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ()),
  64    (fun (loc, context, decls) ->
  65       let module M = InContext(struct let loc = loc end) in
  66         M.gen_sigs ~context ~decls ~classname:M.classname))