syntax/extend.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 (* 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 (*
  69   let pr = print_endline
  70   let pr2 x y = pr (x ^ " " ^ y)
  71 *)
  72   let mk_anti ?(c = "") n s = "\\$"^n^c^":"^s
  73
  74   let derive_ast loc classname methodname t =
  75 (*
  76   EXTEND Gram
  77   expr: LEVEL "simple"
  78   [
  79   [e1 = TRY val_longident ; "<" ; t = ctyp; ">" ->
  80      match e1 with
  81        | <:ident< $uid:classname$ . $lid:methodname$ >> ->
  82 *)
  83          if not (Base.is_registered classname) then
  84            fatal_error loc ("deriving: "^ classname ^" is not a known `class'")
  85          else
  86            let module U = Type.Untranslate(struct let loc = loc end) in
  87            let binding = Ast.TyDcl (loc, "inline", [], t, []) in
  88            let decls = display_errors loc Type.Translate.decls binding in
  89              if List.exists Base.contains_tvars_decl decls then
  90                fatal_error loc ("deriving: type variables cannot be used in `method' instantiations")
  91              else
  92                let tdecls = List.map U.decl decls in
  93                let m = derive_str loc decls classname in
  94                  <:expr< let module $uid:classname$ =
  95                              struct
  96                                type $list:tdecls$;
  97                                $m$;
  98                                include $uid:classname ^ "_inline"$;
  99                              end
 100                           in $uid:classname$.$lid:methodname$ >>
 101
 102   try
 103   DELETE_RULE Gram expr: val_longident END;
 104   with Not_found -> () (* ocaml >= 3.12.0 *)
 105 ;;
 106
 107   EXTEND Gram
 108   GLOBAL: expr;
 109   expr: LEVEL "simple"
 110   [[
 111    a = ident2 -> match a with
 112                  | `Ident i -> <:expr< $id:i$ >>
 113                  | `Deriving (c,m,t) -> derive_ast loc c m t
 114   ]];
 115   ident2:
 116     [ [ `ANTIQUOT ((""|"id"|"anti"|"list" as n),s) ->
 117           `Ident <:ident< $anti:mk_anti ~c:"ident" n s$ >>
 118       | i = a_UIDENT -> (*pr2 "UID" i;*) `Ident <:ident< $uid:i$ >>
 119       | i = a_LIDENT -> (*pr2 "LID" i;*) `Ident <:ident< $lid:i$ >>
 120       | i = a_UIDENT; "."; j = a_LIDENT; "<"; t = ctyp; ">" -> (*pr "RULE";*) `Deriving (i,j,t)
 121       | i = a_UIDENT; "."; j = a_LIDENT -> `Ident <:ident< $uid:i$.$lid:j$ >>
 122       | `ANTIQUOT ((""|"id"|"anti"|"list" as n),s); "."; i = ident ->
 123           `Ident <:ident< $anti:mk_anti ~c:"ident" n s$.$i$ >>
 124       | i = a_UIDENT; "."; j = ident -> (*pr2 "COMPOSE" i;*) `Ident <:ident< $uid:i$.$j$ >> ] ]
 125   ;
 126   END
 127
 128 end
 129
 130 module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Deriving)
 131