(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Loc : Sig.Loc)
: Sig.Camlp4Ast with module Loc = Loc
= struct
module Loc = Loc;
module Ast = struct
include Sig.MakeCamlp4Ast Loc;
value safe_string_escaped s =
if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s
else String.escaped s;
end;
include Ast;
external loc_of_ctyp : ctyp -> Loc.t = "%field0";
external loc_of_patt : patt -> Loc.t = "%field0";
external loc_of_expr : expr -> Loc.t = "%field0";
external loc_of_module_type : module_type -> Loc.t = "%field0";
external loc_of_module_expr : module_expr -> Loc.t = "%field0";
external loc_of_sig_item : sig_item -> Loc.t = "%field0";
external loc_of_str_item : str_item -> Loc.t = "%field0";
external loc_of_class_type : class_type -> Loc.t = "%field0";
external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0";
external loc_of_class_expr : class_expr -> Loc.t = "%field0";
external loc_of_class_str_item : class_str_item -> Loc.t = "%field0";
external loc_of_with_constr : with_constr -> Loc.t = "%field0";
external loc_of_binding : binding -> Loc.t = "%field0";
external loc_of_rec_binding : rec_binding -> Loc.t = "%field0";
external loc_of_module_binding : module_binding -> Loc.t = "%field0";
external loc_of_match_case : match_case -> Loc.t = "%field0";
external loc_of_ident : ident -> Loc.t = "%field0";
value ghost = Loc.ghost;
value rec is_module_longident =
fun
[ <:ident< $_$.$i$ >> -> is_module_longident i
| <:ident< $i1$ $i2$ >> ->
is_module_longident i1 && is_module_longident i2
| <:ident< $uid:_$ >> -> True
| _ -> False ];
value ident_of_expr =
let error () =
invalid_arg "ident_of_expr: this expression is not an identifier" in
let rec self =
fun
[ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >>
| <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >>
| <:expr< $lid:_$ >> -> error ()
| <:expr< $id:i$ >> -> if is_module_longident i then i else error ()
| _ -> error () ] in
fun
[ <:expr< $id:i$ >> -> i
| <:expr< $_$ $_$ >> -> error ()
| t -> self t ];
value ident_of_ctyp =
let error () =
invalid_arg "ident_of_ctyp: this type is not an identifier" in
let rec self =
fun
[ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >>
| <:ctyp< $lid:_$ >> -> error ()
| <:ctyp< $id:i$ >> -> if is_module_longident i then i else error ()
| _ -> error () ] in
fun
[ <:ctyp< $id:i$ >> -> i
| t -> self t ];
value ident_of_patt =
let error () =
invalid_arg "ident_of_patt: this pattern is not an identifier" in
let rec self =
fun
[ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >>
| <:patt< $lid:_$ >> -> error ()
| <:patt< $id:i$ >> -> if is_module_longident i then i else error ()
| _ -> error () ] in
fun
[ <:patt< $id:i$ >> -> i
| p -> self p ];
value rec is_irrefut_patt =
fun
[ <:patt< $lid:_$ >> -> True
| <:patt< () >> -> True
| <:patt< _ >> -> True
| <:patt<>> -> True (* why not *)
| <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
| <:patt< { $p$ } >> -> is_irrefut_patt p
| <:patt< $_$ = $p$ >> -> is_irrefut_patt p
| <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *)
| <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
| <:patt< ($tup:pl$) >> -> is_irrefut_patt pl
| <:patt< ? $_$ >> -> True
| <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p
| <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
| <:patt< ~ $_$ >> -> True
| <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
| <:patt< lazy $p$ >> -> is_irrefut_patt p
| Ast.PaAtt _loc _s _str p -> is_irrefut_patt p
| <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *)
| <:patt< (module $_$) >> -> True
| Ast.PaExc _loc p -> is_irrefut_patt p
| <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> |
<:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> |
<:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> |
<:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False
];
value rec is_constructor =
fun
[ <:ident< $_$.$i$ >> -> is_constructor i
| <:ident< $uid:_$ >> -> True
| <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False
| <:ident< $anti:_$ >> -> assert False ];
value is_patt_constructor =
fun
[ <:patt< $id:i$ >> -> is_constructor i
| <:patt< `$_$ >> -> True
| _ -> False ];
value rec is_expr_constructor =
fun
[ <:expr< $id:i$ >> -> is_constructor i
| <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2
| <:expr< `$_$ >> -> True
| _ -> False ];
value rec tyOr_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ];
value rec tyAnd_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ];
value rec tySem_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ];
value rec tyCom_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ];
value rec tyAmp_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ];
value rec tySta_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ];
value rec stSem_of_list =
fun
[ [] -> <:str_item@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ];
value rec sgSem_of_list =
fun
[ [] -> <:sig_item@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ];
value rec biAnd_of_list =
fun
[ [] -> <:binding@ghost<>>
| [b] -> b
| [b::bs] ->
let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ];
value rec rbSem_of_list =
fun
[ [] -> <:rec_binding@ghost<>>
| [b] -> b
| [b::bs] ->
let _loc = loc_of_rec_binding b in
<:rec_binding< $b$; $rbSem_of_list bs$ >> ];
value rec wcAnd_of_list =
fun
[ [] -> <:with_constr@ghost<>>
| [w] -> w
| [w::ws] ->
let _loc = loc_of_with_constr w in
<:with_constr< $w$ and $wcAnd_of_list ws$ >> ];
value rec idAcc_of_list =
fun
[ [] -> assert False
| [i] -> i
| [i::is] ->
let _loc = loc_of_ident i in
<:ident< $i$ . $idAcc_of_list is$ >> ];
value rec idApp_of_list =
fun
[ [] -> assert False
| [i] -> i
| [i::is] ->
let _loc = loc_of_ident i in
<:ident< $i$ $idApp_of_list is$ >> ];
value rec mcOr_of_list =
fun
[ [] -> <:match_case@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_match_case x in
<:match_case< $x$ | $mcOr_of_list xs$ >> ];
value rec mbAnd_of_list =
fun
[ [] -> <:module_binding@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_module_binding x in
<:module_binding< $x$ and $mbAnd_of_list xs$ >> ];
value rec meApp_of_list =
fun
[ [] -> assert False
| [x] -> x
| [x::xs] ->
let _loc = loc_of_module_expr x in
<:module_expr< $x$ $meApp_of_list xs$ >> ];
value rec ceAnd_of_list =
fun
[ [] -> <:class_expr@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_expr x in
<:class_expr< $x$ and $ceAnd_of_list xs$ >> ];
value rec ctAnd_of_list =
fun
[ [] -> <:class_type@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_type x in
<:class_type< $x$ and $ctAnd_of_list xs$ >> ];
value rec cgSem_of_list =
fun
[ [] -> <:class_sig_item@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_sig_item x in
<:class_sig_item< $x$; $cgSem_of_list xs$ >> ];
value rec crSem_of_list =
fun
[ [] -> <:class_str_item@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_str_item x in
<:class_str_item< $x$; $crSem_of_list xs$ >> ];
value rec paSem_of_list =
fun
[ [] -> <:patt@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_patt x in
<:patt< $x$; $paSem_of_list xs$ >> ];
value rec paCom_of_list =
fun
[ [] -> <:patt@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_patt x in
<:patt< $x$, $paCom_of_list xs$ >> ];
value rec exSem_of_list =
fun
[ [] -> <:expr@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_expr x in
<:expr< $x$; $exSem_of_list xs$ >> ];
value rec exCom_of_list =
fun
[ [] -> <:expr@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_expr x in
<:expr< $x$, $exCom_of_list xs$ >> ];
value ty_of_stl =
fun
[ (_loc, s, []) -> <:ctyp< $uid:s$ >>
| (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ];
value ty_of_sbt =
fun
[ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >>
| (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ];
value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>;
value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l);
value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l);
value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l);
value rec pel_of_binding =
fun
[ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2
| <:binding< $p$ = $e$ >> -> [(p, e)]
| _ -> assert False ];
value rec list_of_binding x acc =
match x with
[ <:binding< $b1$ and $b2$ >> ->
list_of_binding b1 (list_of_binding b2 acc)
| t -> [t :: acc] ];
value rec list_of_rec_binding x acc =
match x with
[ <:rec_binding< $b1$; $b2$ >> ->
list_of_rec_binding b1 (list_of_rec_binding b2 acc)
| t -> [t :: acc] ];
value rec list_of_with_constr x acc =
match x with
[ <:with_constr< $w1$ and $w2$ >> ->
list_of_with_constr w1 (list_of_with_constr w2 acc)
| t -> [t :: acc] ];
value rec list_of_ctyp x acc =
match x with
[ <:ctyp<>> -> acc
| <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> |
<:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> |
<:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> ->
list_of_ctyp x (list_of_ctyp y acc)
| x -> [x :: acc] ];
value rec list_of_patt x acc =
match x with
[ <:patt<>> -> acc
| <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> ->
list_of_patt x (list_of_patt y acc)
| x -> [x :: acc] ];
value rec list_of_expr x acc =
match x with
[ <:expr<>> -> acc
| <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> ->
list_of_expr x (list_of_expr y acc)
| x -> [x :: acc] ];
value rec list_of_str_item x acc =
match x with
[ <:str_item<>> -> acc
| <:str_item< $x$; $y$ >> ->
list_of_str_item x (list_of_str_item y acc)
| x -> [x :: acc] ];
value rec list_of_sig_item x acc =
match x with
[ <:sig_item<>> -> acc
| <:sig_item< $x$; $y$ >> ->
list_of_sig_item x (list_of_sig_item y acc)
| x -> [x :: acc] ];
value rec list_of_class_sig_item x acc =
match x with
[ <:class_sig_item<>> -> acc
| <:class_sig_item< $x$; $y$ >> ->
list_of_class_sig_item x (list_of_class_sig_item y acc)
| x -> [x :: acc] ];
value rec list_of_class_str_item x acc =
match x with
[ <:class_str_item<>> -> acc
| <:class_str_item< $x$; $y$ >> ->
list_of_class_str_item x (list_of_class_str_item y acc)
| x -> [x :: acc] ];
value rec list_of_class_type x acc =
match x with
[ <:class_type< $x$ and $y$ >> ->
list_of_class_type x (list_of_class_type y acc)
| x -> [x :: acc] ];
value rec list_of_class_expr x acc =
match x with
[ <:class_expr< $x$ and $y$ >> ->
list_of_class_expr x (list_of_class_expr y acc)
| x -> [x :: acc] ];
value rec list_of_module_expr x acc =
match x with
[ <:module_expr< $x$ $y$ >> ->
list_of_module_expr x (list_of_module_expr y acc)
| x -> [x :: acc] ];
value rec list_of_match_case x acc =
match x with
[ <:match_case<>> -> acc
| <:match_case< $x$ | $y$ >> ->
list_of_match_case x (list_of_match_case y acc)
| x -> [x :: acc] ];
value rec list_of_ident x acc =
match x with
[ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> ->
list_of_ident x (list_of_ident y acc)
| x -> [x :: acc] ];
value rec list_of_module_binding x acc =
match x with
[ <:module_binding< $x$ and $y$ >> ->
list_of_module_binding x (list_of_module_binding y acc)
| x -> [x :: acc] ];
module Camlp4Trash = struct
INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml";
end;
module Meta = struct
module type META_LOC = sig
(** The first location is where to put the returned pattern.
Generally it's _loc to match with <:patt< ... >> quotations.
The second location is the one to treat. *)
value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt;
(** The first location is where to put the returned expression.
Generally it's _loc to match with <:expr< ... >> quotations.
The second location is the one to treat. *)
value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr;
end;
module MetaLoc = struct
value meta_loc_patt _loc location =
let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in
<:patt< Loc.of_tuple
($`str:a$, $`int:b$, $`int:c$, $`int:d$,
$`int:e$, $`int:f$, $`int:g$,
$if h then <:patt< True >> else <:patt< False >> $) >>;
value meta_loc_expr _loc location =
let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in
<:expr< Loc.of_tuple
($`str:a$, $`int:b$, $`int:c$, $`int:d$,
$`int:e$, $`int:f$, $`int:g$,
$if h then <:expr< True >> else <:expr< False >> $) >>;
end;
module MetaGhostLoc = struct
value meta_loc_patt _loc _ = <:patt< Loc.ghost >>;
value meta_loc_expr _loc _ = <:expr< Loc.ghost >>;
end;
module MetaLocVar = struct
value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>;
value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>;
end;
module Make (MetaLoc : META_LOC) = struct
open MetaLoc;
value meta_loc = meta_loc_expr;
module Expr = Camlp4Filters.MetaGeneratorExpr Ast;
value meta_loc = meta_loc_patt;
module Patt = Camlp4Filters.MetaGeneratorPatt Ast;
end;
end;
class map = Camlp4MapGenerator.generated;
class fold = Camlp4FoldGenerator.generated;
value map_expr f = object
inherit map as super;
method expr x = f (super#expr x);
end;
value map_patt f = object
inherit map as super;
method patt x = f (super#patt x);
end;
value map_ctyp f = object
inherit map as super;
method ctyp x = f (super#ctyp x);
end;
value map_str_item f = object
inherit map as super;
method str_item x = f (super#str_item x);
end;
value map_sig_item f = object
inherit map as super;
method sig_item x = f (super#sig_item x);
end;
value map_loc f = object
inherit map as super;
method loc x = f (super#loc x);
end;
end;