unikernel/duniverse/ppxlib/test/extensions_and_deriving/dune

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

unikernel/duniverse/ppxlib/test/extensions_and_deriving/floating_attr/dune

@@ -0,0 +1,9 @@
+(executables
+ (names ppx)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (package ppxlib)
+ (deps ppx.exe))

unikernel/duniverse/ppxlib/test/extensions_and_deriving/floating_attr/ppx.ml

@@ -0,0 +1,50 @@
+open Ppxlib
+
+let () =
+  let open Context_free.Rule in
+  let open Ast_pattern in
+  let ghost =
+    object
+      inherit Ast_traverse.map
+      method! location loc = { loc with loc_ghost = true }
+    end
+  in
+  let make_str_attr name =
+    Attribute.Floating.declare name Structure_item (pstr __) (fun x -> x)
+  in
+  let make_sig_attr name =
+    Attribute.Floating.declare name Signature_item (psig __) (fun x -> x)
+  in
+  let expand_str ~ctxt:_ x = ghost#structure x in
+  let expand_sig ~ctxt:_ x = ghost#signature x in
+  let make_str name rule = rule (make_str_attr name) expand_str in
+  let make_sig name rule = rule (make_sig_attr name) expand_sig in
+  let rules =
+    [
+      make_str "identity_inline_expanded" attr_str_floating_expect_and_expand;
+      make_sig "identity_inline_expanded" attr_sig_floating_expect_and_expand;
+    ]
+  in
+  Driver.register_transformation "identity" ~rules
+
+let () =
+  let extractor = Ast_pattern.(single_expr_payload (estring __)) in
+  let expander ~loc ~path:_ s =
+    Ast_builder.Default.(estring ~loc (s ^ "_suffix"))
+  in
+  let extender =
+    Extension.declare "suffix" Extension.Context.Expression extractor expander
+  in
+  Driver.register_transformation "suffix"
+    ~rules:[ Context_free.Rule.extension extender ]
+
+let () =
+  let extractor = Ast_pattern.(pstr nil) in
+  let expander ~loc ~path:_ = [%type: string] in
+  let extender =
+    Extension.declare "str" Extension.Context.Core_type extractor expander
+  in
+  Driver.register_transformation "str"
+    ~rules:[ Context_free.Rule.extension extender ]
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/extensions_and_deriving/floating_attr/run-expand-inline.t

@@ -0,0 +1,140 @@
+Test `expand_inline` for structures.
+
+  $ cat << 'EOF' > program.ml
+  > [@@@expand_inline
+  >   module T : sig
+  >     val foo : [%str]
+  >   end = struct
+  >     let foo = [%suffix "apples"]
+  >   end]
+  > [@@@end]
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -4,4 +4,5 @@
+     end = struct
+       let foo = [%suffix "apples"]
+     end]
+  +module T : sig val foo : string end = struct let foo = "apples_suffix" end
+   [@@@end]
+  [1]
+
+Test `expand_inline` for signatures.
+
+  $ cat << 'EOF' > program.ml
+  > module type S = sig
+  >   [@@@expand_inline:
+  >     val foo : [%str]
+  >     include module type of struct
+  >       let foo = [%suffix "apples"]
+  >     end]
+  >   [@@@end]
+  > end 
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -4,5 +4,8 @@
+       include module type of struct
+         let foo = [%suffix "apples"]
+       end]
+  -  [@@@end]
+  +  
+  +val foo : string
+  +include module type of struct let foo = "apples_suffix" end
+  +[@@@end]
+   end 
+  [1]
+
+Test (** ... *) comments get translated using {| |} syntax.
+
+  $ cat << 'EOF' > program.ml
+  > [@@@expand_inline 
+  > module T : sig
+  > (**foo*)
+  > val foo : [%str]
+  > end = struct
+  > (**bar*)
+  > let foo = [%suffix "apples"]
+  > end
+  > 
+  > (** baz *)
+  > 
+  > ]
+  > [@@@end]
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -10,4 +10,7 @@
+   (** baz *)
+   
+   ]
+  +module T : sig val foo : string[@@ocaml.doc {|foo|}] end =
+  +  struct let foo = "apples_suffix"[@@ocaml.doc {|bar|}] end
+  +[@@@ocaml.text {| baz |}]
+   [@@@end]
+  [1]
+
+Test [@@ocaml.doc ...] attributes do not get swapped to using {| |}.
+
+  $ cat << 'EOF' > program.ml
+  > [@@@expand_inline 
+  > module T : sig
+  > val foo : [%str] [@@ocaml.doc "foo"]
+  > end = struct
+  > let foo = [%suffix "apples"] [@@ocaml.doc "foo"]
+  > end
+  > ]
+  > [@@@end]
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -5,4 +5,6 @@
+   let foo = [%suffix "apples"] [@@ocaml.doc "foo"]
+   end
+   ]
+  +module T : sig val foo : string[@@ocaml.doc "foo"] end =
+  +  struct let foo = "apples_suffix"[@@ocaml.doc "foo"] end
+   [@@@end]
+  [1]
+
+Test the delim finding behaviour when translating (** ... *) comments to {| |} syntax.
+
+  $ cat << 'EOF' > program.ml
+  > [@@@expand_inline 
+  > (**blah blah |} blah blah*)
+  > let foo = [%suffix "apples"]
+  > ]
+  > [@@@end]
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -2,4 +2,5 @@
+   (**blah blah |} blah blah*)
+   let foo = [%suffix "apples"]
+   ]
+  +let foo = "apples_suffix"[@@ocaml.doc {x|blah blah |} blah blah|x}]
+   [@@@end]
+  [1]
+
+  $ cat << 'EOF' > program.ml
+  > [@@@expand_inline 
+  > (**blxxx |} blaxxxxxxxxxh blxxahx*)
+  > let foo = [%suffix "apples"]
+  > ]
+  > [@@@end]
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -2,4 +2,5 @@
+   (**blxxx |} blaxxxxxxxxxh blxxahx*)
+   let foo = [%suffix "apples"]
+   ]
+  +let foo = "apples_suffix"[@@ocaml.doc {x|blxxx |} blaxxxxxxxxxh blxxahx|x}]
+   [@@@end]
+  [1]

unikernel/duniverse/ppxlib/test/extensions_and_deriving/floating_attr/run-floating-attr.t

@@ -0,0 +1,48 @@
+Test `attr_str_floating_expect_and_expand` via `@@@identity_inline_expanded`.
+
+  $ cat << 'EOF' > program.ml
+  > [@@@identity_inline_expanded
+  >   module T : sig
+  >     val foo : [%str]
+  >   end = struct
+  >     let foo = [%suffix "apples"]
+  >   end]
+  > [@@@end]
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -4,4 +4,5 @@
+     end = struct
+       let foo = [%suffix "apples"]
+     end]
+  +module T : sig val foo : string end = struct let foo = "apples_suffix" end
+   [@@@end]
+  [1]
+
+Test `attr_sig_floating_expect_and_expand` via `@@@identity_inline_expanded`.
+
+  $ cat << 'EOF' > program.ml
+  > module type S = sig
+  >   [@@@identity_inline_expanded:
+  >     val foo : [%str]
+  >     include module type of struct
+  >       let foo = [%suffix "apples"]
+  >     end]
+  >   [@@@end]
+  > end 
+  > EOF
+  $ ./ppx.exe -no-color -null -diff-cmd 'diff -u --label "" --label ""' program.ml
+  --- 
+  +++ 
+  @@ -4,5 +4,8 @@
+       include module type of struct
+         let foo = [%suffix "apples"]
+       end]
+  -  [@@@end]
+  +  
+  +val foo : string
+  +include module type of struct let foo = "apples_suffix" end
+  +[@@@end]
+   end 
+  [1]

unikernel/duniverse/ppxlib/test/extensions_and_deriving/test.ml

@@ -0,0 +1,142 @@
+open Ppxlib
+
+(* Generates a [let derived_<type_name> = "ok"] or a
+   [let derived_<type_name> = "uninterpreted extension in input"] if
+   the type manifest is an uninterpreted extension. *)
+let deriver =
+  let binding ~loc type_name expr =
+    let var_name = "derived_" ^ type_name in
+    let pat = Ast_builder.Default.ppat_var ~loc {txt = var_name; loc} in
+    let vb = Ast_builder.Default.value_binding ~loc ~pat ~expr in
+    [Ast_builder.Default.pstr_value ~loc Nonrecursive [vb]]
+  in
+  let str_type_decl =
+    Deriving.Generator.V2.make_noarg
+      (fun ~ctxt (_rec_flag, type_decls) ->
+         let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+         match type_decls with
+         | { ptype_manifest = Some {ptyp_desc = Ptyp_extension _; _}
+           ; ptype_name = {txt; _}; _}::_ ->
+           binding ~loc txt [%expr "uninterpreted extension in input"]
+         | {ptype_name = {txt; _}; _}::_ ->
+           binding ~loc txt [%expr "ok"]
+         | [] -> assert false)
+  in
+  Deriving.add ~str_type_decl "derived"
+
+[%%expect{|
+val deriver : Deriving.t = <abstr>
+|}]
+
+(* Generates a [type t = int] *)
+let gen_type_decl =
+  Extension.V3.declare
+    "gen_type_decl"
+    Extension.Context.structure_item
+    Ast_pattern.(pstr nil)
+    (fun ~ctxt ->
+       let loc = Expansion_context.Extension.extension_point_loc ctxt in
+       [%stri type t = int])
+  |> Context_free.Rule.extension
+
+let () = Driver.register_transformation ~rules:[gen_type_decl] "gen_type_decl"
+
+[%%expect{|
+val gen_type_decl : Context_free.Rule.t = <abstr>
+|}]
+
+(* You cannot attach attributes to structure item extension points *)
+[%%gen_type_decl]
+[@@deriving derived]
+
+[%%expect{|
+Line _, characters 3-19:
+Error: Attributes not allowed here
+|}]
+
+(* Generates a [type t = int[@@deriving derived]] *)
+let gen_type_decl_with_derived =
+  Extension.V3.declare
+    "gen_type_decl_with_derived"
+    Extension.Context.structure_item
+    Ast_pattern.(pstr nil)
+    (fun ~ctxt ->
+       let loc = Expansion_context.Extension.extension_point_loc ctxt in
+       [%stri type t = int[@@deriving derived]])
+  |> Context_free.Rule.extension
+
+let () =
+  Driver.register_transformation
+    ~rules:[gen_type_decl_with_derived]
+    "gen_type_decl_with_derived"
+
+[%%expect{|
+val gen_type_decl_with_derived : Context_free.Rule.t = <abstr>
+|}]
+
+(* Attributes rule must be applied in code generated by a structure item
+   extension *)
+[%%gen_type_decl_with_derived]
+
+[%%expect{|
+type t = int
+val derived_t : string = "ok"
+|}]
+
+let gen_inline_type_decls_with_derived =
+  Extension.V3.declare_inline
+    "gen_inline_type_decls_with_derived"
+    Extension.Context.structure_item
+    Ast_pattern.(pstr nil)
+    (fun ~ctxt ->
+       let loc = Expansion_context.Extension.extension_point_loc ctxt in
+       [%str
+         type t = int[@@deriving derived]
+         type u = float[@@deriving derived]])
+  |> Context_free.Rule.extension
+
+let () =
+  Driver.register_transformation
+    ~rules:[gen_inline_type_decls_with_derived]
+    "gen_inline_type_decls_with_derived"
+
+[%%expect{|
+val gen_inline_type_decls_with_derived : Context_free.Rule.t = <abstr>
+|}]
+
+(* That also stands for inline extension rules *)
+[%%gen_inline_type_decls_with_derived]
+
+[%%expect{|
+type t = int
+val derived_t : string = "ok"
+type u = float
+val derived_u : string = "ok"
+|}]
+
+let id =
+  Extension.V3.declare
+    "id"
+    Extension.Context.core_type
+    Ast_pattern.(ptyp __)
+    (fun ~ctxt:_ core_type -> core_type)
+  |> Context_free.Rule.extension
+
+let () = Driver.register_transformation ~rules:[id] "id"
+
+[%%expect{|
+val id : Context_free.Rule.t = <abstr>
+|}]
+
+(* Nodes with attributes are expanded before attribute-based, inline
+   code generation rules are applied.
+   In this below, the `[[%id: int]]` is interpreted before the deriver
+   is applied, meaning it can't see this extension point in its expand
+   function argument. *)
+type t = [%id: int]
+[@@deriving derived]
+
+[%%expect{|
+type t = int
+val derived_t : string = "ok"
+|}]