PPX Hacks for Context

# PPX Hacks for OCaml Context I had this problem where I wanted to be able to create an extensible list of variants... but have the variants be closed after I was done with them. This is going to be useful for creating various contexts and middlewares in my OCaml SaaS framework I'm building. That's a problem for another day to explain fully, but I just wanted to show that writing two PPX's to hack this together was actually quite easy! PPX doesn't have to be intimidating! There's basically two different PPX that we have to construct. The first is for deriving our `context`, which looks like this: ```neovim <pre> let args () = Deriving.Args.(empty) let generate_impl ~ctxt (_, (type_declarations : type_declaration list)) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in let ty = match type_declarations with | [ ty ] -> ty | _ -> Util.throw ~loc "ppx_table requires exactly one type declaration" in match ty with | { ptype_manifest = Some { ptyp_desc = Ptyp_variant ([ { prf_desc = Rtag (x, _, [ t ]); _ } ], _, _) } ; _ } -> let open Ast_builder.Default in let construct = pexp_variant ~loc x.txt (Some [%expr value]) in let pat = ppat_variant ~loc x.txt (Some (ppat_var ~loc @@ Loc.make ~loc "s")) in [ [%stri let t (value : [%t t]) = [%e construct]] ; [%stri let get (l : [> t ] list) : [%t t] = Stdlib.List.find_map (function | [%p pat] -> Some s | _ -> None) l |> Stdlib.Option.get ;;] ] | _ -> Util.throw ~loc "ppx_drive: context can only be applied to a single variant type" ;; let generator () = Deriving.Generator.V2.make (args ()) generate_impl let my_deriver = Deriving.add "context" ~str_type_decl:(generator ())</pre> ``` And the second PPX we have to create is for taking a list of contexts (all polymorphic variants) and created a list that is closed over their types. ```neovim <pre> let query_rule = let context = Extension.Context.structure_item in let extracter () = let open Ast_pattern in let pat = ppat_var __ in let binding = value_binding ~pat ~expr:(elist __) in pstr (pstr_value nonrecursive (binding ^:: nil) ^:: nil) in let my_extender = Extension.V3.declare "context" context (extracter ()) @@ fun ~ctxt pat query -> let open Ast_builder.Default in let loc = Expansion_context.Extension.extension_point_loc ctxt in let ty_ctx = List.fold query ~init:[] ~f:(fun acc expr -> match expr with | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident { txt = Ldot (Lident m, "t") as txt }; _ }, _) ; pexp_loc } -> let t = ptyp_constr ~loc { txt; loc } [] in let f = { prf_desc = Rinherit t; prf_loc = pexp_loc; prf_attributes = [] } in f :: acc | _ -> Util.throw ~loc "ppx_drive: expressions must be a Module.t") in let ty = ptyp_variant ~loc ty_ctx Closed None in let query = elist ~loc query in [%stri let ctx : [%t ty] list = [%e query]] in Context_free.Rule.extension my_extender ;; Driver.register_transformation ~rules:[ query_rule ] "ppx_drive"</pre> ``` This let's us do some pretty easy & nifty tricks. I may make `deriving context` a little easier in the future - perhaps something like `let%context User = 'user string` or something, but it seems a little too magical... Anyway, this is what works now! ```neovim <pre> module User = struct type t = [ `user of string ] [@@deriving context] end module Log = struct type t = [ `log of string -> unit ] [@@deriving context] end (* let ctx : [ User.t | Log.t ] list = [ User.t "teej_dv"; Log.t print_endline ] *) let%context ctx = [ User.t "teej_dv"; Log.t print_endline ] let user = User.get ctx ``` This example works great! The `User.get` function retrieves the value from the context and is type safe! It doesn't return an option - but instead returns the actual value. And what's even better is that if we do not include a `User.t` value in the list, it will not work, like below! ```neovim <pre> let%context ctx = [ Log.t print_endline ] let user = User.get ctx └──── This expression has type Log.t list but an expression was expected of type [> User.t ] list Type Log.t = [ `log of string -> unit ] is not compatible with type [> User.t ] = [> `user of string ] The first variant type does not allow tag(s) `user </pre> ``` It even has a pretty reasonable error, all things considered.