unikernel/duniverse/ppxlib/metaquot_lifters/ppxlib_metaquot_lifters.ml

@@ -0,0 +1,65 @@
+open Stdppx
+open Ppxlib
+open Ast_builder.Default
+
+class expression_lifters loc =
+  let loc = { loc with loc_ghost = true } in
+  object
+    inherit [expression] Ppxlib_traverse_builtins.lift
+
+    method record flds =
+      pexp_record ~loc
+        (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e)))
+        None
+
+    method constr id args =
+      pexp_construct ~loc { loc; txt = Lident id }
+        (match args with [] -> None | l -> Some (pexp_tuple ~loc l))
+
+    method tuple l = pexp_tuple ~loc l
+    method int i = eint ~loc i
+    method int32 i = eint32 ~loc i
+    method int64 i = eint64 ~loc i
+    method nativeint i = enativeint ~loc i
+    method float f = efloat ~loc (Float.to_string f)
+    method string s = estring ~loc s
+    method char c = echar ~loc c
+    method bool b = ebool ~loc b
+
+    method array : 'a. ('a -> expression) -> 'a array -> expression =
+      fun f a -> pexp_array ~loc (List.map (Array.to_list a) ~f)
+
+    method unit () = eunit ~loc
+    method other : 'a. 'a -> expression = fun _ -> failwith "not supported"
+  end
+
+class pattern_lifters loc =
+  let loc = { loc with loc_ghost = true } in
+  object
+    inherit [pattern] Ppxlib_traverse_builtins.lift
+
+    method record flds =
+      ppat_record ~loc
+        (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e)))
+        Closed
+
+    method constr id args =
+      ppat_construct ~loc { loc; txt = Lident id }
+        (match args with [] -> None | l -> Some (ppat_tuple ~loc l))
+
+    method tuple l = ppat_tuple ~loc l
+    method int i = pint ~loc i
+    method int32 i = pint32 ~loc i
+    method int64 i = pint64 ~loc i
+    method nativeint i = pnativeint ~loc i
+    method float f = pfloat ~loc (Float.to_string f)
+    method string s = pstring ~loc s
+    method char c = pchar ~loc c
+    method bool b = pbool ~loc b
+
+    method array : 'a. ('a -> pattern) -> 'a array -> pattern =
+      fun f a -> ppat_array ~loc (List.map (Array.to_list a) ~f)
+
+    method unit () = punit ~loc
+    method other : 'a. 'a -> pattern = fun _ -> failwith "not supported"
+  end