syntax/extend.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 (* Extend the OCaml grammar to include the `deriving' clause after
   9    type declarations in structure and signatures. *)
  10
  11 open Utils
  12
  13 module Deriving (Syntax : Camlp4.Sig.Camlp4Syntax) =
  14 struct
  15   open Camlp4.PreCast
  16
  17   include Syntax
  18
  19   let fatal_error loc msg =
  20     Syntax.print_warning loc msg;
  21     exit 1
  22
  23   let display_errors loc f p =
  24     try
  25       f p
  26     with
  27         Base.Underivable msg | Failure msg ->
  28           fatal_error loc msg
  29
  30   let derive proj (loc : Loc.t) tdecls classname =
  31     let context = display_errors loc (Base.setup_context loc) tdecls in
  32       display_errors loc
  33         (proj (Base.find classname)) (loc, context, tdecls)
  34
  35   let derive_str loc (tdecls : Type.decl list) classname : Ast.str_item =
  36     derive fst loc tdecls classname
  37
  38   let derive_sig loc tdecls classname : Ast.sig_item =
  39     derive snd loc tdecls classname
  40
  41
  42   DELETE_RULE Gram str_item: "type"; type_declaration END
  43   DELETE_RULE Gram sig_item: "type"; type_declaration END
  44
  45   open Ast
  46
  47   EXTEND Gram
  48   str_item:
  49   [[ "type"; types = type_declaration -> <:str_item< type $types$ >>
  50     | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP ","; ")" ->
  51         let decls = display_errors loc Type.Translate.decls types in
  52         let module U = Type.Untranslate(struct let loc = loc end) in
  53         let tdecls = List.map U.decl decls in
  54           <:str_item< type $list:tdecls$ $list:List.map (derive_str loc decls) cl$ >>
  55    ]]
  56   ;
  57   sig_item:
  58   [[ "type"; types = type_declaration -> <:sig_item< type $types$ >>
  59    | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP "," ; ")" ->
  60        let decls  = display_errors loc Type.Translate.decls types in
  61        let module U = Type.Untranslate(struct let loc = loc end) in
  62        let tdecls = List.concat_map U.sigdecl decls in
  63        let ms = List.map (derive_sig loc decls) cl in
  64          <:sig_item< type $list:tdecls$ $list:ms$ >> ]]
  65   ;
  66   END
  67
  68   EXTEND Gram
  69   expr: LEVEL "simple"
  70   [
  71   [e1 = val_longident ; "<" ; t = ctyp; ">" ->
  72      match e1 with
  73        | <:ident< $uid:classname$ . $lid:methodname$ >> ->
  74          if not (Base.is_registered classname) then
  75            fatal_error loc ("deriving: "^ classname ^" is not a known `class'")
  76          else
  77            let module U = Type.Untranslate(struct let loc = loc end) in
  78            let binding = Ast.TyDcl (loc, "inline", [], t, []) in
  79            let decls = display_errors loc Type.Translate.decls binding in
  80              if List.exists Base.contains_tvars_decl decls then
  81                fatal_error loc ("deriving: type variables cannot be used in `method' instantiations")
  82              else
  83                let tdecls = List.map U.decl decls in
  84                let m = derive_str loc decls classname in
  85                  <:expr< let module $uid:classname$ =
  86                              struct
  87                                type $list:tdecls$
  88                                $m$
  89                                include $uid:classname ^ "_inline"$
  90                              end
  91                           in $uid:classname$.$lid:methodname$ >>
  92        | _ ->
  93            fatal_error loc ("deriving: this looks a bit like a method application, but "
  94                             ^"the syntax is not valid");
  95   ]];
  96   END
  97
  98 end
  99
 100 module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Deriving)