Commit 08859d1b authored by POTTIER Francois's avatar POTTIER Francois

Implement [visit_prefix], [build_prefix], [fail_prefix].

parent f4ba2e14
......@@ -118,10 +118,15 @@ let check_regularity loc tycon (formals : tyvars) (actuals : core_types) =
(* Public naming conventions. *)
(* The names of the methods associated with the type [foo] are normally based
on (derived from) the name [foo]. This base name can be overriden by the
user via an attribute. For a local type, a [@@name] attribute must be
attached to the type declaration. For a nonlocal type, a [@name] attribute
must be attached to every reference to this type. *)
on (derived from) the name [foo].
This base name can be overriden by the user via an attribute. For a local
type, a [@@name] attribute must be attached to the type declaration. For a
nonlocal type, a [@name] attribute must be attached to every reference to
this type.
The prefix that is prepended to the base name can be controlled via the
settings [visit_prefix], [build_prefix], and [fail_prefix]. *)
let tycon_modified_name (attrs : attributes) (tycon : tycon) : tycon =
maybe (name attrs) tycon
......@@ -140,7 +145,7 @@ let datacon_modified_name (cd : constructor_declaration) : datacon =
or [A.foo]. (A qualified name must denote a nonlocal type.) *)
let tycon_visitor_method (attrs : attributes) (tycon : tycon) : methode =
"visit_" ^ tycon_modified_name attrs tycon
X.visit_prefix ^ tycon_modified_name attrs tycon
let local_tycon_visitor_method (decl : type_declaration) : methode =
tycon_visitor_method decl.ptype_attributes decl.ptype_name.txt
......@@ -160,13 +165,13 @@ let nonlocal_tycon_visitor_method (ty : core_type) : methode =
(* The name of this method is normally [build_foo] if the type is named [foo]. *)
let tycon_ascending_method (decl : type_declaration) : methode =
"build_" ^ tycon_modified_name decl.ptype_attributes decl.ptype_name.txt
X.build_prefix ^ tycon_modified_name decl.ptype_attributes decl.ptype_name.txt
(* [mono] type variables have a virtual visitor method. We include a quote in
the method name so as to ensure the absence of collisions. *)
let tyvar_visitor_method (alpha : tyvar) : methode =
"visit_'" ^ alpha
sprintf "%s'%s" X.visit_prefix alpha
(* For every data constructor [datacon], there is a descending visitor method,
which is invoked on the way down, when this data constructor is discovered. *)
......@@ -175,14 +180,14 @@ let tyvar_visitor_method (alpha : tyvar) : methode =
named [Foo]. *)
let datacon_descending_method (cd : constructor_declaration) : methode =
"visit_" ^ datacon_modified_name cd
X.visit_prefix ^ datacon_modified_name cd
(* For every data constructor [datacon], there is a ascending visitor method,
which is invoked on the way up, in order to re-build some data structure.
This method is virtual and exists only when the scheme is [fold]. *)
let datacon_ascending_method (cd : constructor_declaration) : methode =
"build_" ^ datacon_modified_name cd
X.build_prefix ^ datacon_modified_name cd
(* At arity 2, for every sum type constructor [tycon] which has at least two
data constructors, there is a failure method, which is invoked when the
......@@ -191,7 +196,7 @@ let datacon_ascending_method (cd : constructor_declaration) : methode =
(* The name of this method is normally [fail_foo] if the type is named [foo]. *)
let failure_method (decl : type_declaration) : methode =
"fail_" ^ tycon_modified_name decl.ptype_attributes decl.ptype_name.txt
X.fail_prefix ^ tycon_modified_name decl.ptype_attributes decl.ptype_name.txt
(* When [scheme] is [Reduce], we need a monoid, that is, a unit [zero] and a
binary operation [plus]. The names [zero] and [plus] are fixed. We assume
......
......@@ -87,6 +87,14 @@ let is_valid_class_longident (m : string) : bool =
(* -------------------------------------------------------------------------- *)
(* Testing if a string is a valid method name prefix. *)
let is_valid_method_name_prefix (m : string) : bool =
String.length m > 0 &&
classify m = LIDENT
(* -------------------------------------------------------------------------- *)
(* Testing for the presence of attributes. *)
(* We use [ppx_deriving] to extract a specific attribute from an attribute
......
......@@ -50,6 +50,21 @@ module type SETTINGS = sig
the string provided by the user. *)
val variety: string
(* [visit_prefix] is the common prefix used to name the descending visitor
methods. It must be nonempty and a valid identifier by itself. Its
default value is "visit_". *)
val visit_prefix: string
(* [build_prefix] is the common prefix used to name the ascending visitor
methods. It must be nonempty and a valid identifier by itself. Its
default value is "build_". *)
val build_prefix: string
(* [fail_prefix] is the common prefix used to name the failure methods. It
must be nonempty and a valid identifier by itself. Its default value is
"fail_". *)
val fail_prefix: string
(* The classes that the visitor should inherit. If [nude] is [false], the
class [VisitorsRuntime.<scheme>] is implicitly prepended to this list.
If [nude] is [true], it is not. *)
......@@ -141,15 +156,20 @@ let parse_variety loc (s : string) : scheme * int =
(* -------------------------------------------------------------------------- *)
let must_be_valid_method_name_prefix loc p =
if not (is_valid_method_name_prefix p) then
raise_errorf ~loc
"%s: %S is not a valid method name prefix." plugin p
let must_be_valid_mod_longident loc m =
if not (is_valid_mod_longident m) then
raise_errorf ~loc
"%s: %s is not a valid module identifier." plugin m
"%s: %S is not a valid module identifier." plugin m
let must_be_valid_class_longident loc c =
if not (is_valid_class_longident c) then
raise_errorf ~loc
"%s: %s is not a valid class identifier." plugin c
"%s: %S is not a valid class identifier." plugin c
(* -------------------------------------------------------------------------- *)
......@@ -195,6 +215,9 @@ end)
let arity = ref 1 (* dummy: [variety] is mandatory; see below *)
let scheme = ref Iter (* dummy: [variety] is mandatory; see below *)
let variety = ref None
let visit_prefix = ref "visit_"
let build_prefix = ref "build_"
let fail_prefix = ref "fail_"
let ancestors = ref []
let concrete = ref false
let data = ref true
......@@ -210,6 +233,15 @@ end)
iter (fun (o, e) ->
let loc = e.pexp_loc in
match o with
| "visit_prefix" ->
visit_prefix := string e;
must_be_valid_method_name_prefix loc !visit_prefix
| "build_prefix" ->
build_prefix := string e;
must_be_valid_method_name_prefix loc !build_prefix
| "fail_prefix" ->
fail_prefix := string e;
must_be_valid_method_name_prefix loc !fail_prefix
| "ancestors" ->
ancestors := strings e
| "concrete" ->
......@@ -275,6 +307,9 @@ end)
let decls = decls
let arity = !arity
let scheme = !scheme
let visit_prefix = !visit_prefix
let build_prefix = !build_prefix
let fail_prefix = !fail_prefix
let ancestors = !ancestors
let concrete = !concrete
let data = !data
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment