l4/pkg/ocaml/contrib/camlp4/examples/fancy_lambda_quot.ml

   1 (* module LambdaSyntax = struct
   2   module Loc = Camlp4.PreCast.Loc
   3   type 'a antiquotable =
   4     | Val of Loc.t * 'a
   5     | Ant of Loc.t * string
   6   type term' =
   7     | Lam of var * term
   8     | App of term * term
   9     | Var of var
  10     | Int of int antiquotable
  11     |+ Why you don't want an antiquotation case here:
  12      *   Basically it seems natural that since an antiquotation of expression
  13      *   can be at any expression place. One can be a
  14      *   .... in fact not I not against that...
  15     | Anti of Loc.t * string
  16      +|
  17   and term = term' antiquotable
  18   and var = string antiquotable
  19 end                                                                              *)
  20 module Antiquotable = struct
  21   module Loc = Camlp4.PreCast.Loc
  22   type 'a t =
  23     | Val of Loc.t * 'a
  24     | Ant of Loc.t * string
  25 end
  26 module Identity_type_functor = struct
  27   type 'a t = 'a
  28 end
  29 module MakeLambdaSyntax(Node : sig type 'a t end) = struct
  30   type term' =
  31     | Lam of var * term
  32     | App of term * term
  33     | Var of var
  34     | Int of num
  35   and term = term'  Node.t
  36   and num  = int    Node.t
  37   and var  = string Node.t
  38 end
  39 module AntiquotableLambdaSyntax = MakeLambdaSyntax(Antiquotable);;
  40 module LambdaSyntax = MakeLambdaSyntax(Identity_type_functor);;
  41 module LambdaParser = struct
  42   open Antiquotable;;
  43   open AntiquotableLambdaSyntax;;
  44   open Camlp4.PreCast;;
  45
  46   module LambdaGram = MakeGram(Lexer);;
  47
  48   let term = LambdaGram.Entry.mk "term";;
  49   let term_eoi = LambdaGram.Entry.mk "lambda term quotation";;
  50
  51   Camlp4_config.antiquotations := true;;
  52
  53   let mkLam _loc v t = Val(_loc, Lam(v, t));;
  54   let mkApp _loc f x = Val(_loc, App(f, x));;
  55   let mkVar _loc x   = Val(_loc, Var(x));;
  56   let mkInt _loc v   = Val(_loc, Int(v));;
  57
  58   EXTEND LambdaGram
  59     GLOBAL: term term_eoi;
  60     term:
  61       [ "top"
  62         [ "fun"; v = var; "->"; t = term -> mkLam _loc v t ]
  63       | "app"
  64         [ t1 = SELF; t2 = SELF           -> mkApp _loc t1 t2 ]
  65       | "simple"
  66         [ `ANTIQUOT((""|"term"), a)      -> Ant(_loc, a)
  67         | i = int                        -> mkInt _loc i
  68         | v = var                        -> mkVar _loc v
  69         | "("; t = term; ")"             -> t ]
  70       ];
  71     var:
  72       [[ v = LIDENT              -> Val(_loc, v)
  73       | `ANTIQUOT((""|"var"), a) -> Ant(_loc, a)
  74       ]];
  75     int:
  76       [[ `INT(i, _)              -> Val(_loc, i)
  77       | `ANTIQUOT((""|"int"), a) -> Ant(_loc, a)
  78       ]];
  79     term_eoi:
  80       [[ t = term; `EOI -> t ]];
  81   END;;
  82
  83   let parse_string = LambdaGram.parse_string term_eoi
  84 end
  85 module LambdaLifter = struct
  86   open Antiquotable;;
  87   open AntiquotableLambdaSyntax;;
  88   module CamlSyntax =
  89     Camlp4OCamlParser.Make(
  90       Camlp4OCamlRevisedParser.Make(
  91         Camlp4.PreCast.Syntax
  92       )
  93     );;
  94   module Ast = Camlp4.PreCast.Ast
  95   let expr_of_string = CamlSyntax.Gram.parse_string CamlSyntax.expr_eoi;;
  96   let patt_of_string = CamlSyntax.Gram.parse_string CamlSyntax.patt_eoi;;
  97
  98   (*
  99   << fun x -> $3$ >> -> Lam(VAtom"x", 3)
 100
 101   (* compilo.ml -pp lam.cmo *)
 102   match t with
 103   | << (fun $x$ -> $e1$) $e2$ >> -> << $subst ...$ >>
 104   *)
 105
 106   (* This part can be generated use SwitchValRepr *)
 107   let rec term_to_expr = function
 108     | Val(_loc, Lam(v, t))   -> <:expr< Lam($var_to_expr v$, $term_to_expr t$) >>
 109     | Val(_loc, App(t1, t2)) -> <:expr< App($term_to_expr t1$, $term_to_expr t2$) >>
 110     | Val(_loc, Var(v))      -> <:expr< Var($var_to_expr v$) >>
 111     | Val(_loc, Int(i))      -> <:expr< Int($int_to_expr i$) >>
 112     | Ant(_loc, a)           -> expr_of_string _loc a
 113   and var_to_expr = function
 114     | Val(_loc, v) -> <:expr< $str:v$ >>
 115     | Ant(_loc, s) -> expr_of_string _loc s
 116   and int_to_expr = function
 117     | Val(_loc, v) -> <:expr< $`int:v$ >>
 118     | Ant(_loc, s) -> expr_of_string _loc s
 119   ;;
 120
 121   let rec term_to_patt = function
 122     | Val(_loc, Lam(v, t)) -> <:patt< Lam($var_to_patt v$, $term_to_patt t$) >>
 123     | Val(_loc, App(t1, t2)) -> <:patt< App($term_to_patt t1$, $term_to_patt t2$) >>
 124     | Val(_loc, Var(v)) -> <:patt< Var($var_to_patt v$) >>
 125     | Val(_loc, Int(i)) -> <:patt< Int($int_to_patt i$) >>
 126     | Ant(_loc, a) -> patt_of_string _loc a
 127   and var_to_patt = function
 128     | Val(_loc, v) -> <:patt< $str:v$ >>
 129     | Ant(_loc, s) -> patt_of_string _loc s
 130   and int_to_patt = function
 131     | Val(_loc, v) -> <:patt< $`int:v$ >>
 132     | Ant(_loc, s) -> patt_of_string _loc s
 133   ;;
 134
 135     (*
 136 Arrow(Var"a", Var"b")
 137 <:typ< 'a -> 'b >>
 138
 139   let a = ...
 140   let b = ...
 141   let ( ^-> ) t1 t2 = Arrow(t1, t2)
 142   a ^-> b
 143   *)
 144 end
 145 module LambadExpander = struct
 146   module Q = Camlp4.PreCast.Syntax.Quotation;;
 147   let expand_lambda_quot_expr loc _loc_name_opt quotation_contents =
 148     LambdaLifter.term_to_expr
 149       (LambdaParser.parse_string loc quotation_contents)
 150   ;;
 151   Q.add "lam" Q.DynAst.expr_tag expand_lambda_quot_expr;;
 152   let expand_lambda_quot_patt loc _loc_name_opt quotation_contents =
 153     LambdaLifter.term_to_patt
 154       (LambdaParser.parse_string loc quotation_contents)
 155   ;;
 156   Q.add "lam" Q.DynAst.patt_tag expand_lambda_quot_patt;;
 157
 158   Q.default := "lam";;
 159 end