├── .gitignore
├── README.md
├── lib.ml.in
├── .ocamlinit
├── Makefile
├── psql.ml
└── myppx_ppx.ml


/.gitignore:
--------------------------------------------------------------------------------
1 | /lib.ml
2 | /myppx_ppx
3 | *.cmi
4 | *.cmx
5 | *.o
6 | 
7 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | This repo contains a very basic example of how to implement a PPX
2 | based syntax extension in OCaml.
3 | 


--------------------------------------------------------------------------------
/lib.ml.in:
--------------------------------------------------------------------------------
1 | open Core.Std
2 | 
3 | type user = {
4 |   id : int32;
5 |   name : string;
6 |   password : string;
7 | } [@@myppx]
8 | 


--------------------------------------------------------------------------------
/.ocamlinit:
--------------------------------------------------------------------------------
 1 | let () =
 2 |   try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH")
 3 |   with Not_found -> ()
 4 | ;;
 5 | 
 6 | #use "topfind";;
 7 | #require "core";;
 8 | open Core.Std;;
 9 | #require "ppx_tools.metaquot";;
10 | #require "ppx_deriving.std";;
11 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
 1 | PACKAGES=core,compiler-libs.common,ppx_tools.metaquot
 2 | FLAGS=-thread -safe-string -short-paths -package $(PACKAGES)
 3 | 
 4 | all: lib.ml
 5 | 
 6 | myppx_ppx: myppx_ppx.ml
 7 | 	ocamlfind ocamlopt $(FLAGS) -linkpkg $< -o myppx_ppx
 8 | 
 9 | psql.cmx: psql.ml
10 | 	ocamlfind ocamlopt $(FLAGS) -c $<
11 | 
12 | lib.ml: lib.ml.in myppx_ppx psql.cmx
13 | 	ocamlfind ocamlopt $(FLAGS) -c -dsource -ppx ./myppx_ppx -impl $< 2>| $@
14 | 
15 | .PHONY: clean
16 | clean:
17 | 	rm -rf *.{cmi,cmx,o} myppx_ppx lib.ml
18 | 


--------------------------------------------------------------------------------
/psql.ml:
--------------------------------------------------------------------------------
 1 | open Core.Std
 2 | open Asttypes
 3 | open Parsetree
 4 | open Longident
 5 | open Ast_helper
 6 | open Ast_convenience
 7 | 
 8 | type t = [`Int32 | `Text | `Timestamptz | `Interval | `Uuid]
 9 | 
10 | let t_of_ocaml_type (t:core_type) : t =
11 |   match t with
12 |   | [%type: int32] -> `Int32
13 |   | [%type: string] -> `Text
14 |   | [%type: Time.t] -> `Timestamptz
15 |   | [%type: Time.Span.t] -> `Interval
16 |   | [%type: Uuid.t] -> `Uuid
17 |   | _ -> failwith "unsupported type"
18 | 
19 | let t_to_ocaml_type (t:t) : core_type =
20 |   match t with
21 |   | `Int32 -> [%type: int32]
22 |   | `Text -> [%type: string]
23 |   | `Timestamptz -> [%type: Time.t]
24 |   | `Interval -> [%type: Time.Span.t]
25 |   | `Uuid ->
26 |     let x : core_type = [%type: Uuid.t] in
27 |     [%type: [%t x]]
28 | 


--------------------------------------------------------------------------------
/myppx_ppx.ml:
--------------------------------------------------------------------------------
 1 | open Core.Std
 2 | open Asttypes
 3 | open Parsetree
 4 | 
 5 | let error msg =
 6 |   Or_error.error_string msg
 7 |   |> fun x -> Or_error.tag x "[@@myppx]"
 8 |   |> ok_exn
 9 | 
10 | let structure_items_of_type_declaration (t:type_declaration) : structure_item list =
11 |   if t.ptype_params <> [] then
12 |     error "type parameters not allowed"
13 |   else if t.ptype_cstrs <> [] then
14 |     error "type constraints not allowed"
15 |   else match t.ptype_kind with
16 |   | Ptype_abstract
17 |   | Ptype_variant _
18 |   | Ptype_open
19 |     -> error "only record types allowed"
20 |   | Ptype_record label_decs -> [
21 |     [%stri
22 |      let x = 42
23 |     ]
24 |   ]
25 | 
26 | let structure_items_of_item mapper (x : structure_item) : structure_item list =
27 |   let x = mapper.Ast_mapper.structure_item mapper x in
28 |   match x.pstr_desc with
29 |   | Pstr_type (t::[]) -> (
30 |     match Ast_convenience.find_attr "myppx" t.ptype_attributes with
31 |     | None -> [x]
32 |     | Some (PPat _) | Some (PTyp _) | Some (PStr (_::_)) ->
33 |       error "expected empty payload"
34 |     | Some (PStr []) ->
35 |       let x = {x with pstr_desc = (Pstr_type [t])} in
36 |       x::(structure_items_of_type_declaration t)
37 |   )
38 |   | _ -> [x]
39 | ;;
40 | 
41 | let structure_mapper mapper structure =
42 |   List.map structure ~f:(structure_items_of_item mapper)
43 |   |> List.concat
44 | 
45 | let mapper = Ast_mapper.{default_mapper with
46 |   structure = structure_mapper;
47 | }
48 | 
49 | let () = Ast_mapper.run_main(fun _argv -> mapper)
50 | 


--------------------------------------------------------------------------------