unikernel/duniverse/ppxlib/metaquot/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppxlib_metaquot)
+ (public_name ppxlib.metaquot)
+ (kind ppx_rewriter)
+ (flags
+  (:standard -safe-string))
+ (libraries astlib ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters)
+ (ppx_runtime_libraries ppxlib_ast))

unikernel/duniverse/ppxlib/metaquot/ppxlib_metaquot.ml

@@ -0,0 +1,323 @@
+open Ppxlib
+open Ast_builder.Default
+module E = Extension
+module A = Ast_pattern
+
+type quoted_attributes = {
+  quoted_attributes : attributes;
+      (* The attributes that appear quoted, e.g. [@foo] in [%expr [%e e] [@foo]] *)
+  field_name : string;
+      (* The field name where attributes are stored for the kind of AST the quoted
+         attributes are placed on, e.g. pexp_attributes. *)
+}
+
+let coalesce_arity_expr (input : expression) super =
+  match input with
+  | { pexp_desc = Pexp_function _; pexp_loc = loc; _ } ->
+      let ppxlib_coalesce_arity =
+        Ldot
+          ( Ldot (Ldot (Lident "Ppxlib", "Ast_builder"), "Default"),
+            "coalesce_arity" )
+      in
+      pexp_apply ~loc
+        (pexp_ident ~loc { txt = ppxlib_coalesce_arity; loc })
+        [ (Nolabel, super input) ]
+  | exp -> super exp
+
+(* Produce a pattern that matches on the maximum arity of a function *)
+let coalesce_arity_pat (input : expression) super =
+  match input with
+  | { pexp_desc = Pexp_function _; pexp_loc = _loc; _ } as exp ->
+      let c = Ast_builder.Default.coalesce_arity exp in
+      super c
+  | e -> super e
+
+module Make (M : sig
+  type result
+
+  val annotate : result -> core_type -> result
+
+  val cast :
+    (* The instance of the [std_lifters] class being used. *)
+    < attributes : attributes -> result
+    ; typed : result -> string -> result
+    ; .. > ->
+    extension ->
+    quoted_attributes option ->
+    (* e.g. [expression]; the callee is responsible for calling
+       [self#typed ast type_name] on the AST to add a type annotation
+       that constrains its type.
+    *)
+    type_name:string ->
+    result
+
+  val location : location -> result
+  val location_stack : (location -> result) option
+  val attributes : (location -> result) option
+  val coalesce : (expression -> (expression -> result) -> result) option
+
+  class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters
+end) =
+struct
+  let lift loc =
+    object (self)
+      inherit [M.result] Ast_traverse.lift as super
+      inherit! M.std_lifters loc
+
+      method typed ast name =
+        let loc = { loc with loc_ghost = true } in
+        M.annotate ast
+          (ptyp_constr ~loc
+             { loc; txt = Ldot (Ldot (Lident "Ppxlib_ast", "Ast"), name) }
+             [])
+
+      method! attribute x =
+        Attribute.mark_as_handled_manually x;
+        super#attribute x
+
+      method! location _ = M.location loc
+
+      method! attributes x =
+        match M.attributes with
+        | None -> super#attributes x
+        | Some f ->
+            assert_no_attributes x;
+            f loc
+
+      method! location_stack x =
+        match M.location_stack with
+        | None -> super#location_stack x
+        | Some f -> f loc
+
+      method! expression e =
+        match (M.coalesce, e.pexp_desc) with
+        | _, Pexp_extension (({ txt = "e"; _ }, _) as ext) ->
+            let attributes =
+              {
+                quoted_attributes = e.pexp_attributes;
+                field_name = "pexp_attributes";
+              }
+            in
+            M.cast self ext (Some attributes) ~type_name:"expression"
+        | Some f, _ -> f e super#expression
+        | None, _ -> super#expression e
+
+      method! pattern p =
+        match p.ppat_desc with
+        | Ppat_extension (({ txt = "p"; _ }, _) as ext) ->
+            let attributes =
+              {
+                quoted_attributes = p.ppat_attributes;
+                field_name = "ppat_attributes";
+              }
+            in
+            M.cast self ext (Some attributes) ~type_name:"pattern"
+        | _ -> super#pattern p
+
+      method! core_type t =
+        match t.ptyp_desc with
+        | Ptyp_extension (({ txt = "t"; _ }, _) as ext) ->
+            let attributes =
+              {
+                quoted_attributes = t.ptyp_attributes;
+                field_name = "ptyp_attributes";
+              }
+            in
+            M.cast self ext (Some attributes) ~type_name:"core_type"
+        | _ -> super#core_type t
+
+      method! module_expr m =
+        match m.pmod_desc with
+        | Pmod_extension (({ txt = "m"; _ }, _) as ext) ->
+            let attributes =
+              {
+                quoted_attributes = m.pmod_attributes;
+                field_name = "pmod_attributes";
+              }
+            in
+            M.cast self ext (Some attributes) ~type_name:"module_expr"
+        | _ -> super#module_expr m
+
+      method! module_type m =
+        match m.pmty_desc with
+        | Pmty_extension (({ txt = "m"; _ }, _) as ext) ->
+            let attributes =
+              {
+                quoted_attributes = m.pmty_attributes;
+                field_name = "pmty_attributes";
+              }
+            in
+            M.cast self ext (Some attributes) ~type_name:"module_type"
+        | _ -> super#module_type m
+
+      method! structure_item i =
+        match i.pstr_desc with
+        | Pstr_extension ((({ txt = "i"; _ }, _) as ext), attrs) ->
+            assert_no_attributes attrs;
+            M.cast self ext None ~type_name:"structure_item"
+        | _ -> super#structure_item i
+
+      method! signature_item i =
+        match i.psig_desc with
+        | Psig_extension ((({ txt = "i"; _ }, _) as ext), attrs) ->
+            assert_no_attributes attrs;
+            M.cast self ext None ~type_name:"signature_item"
+        | _ -> super#signature_item i
+    end
+end
+
+module Expr = Make (struct
+  type result = expression
+
+  let location loc = evar ~loc:{ loc with loc_ghost = true } "loc"
+  let location_stack = None
+  let attributes = None
+  let coalesce = Some coalesce_arity_expr
+
+  class std_lifters = Ppxlib_metaquot_lifters.expression_lifters
+
+  let annotate e core_type = pexp_constraint ~loc:core_type.ptyp_loc e core_type
+
+  (* Append the quoted attributes to the attributes present on the
+     antiquoted construct. Take this as example:
+
+     [%expr [%e e] [@attr]]
+
+     Suppose e has pexp_attributes = [attr1]. Then the resulting attributes
+     are [ attr1; [@attr] ]. The decision to put outer attributes (here,
+     [@attr]) at the end of the list is consistent with other parts of ppxlib
+     that accumulate attributes.
+  *)
+  let add_quoted_attributes self e { quoted_attributes; field_name } ~type_name
+      ~loc =
+    match quoted_attributes with
+    | [] -> self#typed e type_name
+    | _ :: _ ->
+        let loc = { loc with loc_ghost = true } in
+        let var = gen_symbol ~prefix:"_ppx_metaquot_helper_var" () in
+        let var_expr = pexp_ident ~loc (Located.mk ~loc (Lident var)) in
+        let field_name = Located.mk ~loc (Lident field_name) in
+        let reified_attrs = self#attributes quoted_attributes in
+        (* append arg1 arg2 = [%expr Stdlib.List.append [%e arg1] [%e arg2]] *)
+        let append arg1 arg2 =
+          pexp_apply ~loc
+            (pexp_ident ~loc
+               (Located.mk ~loc
+                  (Ldot (Ldot (Lident "Stdlib", "List"), "append"))))
+            [ (Nolabel, arg1); (Nolabel, arg2) ]
+        in
+        (*
+         Morally,
+         {[
+           let var = ([%expr e] : [%type: type_name]) in
+           { var
+             with pexp_attributes = var.pexp_attributes @ [%e reified_attrs ]
+           }
+         ]}
+        *)
+        pexp_let Nonrecursive ~loc
+          [
+            value_binding ~loc
+              ~pat:(ppat_var ~loc (Located.mk ~loc var))
+              ~expr:(self#typed e type_name);
+          ]
+          (pexp_record ~loc
+             [
+               ( field_name,
+                 append (pexp_field ~loc var_expr field_name) reified_attrs );
+             ]
+             (Some var_expr))
+
+  let cast self ext attrs ~type_name =
+    match snd ext with
+    | PStr [ { pstr_desc = Pstr_eval (e, inner_attrs); _ } ] -> (
+        assert_no_attributes inner_attrs;
+        match attrs with
+        | None -> self#typed e type_name
+        | Some quoted_attrs ->
+            add_quoted_attributes self e quoted_attrs ~type_name
+              ~loc:(loc_of_extension ext))
+    | _ ->
+        pexp_extension ~loc:(loc_of_extension ext)
+          (Location.error_extensionf ~loc:(loc_of_extension ext)
+             "expression expected")
+end)
+
+module Patt = Make (struct
+  type result = pattern
+
+  let location loc = ppat_any ~loc:{ loc with loc_ghost = true }
+
+  let location_stack =
+    Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true })
+
+  let attributes = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true })
+  let coalesce = Some coalesce_arity_pat
+
+  class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters
+
+  let annotate p core_type = ppat_constraint ~loc:core_type.ptyp_loc p core_type
+
+  let cast self ext attrs ~type_name =
+    match snd ext with
+    | PPat (p, None) ->
+        (match attrs with
+        | None -> ()
+        | Some { quoted_attributes; field_name = _ } ->
+            assert_no_attributes quoted_attributes);
+        self#typed p type_name
+    | PPat (_, Some e) ->
+        Ast_builder.Default.(
+          ppat_extension ~loc:e.pexp_loc
+            (Location.error_extensionf ~loc:e.pexp_loc "guard not expected here"))
+    | _ ->
+        Ast_builder.Default.(
+          ppat_extension ~loc:(loc_of_extension ext)
+            (Location.error_extensionf ~loc:(loc_of_extension ext)
+               "pattern expected"))
+end)
+
+let () =
+  let extensions ctx lifter =
+    [
+      E.declare "metaquot.expr" ctx
+        A.(single_expr_payload __)
+        (fun ~loc ~path:_ e ->
+          let lift = lifter loc in
+          lift#typed (lift#expression e) "expression");
+      E.declare "metaquot.pat" ctx
+        A.(ppat __ none)
+        (fun ~loc ~path:_ p ->
+          let lift = lifter loc in
+          lift#typed (lift#pattern p) "pattern");
+      E.declare "metaquot.str" ctx
+        A.(pstr __)
+        (fun ~loc ~path:_ s ->
+          let lift = lifter loc in
+          lift#typed (lift#structure s) "structure");
+      E.declare "metaquot.stri" ctx
+        A.(pstr (__ ^:: nil))
+        (fun ~loc ~path:_ s ->
+          let lift = lifter loc in
+          lift#typed (lift#structure_item s) "structure_item");
+      E.declare "metaquot.sig" ctx
+        A.(psig __)
+        (fun ~loc ~path:_ s ->
+          let lift = lifter loc in
+          lift#typed (lift#signature s) "signature");
+      E.declare "metaquot.sigi" ctx
+        A.(psig (__ ^:: nil))
+        (fun ~loc ~path:_ s ->
+          let lift = lifter loc in
+          lift#typed (lift#signature_item s) "signature_item");
+      E.declare "metaquot.type" ctx
+        A.(ptyp __)
+        (fun ~loc ~path:_ t ->
+          let lift = lifter loc in
+          lift#typed (lift#core_type t) "core_type");
+    ]
+  in
+  let extensions =
+    extensions Expression Expr.lift @ extensions Pattern Patt.lift
+  in
+  Driver.register_transformation "metaquot" ~extensions