syntax/enum_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 = "Enum"
  17
  18   let instance = object(self)
  19     inherit make_module_expr ~classname ~allow_private:false
  20
  21     method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands =
  22     let numbering =
  23       List.fold_right2
  24         (fun n ctor rest ->
  25            match ctor with
  26              | (name, []) -> <:expr< [ ($uid:name$, $`int:n$) :: $rest$ ] >>
  27              | (name,_) -> raise (Underivable ("Enum cannot be derived for the type "^
  28                                   tname ^" because the constructor "^
  29                                   name^" is not nullary")))
  30         (List.range 0 (List.length summands))
  31         summands
  32         <:expr< [] >> in
  33       <:module_expr< Deriving_Enum.Defaults(struct type a = $atype ctxt decl$; value numbering = $numbering$; end) >>
  34
  35     method variant ctxt decl (_, tags) =
  36     let numbering =
  37       List.fold_right2
  38         (fun n tagspec rest ->
  39            match tagspec with
  40              | Tag (name, None) -> <:expr< [ (`$name$, $`int:n$) :: $rest$ ] >>
  41              | Tag (name, _) -> raise (Underivable ("Enum cannot be derived because the tag "^
  42                                                       name^" is not nullary"))
  43              | _ -> raise (Underivable ("Enum cannot be derived for this "
  44                                         ^"polymorphic variant type")))
  45         (List.range 0 (List.length tags))
  46         tags
  47         <:expr< [] >> in
  48       <:module_expr< Deriving_Enum.Defaults(struct type a = $atype ctxt decl$; value numbering = $numbering$; end) >>
  49
  50     method tuple context _ = raise (Underivable "Enum cannot be derived for tuple types")
  51     method record ?eq _ (tname,_,_,_,_) = raise (Underivable
  52                                                  ("Enum cannot be derived for record types (i.e. "^
  53                                                     tname^")"))
  54   end
  55 end
  56
  57 let _ = Base.register "Enum"
  58   ((fun (loc, context, decls) ->
  59      let module M = InContext(struct let loc = loc end) in
  60        M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ()),
  61    (fun (loc, context, decls) ->
  62       let module M = InContext(struct let loc = loc end) in
  63         M.gen_sigs ~context ~decls ~classname:M.classname))