Add mangling utilities from ppx_deriving (issue ocaml-ppx#317)

Signed-off-by: Simmo Saan <[email protected]>

CHANGES.md

@@ -1,6 +1,8 @@
 unreleased
 -------------------
 
+- Add `Ppxlib.Mangle` with name mangling utilities from ppx_deriving (#<PR_NUMBER>, @sim642)
+
 - Make `esequence` right-associative. (#366, @ceastlund)
 
 - Deprecate unused attributes in `Deriving.Generator` (#368, @sim642)

src/mangle.ml

@@ -0,0 +1,21 @@
+open Import
+
+type affix =
+  [ `Prefix of string | `Suffix of string | `PrefixSuffix of string * string ]
+
+let mangle ?(fixpoint = "t") affix name =
+  match (String.(name = fixpoint), affix) with
+  | true, (`Prefix x | `Suffix x) -> x
+  | true, `PrefixSuffix (p, s) -> p ^ "_" ^ s
+  | false, `PrefixSuffix (p, s) -> p ^ "_" ^ name ^ "_" ^ s
+  | false, `Prefix x -> x ^ "_" ^ name
+  | false, `Suffix x -> name ^ "_" ^ x
+
+let mangle_type_decl ?fixpoint affix { ptype_name = { txt = name; _ }; _ } =
+  mangle ?fixpoint affix name
+
+let mangle_lid ?fixpoint affix lid =
+  match lid with
+  | Lident s -> Lident (mangle ?fixpoint affix s)
+  | Ldot (p, s) -> Ldot (p, mangle ?fixpoint affix s)
+  | Lapply _ -> invalid_arg "Ppxlib.Mangle.mangle_lid: Lapply"

src/mangle.mli

@@ -0,0 +1,23 @@
+(** Derive mangled names from type names in a deriver. *)
+
+open Import
+
+type affix =
+  [ `Prefix of string  (** [`Prefix p] adds prefix [p]. *)
+  | `Suffix of string  (** [`Suffix s] adds suffix [s]. *)
+  | `PrefixSuffix of string * string
+    (** [`PrefixSuffix (p, s)] adds both prefix [p] and suffix [s]. *) ]
+(** Specification for name mangling. *)
+
+val mangle : ?fixpoint:string -> affix -> string -> string
+(** [mangle ~fixpoint affix s] derives a mangled name from [s] with the mangling
+    specified by [affix]. If [s] is equal to [fixpoint] (["t"] by default), then
+    [s] is omitted from the mangled name. *)
+
+val mangle_type_decl : ?fixpoint:string -> affix -> type_declaration -> string
+(** [mangle_type_decl ~fixpoint affix td] does the same as {!mangle}, but for
+    the name of [td]. *)
+
+val mangle_lid : ?fixpoint:string -> affix -> Longident.t -> Longident.t
+(** [mangle_lid ~fixpoint affix lid] does the same as {!mangle}, but for the
+    last component of [lid]. *)

src/ppxlib.ml

@@ -59,6 +59,7 @@ module Keyword = Keyword
 module Loc = Loc
 module Location = Location
 module Longident = Longident
+module Mangle = Mangle
 module Merlin_helpers = Merlin_helpers
 module Reserved_namespaces = Name.Reserved_namespaces
 module Spellcheck = Spellcheck

test/mangle/dune

@@ -0,0 +1,13 @@
+(rule
+ (alias runtest)
+ (enabled_if
+  (>= %{ocaml_version} "4.08.0"))
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))

test/mangle/test.ml

@@ -0,0 +1,46 @@
+open Ppxlib;;
+
+Mangle.mangle (`Prefix "pre") "foo";;
+[%%expect{|
+- : string = "pre_foo"
+|}]
+
+Mangle.mangle (`Suffix "suf") "foo";;
+[%%expect{|
+- : string = "foo_suf"
+|}]
+
+Mangle.mangle (`PrefixSuffix ("pre", "suf")) "foo";;
+[%%expect{|
+- : string = "pre_foo_suf"
+|}]
+
+Mangle.mangle (`Prefix "pre") "t";;
+[%%expect{|
+- : string = "pre"
+|}]
+
+Mangle.mangle (`Suffix "suf") "t";;
+[%%expect{|
+- : string = "suf"
+|}]
+
+Mangle.mangle (`PrefixSuffix ("pre", "suf")) "t";;
+[%%expect{|
+- : string = "pre_suf"
+|}]
+
+Mangle.mangle ~fixpoint:"foo" (`Prefix "pre") "foo";;
+[%%expect{|
+- : string = "pre"
+|}]
+
+Mangle.mangle ~fixpoint:"foo" (`Suffix "suf") "foo";;
+[%%expect{|
+- : string = "suf"
+|}]
+
+Mangle.mangle ~fixpoint:"foo" (`PrefixSuffix ("pre", "suf")) "foo";;
+[%%expect{|
+- : string = "pre_suf"
+|}]