ppx_irmin: support primitive representations outside 'Irmin.Type'

CHANGES.md

@@ -10,6 +10,9 @@
     shadowing primitive types such as `unit`. See `README_PPX` for details.
     (#993, @CraigFe)
 
+  - Added support for a `lib` argument, which can be used to supply primitive
+    type representations from modules other than `Irmin.Type`. (#994, @CraigFe)
+
 #### Changed
 
 - **irmin**:

README_PPX.md

@@ -55,6 +55,17 @@ types, records, variants (plain and closed polymorphic), recursive types etc.).
 Irmin does not currently support higher-kinded generics: all Irmin types must
 fully grounded (no polymorphic type variables).
 
+To supply base representations from a module other than `Irmin.Type` (such as
+when `Irmin.Type` is aliased to a different module path), the `lib` argument can
+be passed to `@@deriving irmin`:
+
+```ocaml
+type foo = unit [@@deriving irmin { lib = Some "Mylib.Types" }]
+
+(* generates the value *)
+val foo_t = Mylib.Types.unit
+```
+
 #### Naming scheme
 
 The generated generics will be called `<type-name>_t`, unless the type-name is
@@ -80,17 +91,15 @@ val bar_t = Irmin.Type.(result foo_generic string)
 ```
 
 Built-in abstract types such as `unit` are assumed to be represented in
-`Irmin.Type`. This behaviour can be overridden with the []`[@nobuiltin]`
+`Irmin.Type`. This behaviour can be overridden with the `[@nobuiltin]`
 attribute:
 
 
 ```ocaml
-type unit = string [@@deriving irmin]
-
 type t = unit [@nobuiltin] [@@deriving irmin]
 
 (* generates the value *)
-let t = string_t (* not [Irmin.Type.t] *)
+let t = unit_t (* not [Irmin.Type.unit] *)
 ```
 
 #### Signature type definitions

src/ppx_irmin/deriver/ppx_irmin.ml

@@ -19,23 +19,23 @@ open Ppx_irmin_lib
 
 let ppx_name = "irmin"
 
-let expand_str ~loc ~path:_ input_ast name =
+let expand_str ~loc ~path:_ input_ast name lib =
   let (module S) = Ast_builder.make loc in
   let (module L) = (module Deriver.Located (S) : Deriver.S) in
-  L.derive_str ?name input_ast
+  L.derive_str ?name ?lib input_ast
 
-let expand_sig ~loc ~path:_ input_ast name =
+let expand_sig ~loc ~path:_ input_ast name lib =
   let (module S) = Ast_builder.make loc in
   let (module L) = (module Deriver.Located (S) : Deriver.S) in
-  L.derive_sig ?name input_ast
+  L.derive_sig ?name ?lib input_ast
 
 let str_type_decl_generator =
-  let args = Deriving.Args.(empty +> arg "name" (estring __)) in
+  let args = Deriving.Args.(empty +> arg "name" (estring __) +> arg "lib" __) in
   let attributes = Attributes.all in
   Deriving.Generator.make ~attributes args expand_str
 
 let sig_type_decl_generator =
-  let args = Deriving.Args.(empty +> arg "name" (estring __)) in
+  let args = Deriving.Args.(empty +> arg "name" (estring __) +> arg "lib" __) in
   Deriving.Generator.make args expand_sig
 
 let irmin =

src/ppx_irmin/lib/deriver.ml

@@ -39,54 +39,68 @@ let irmin_types =
 
 module type S = sig
   val derive_str :
-    ?name:string -> rec_flag * type_declaration list -> structure_item list
+    ?name:string ->
+    ?lib:expression ->
+    rec_flag * type_declaration list ->
+    structure_item list
 
   val derive_sig :
-    ?name:string -> rec_flag * type_declaration list -> signature_item list
+    ?name:string ->
+    ?lib:expression ->
+    rec_flag * type_declaration list ->
+    signature_item list
 end
 
 module Located (A : Ast_builder.S) : S = struct
   module State = struct
     type t = {
       rec_flag : rec_flag;
       type_name : string;
+      lib : string option;
       generic_name : string;
       rec_detected : bool ref;
     }
   end
 
   module Reader = Monad.Reader (State)
 
-  let ( >>| ) x f = Reader.map f x
+  let ( >>= ) x f = Reader.bind f x
 
   module Algebraic = Algebraic.Located (A) (Reader)
   open A
+  open Reader.Syntax
+  open Reader
 
   let unlabelled x = (Nolabel, x)
 
   let ( >|= ) x f = List.map f x
 
   let lambda fparam = pvar fparam |> pexp_fun Nolabel None
 
-  let open_module =
-    pexp_open
-      {
-        popen_expr = pmod_ident (Located.lident "Irmin.Type");
-        popen_override = Fresh;
-        popen_loc = A.loc;
-        popen_attributes = [];
-      }
+  let open_lib expr =
+    let+ { lib; _ } = ask in
+    match lib with
+    | Some lib ->
+        pexp_open
+          {
+            popen_expr = pmod_ident (Located.lident lib);
+            popen_override = Fresh;
+            popen_loc = A.loc;
+            popen_attributes = [];
+          }
+          expr
+    | None -> expr
 
-  let recursive fparam e =
-    pexp_apply (evar "Irmin.Type.mu") ([ lambda fparam e ] >|= unlabelled)
+  let recursive ~lib fparam e =
+    let lib = match lib with Some s -> s | None -> "" in
+    pexp_apply
+      (evar (String.concat "." [ lib; "mu" ]))
+      ([ lambda fparam e ] >|= unlabelled)
 
   let generic_name_of_type_name = function "t" -> "t" | x -> x ^ "_t"
 
-  open Reader.Syntax
-  open Reader
-
   let rec derive_core typ =
-    let* { rec_flag; type_name; generic_name; rec_detected } = ask in
+    let* { rec_flag; type_name; generic_name; rec_detected; _ } = ask in
     match typ.ptyp_desc with
     | Ptyp_constr ({ txt = const_name; _ }, args) -> (
         match Attribute.get Attributes.generic typ with
@@ -196,35 +210,21 @@ module Located (A : Ast_builder.S) : S = struct
     in
     Algebraic.(encode Polyvariant) ~subderive ~type_name:name rowfields
 
-  let derive_sig ?name input_ast =
-    match input_ast with
-    | _, [ typ ] ->
-        let type_name = typ.ptype_name.txt in
-        let name =
-          Located.mk
-            ( match name with
-            | Some n -> n
-            | None -> generic_name_of_type_name type_name )
-        in
-        let type_ =
-          ptyp_constr
-            (Located.lident "Irmin.Type.t")
-            [ ptyp_constr (Located.lident type_name) [] ]
-        in
-        [ psig_value (value_description ~name ~type_ ~prim:[]) ]
-    | _ -> invalid_arg "Multiple type declarations not supported"
-
   let derive_lident :
-      ?generic:expression -> ?nobuiltin:unit -> longident -> expression =
+      ?generic:expression -> ?nobuiltin:unit -> longident -> expression Reader.t
+      =
    fun ?generic ?nobuiltin txt ->
+    let+ { lib; _ } = ask in
     let nobuiltin = match nobuiltin with Some () -> true | None -> false in
     match generic with
     | Some e -> e
     | None -> (
         match txt with
         | Lident cons_name ->
             if (not nobuiltin) && SSet.mem cons_name irmin_types then
-              evar ("Irmin.Type." ^ cons_name)
+              match lib with
+              | Some lib -> evar (String.concat "." [ lib; cons_name ])
+              | None -> evar cons_name
             else
               (* If not a basic type, assume a composite
                  generic /w same naming convention *)
@@ -242,18 +242,65 @@ module Located (A : Ast_builder.S) : S = struct
         | None -> invalid_arg "No manifest"
         | Some c -> (
             match c.ptyp_desc with
-            (* No need to open Irmin.Type module *)
+            (* No need to open library module *)
             | Ptyp_constr ({ txt; loc = _ }, []) ->
                 let generic = Attribute.get Attributes.generic c
                 and nobuiltin = Attribute.get Attributes.nobuiltin c in
-                derive_lident ?generic ?nobuiltin txt |> Reader.return
+                derive_lident ?generic ?nobuiltin txt
             (* Type constructor: list, tuple, etc. *)
-            | _ -> derive_core c >>| open_module ) )
-    | Ptype_variant cs -> derive_variant cs >>| open_module
-    | Ptype_record ls -> derive_record ls >>| open_module
+            | _ -> derive_core c >>= open_lib ) )
+    | Ptype_variant cs -> derive_variant cs >>= open_lib
+    | Ptype_record ls -> derive_record ls >>= open_lib
     | Ptype_open -> Raise.Unsupported.type_open ~loc
 
-  let derive_str ?name input_ast =
+  let parse_lib expr =
+    match expr with
+    | { pexp_desc = Pexp_construct ({ txt = Lident "None"; _ }, None); _ } ->
+        None
+    | {
+     pexp_desc =
+       Pexp_construct
+         ( { txt = Lident "Some"; _ },
+           Some { pexp_desc = Pexp_constant (Pconst_string (lib, None)); _ } );
+     _;
+    } ->
+        Some lib
+    | { pexp_loc = loc; _ } ->
+        Location.raise_errorf ~loc
+          "Could not process `lib' argument: must be either `Some \"Lib\"' or \
+           `None'"
+
+  let lib_default = "Irmin.Type"
+
+  let derive_sig ?name ?lib input_ast =
+    match input_ast with
+    | _, [ typ ] ->
+        let type_name = typ.ptype_name.txt in
+        let name =
+          Located.mk
+            ( match name with
+            | Some n -> n
+            | None -> generic_name_of_type_name type_name )
+        in
+        let lib =
+          match lib with Some l -> parse_lib l | None -> Some lib_default
+        in
+        let ty_lident =
+          match lib with
+          | Some l -> Located.lident (String.concat "." [ l; "t" ])
+          | None -> (
+              (* This type decl may shadow the repr type ['a t] *)
+              match name.txt with
+              | "t" -> Located.lident "ty"
+              | _ -> Located.lident "t" )
+        in
+        let type_ =
+          ptyp_constr ty_lident [ ptyp_constr (Located.lident type_name) [] ]
+        in
+        [ psig_value (value_description ~name ~type_ ~prim:[]) ]
+    | _ -> invalid_arg "Multiple type declarations not supported"
+
+  let derive_str ?name ?lib input_ast =
     match input_ast with
     | rec_flag, [ typ ] ->
         let env =
@@ -264,15 +311,18 @@ module Located (A : Ast_builder.S) : S = struct
             | None -> generic_name_of_type_name type_name
           in
           let rec_detected = ref false in
-          State.{ rec_flag; type_name; generic_name; rec_detected }
+          let lib =
+            match lib with Some l -> parse_lib l | None -> Some lib_default
+          in
+          State.{ rec_flag; type_name; generic_name; rec_detected; lib }
         in
         let expr = run (derive_type_decl typ) env in
         (* If the type is syntactically self-referential and the user has not
            asserted 'nonrec' in the type declaration, wrap in a 'mu'
            combinator *)
         let expr =
           if !(env.rec_detected) && rec_flag == Recursive then
-            recursive env.generic_name expr
+            recursive ~lib:env.lib env.generic_name expr
           else expr
         in
         let pat = pvar env.generic_name in

src/ppx_irmin/lib/deriver.mli

@@ -18,12 +18,26 @@ open Ppxlib
 
 module type S = sig
   val derive_str :
-    ?name:string -> rec_flag * type_declaration list -> structure_item list
-  (** Deriver for Irmin generics. *)
+    ?name:string ->
+    ?lib:expression ->
+    rec_flag * type_declaration list ->
+    structure_item list
+  (** Deriver for Irmin generics.
+
+      - [?name]: overrides the default name of the generated generic;
+
+      - [?lib]: overrides the default location for the primitive Irmin generics.
+        [~lib:None] will assume that the generics are available in the same
+        namespace. *)
 
   val derive_sig :
-    ?name:string -> rec_flag * type_declaration list -> signature_item list
-  (** Deriver for Irmin generic type signatures. *)
+    ?name:string ->
+    ?lib:expression ->
+    rec_flag * type_declaration list ->
+    signature_item list
+  (** Deriver for Irmin generic type signatures.
+
+      Optional arguments have the same meaning as in {!derive_str}. *)
 end
 
 module Located (A : Ast_builder.S) : S

test/ppx_irmin/deriver/errors/dune.inc

@@ -6,6 +6,24 @@
 
 
 
+(rule
+ (targets lib_invalid.actual)
+ (deps
+  (:pp pp.exe)
+  (:input lib_invalid.ml))
+ (action
+  (with-stderr-to
+   %{targets}
+   (bash "! ./%{pp} -no-color --impl %{input}"))))
+
+(alias
+ (name runtest)
+ (package ppx_irmin)
+ (action
+  (diff lib_invalid.expected lib_invalid.actual)))
+
+
+
 (rule
  (targets nobuiltin_nonempty.actual)
  (deps

test/ppx_irmin/deriver/errors/lib_invalid.expected

@@ -0,0 +1,2 @@
+File "lib_invalid.ml", line 1, characters 40-45:
+Error: Could not process `lib' argument: must be either `Some "Lib"' or `None'

test/ppx_irmin/deriver/errors/lib_invalid.ml

@@ -0,0 +1 @@
+type t = unit [@@deriving irmin { lib = "foo" }] (* should be [Some "foo"] *)

test/ppx_irmin/deriver/passing/dune.inc

@@ -76,6 +76,24 @@
  (action
   (diff composite.expected composite.actual)))
 
+(library
+ (name lib_relocated)
+ (modules lib_relocated))
+
+(rule
+ (targets lib_relocated.actual)
+ (deps
+  (:pp pp.exe)
+  (:input lib_relocated.ml))
+ (action
+  (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets})))
+
+(alias
+ (name runtest)
+ (package ppx_irmin)
+ (action
+  (diff lib_relocated.expected lib_relocated.actual)))
+
 (library
  (name module)
  (modules module))