Type Providers in OCaml: Compile-Time Code Generation

1(* Manual type definition - gets out of sync *)
2type market_data = {
3  symbol: string;
4  price: float;
5  volume: int;
6  timestamp: int64;
7}
8
9(* Runtime parsing - errors only at runtime *)
10let parse_json json =
11  {
12    symbol = Yojson.Basic.Util.member "symbol" json |> to_string;
13    price = Yojson.Basic.Util.member "price" json |> to_float;
14    volume = Yojson.Basic.Util.member "volume" json |> to_int;
15    timestamp = Yojson.Basic.Util.member "timestamp" json |> to_int;
16  }
17

1Source Code → PPX Rewriter → Modified AST → Compiler → Binary
2

1{
2  "type": "object",
3  "properties": {
4    "symbol": { "type": "string" },
5    "price": { "type": "number" },
6    "volume": { "type": "integer" },
7    "timestamp": { "type": "integer" }
8  },
9  "required": ["symbol", "price", "volume", "timestamp"]
10}
11

1(* User writes this *)
2type market_data = [%json_of_schema "schemas/market_data.json"]
3
4(* PPX generates this *)
5type market_data = {
6  symbol: string;
7  price: float;
8  volume: int;
9  timestamp: int64;
10}
11

1(* ppx_json_schema.ml *)
2open Ppxlib
3open Ast_builder.Default
4
5(* Schema parsing *)
6module Schema = struct
7  type json_type =
8    | String
9    | Number
10    | Integer
11    | Boolean
12    | Object of (string * json_type) list
13    | Array of json_type
14
15  let rec of_yojson = function
16    | `Assoc [("type", `String "string")] -> String
17    | `Assoc [("type", `String "number")] -> Number
18    | `Assoc [("type", `String "integer")] -> Integer
19    | `Assoc [("type", `String "boolean")] -> Boolean
20    | `Assoc fields ->
21        let type_field = List.assoc "type" fields in
22        (match type_field with
23         | `String "object" ->
24             let props = List.assoc "properties" fields in
25             (match props with
26              | `Assoc kvs ->
27                  Object (List.map (fun (k, v) -> (k, of_yojson v)) kvs)
28              | _ -> failwith "Invalid object properties")
29         | `String "array" ->
30             let items = List.assoc "items" fields in
31             Array (of_yojson items)
32         | _ -> failwith "Unknown type")
33    | _ -> failwith "Invalid schema"
34
35  let load_schema path =
36    let json = Yojson.Basic.from_file path in
37    of_yojson json
38end
39
40(* AST generation *)
41module Generator = struct
42  let rec ocaml_type_of_schema ~loc = function
43    | Schema.String -> [%type: string]
44    | Schema.Number -> [%type: float]
45    | Schema.Integer -> [%type: int64]
46    | Schema.Boolean -> [%type: bool]
47    | Schema.Object fields ->
48        let label_declarations =
49          List.map (fun (name, schema) ->
50            let type_ = ocaml_type_of_schema ~loc schema in
51            label_declaration ~loc
52              ~name:(Located.mk ~loc name)
53              ~mutable_:Immutable
54              ~type_
55          ) fields
56        in
57        ptyp_constr ~loc
58          (Located.mk ~loc (Longident.Lident "record"))
59          [ptyp_record ~loc label_declarations Closed]
60    | Schema.Array item_schema ->
61        let item_type = ocaml_type_of_schema ~loc item_schema in
62        [%type: [%t item_type] list]
63
64  let generate_type ~loc ~path schema =
65    let core_type = ocaml_type_of_schema ~loc schema in
66    pstr_type ~loc Recursive
67      [type_declaration ~loc
68         ~name:(Located.mk ~loc "t")
69         ~params:[]
70         ~cstrs:[]
71         ~kind:(Ptype_abstract)
72         ~private_:Public
73         ~manifest:(Some core_type)]
74
75  let generate_parser ~loc schema =
76    let rec gen_parser = function
77      | Schema.String ->
78          [%expr Yojson.Basic.Util.to_string]
79      | Schema.Number ->
80          [%expr Yojson.Basic.Util.to_float]
81      | Schema.Integer ->
82          [%expr fun json ->
83            Yojson.Basic.Util.to_int json |> Int64.of_int]
84      | Schema.Boolean ->
85          [%expr Yojson.Basic.Util.to_bool]
86      | Schema.Object fields ->
87          let field_parsers =
88            List.map (fun (name, field_schema) ->
89              let parser = gen_parser field_schema in
90              [%expr
91                [%e estring ~loc name],
92                (fun json ->
93                  Yojson.Basic.Util.member [%e estring ~loc name] json
94                  |> [%e parser])]
95            ) fields
96          in
97          [%expr fun json ->
98            let open Yojson.Basic.Util in
99            { [%e
100              pexp_record ~loc
101                (List.map (fun (name, _) ->
102                  (Located.mk ~loc (Longident.Lident name),
103                   [%expr member [%e estring ~loc name] json
104                     |> [%e gen_parser (List.assoc name fields)]])
105                ) fields)
106                None
107            ] }]
108      | Schema.Array item_schema ->
109          let item_parser = gen_parser item_schema in
110          [%expr fun json ->
111            Yojson.Basic.Util.to_list json
112            |> List.map [%e item_parser]]
113    in
114    [%stri let of_json json = [%e gen_parser schema] json]
115end
116
117(* PPX extension *)
118let expand ~loc ~path (schema_path : string) =
119  (* Load schema at compile time *)
120  let schema = Schema.load_schema schema_path in
121  
122  (* Generate type and parser *)
123  [
124    Generator.generate_type ~loc ~path schema;
125    Generator.generate_parser ~loc schema;
126  ]
127
128let extension =
129  Extension.declare
130    "json_of_schema"
131    Extension.Context.structure_item
132    Ast_pattern.(single_expr_payload (estring __))
133    expand
134
135let rule = Context_free.Rule.extension extension
136
137let () =
138  Driver.register_transformation
139    ~rules:[rule]
140    "ppx_json_schema"
141

1(* market_data.ml *)
2
3(* Schema file: schemas/market_data.json *)
4type t = [%json_of_schema "schemas/market_data.json"]
5(* Generates:
6   type t = {
7     symbol: string;
8     price: float;
9     volume: int64;
10     timestamp: int64;
11   }
12   
13   val of_json : Yojson.Basic.t -> t
14*)
15
16(* Usage *)
17let parse_market_data json_string =
18  Yojson.Basic.from_string json_string
19  |> of_json
20
21(* Compile-time errors if schema changes *)
22let get_price data = data.price  (* Type-safe! *)
23

1CREATE TABLE orders (
2  id BIGSERIAL PRIMARY KEY,
3  client_id BIGINT NOT NULL,
4  symbol VARCHAR(10) NOT NULL,
5  side VARCHAR(4) NOT NULL,
6  quantity BIGINT NOT NULL,
7  price DECIMAL(18, 8) NOT NULL,
8  status VARCHAR(20) NOT NULL,
9  created_at TIMESTAMP NOT NULL
10);
11

1(* ppx_sql_schema.ml *)
2open Ppxlib
3
4module Database = struct
5  type sql_type =
6    | BigInt
7    | VarChar of int
8    | Decimal of int * int
9    | Timestamp
10    | Boolean
11
12  type column = {
13    name: string;
14    sql_type: sql_type;
15    nullable: bool;
16  }
17
18  type table = {
19    name: string;
20    columns: column list;
21  }
22
23  (* Connect and introspect database *)
24  let introspect_table ~connection_string ~table_name =
25    let conn = Postgresql.new_connection connection_string in
26    let query = Printf.sprintf
27      "SELECT column_name, data_type, is_nullable, \
28              character_maximum_length, numeric_precision, numeric_scale \
29       FROM information_schema.columns \
30       WHERE table_name = '%s' \
31       ORDER BY ordinal_position"
32      table_name
33    in
34    let result = conn#exec query in
35    
36    let columns = ref [] in
37    for i = 0 to result#ntuples - 1 do
38      let name = result#getvalue i 0 in
39      let data_type = result#getvalue i 1 in
40      let nullable = result#getvalue i 2 = "YES" in
41      
42      let sql_type = match data_type with
43        | "bigint" | "bigserial" -> BigInt
44        | "character varying" ->
45            let len = int_of_string (result#getvalue i 3) in
46            VarChar len
47        | "numeric" ->
48            let prec = int_of_string (result#getvalue i 4) in
49            let scale = int_of_string (result#getvalue i 5) in
50            Decimal (prec, scale)
51        | "timestamp without time zone" -> Timestamp
52        | "boolean" -> Boolean
53        | _ -> failwith ("Unsupported type: " ^ data_type)
54      in
55      
56      columns := { name; sql_type; nullable } :: !columns
57    done;
58    
59    conn#finish;
60    { name = table_name; columns = List.rev !columns }
61end
62
63module Generator = struct
64  let ocaml_type_of_sql ~loc ~nullable = function
65    | Database.BigInt ->
66        if nullable then [%type: int64 option]
67        else [%type: int64]
68    | Database.VarChar _ ->
69        if nullable then [%type: string option]
70        else [%type: string]
71    | Database.Decimal _ ->
72        if nullable then [%type: float option]
73        else [%type: float]
74    | Database.Timestamp ->
75        if nullable then [%type: Ptime.t option]
76        else [%type: Ptime.t]
77    | Database.Boolean ->
78        if nullable then [%type: bool option]
79        else [%type: bool]
80
81  let generate_record_type ~loc table =
82    let fields =
83      List.map (fun col ->
84        let type_ =
85          ocaml_type_of_sql ~loc ~nullable:col.nullable col.sql_type
86        in
87        label_declaration ~loc
88          ~name:(Located.mk ~loc col.name)
89          ~mutable_:Immutable
90          ~type_
91      ) table.Database.columns
92    in
93    
94    pstr_type ~loc Recursive
95      [type_declaration ~loc
96         ~name:(Located.mk ~loc "t")
97         ~params:[]
98         ~cstrs:[]
99         ~kind:(Ptype_record fields)
100         ~private_:Public
101         ~manifest:None]
102
103  let generate_query_builder ~loc table =
104    let table_name = table.Database.name in
105    
106    [%stri
107      let select_all () =
108        let query = [%e estring ~loc
109          (Printf.sprintf "SELECT * FROM %s" table_name)]
110        in
111        fun conn ->
112          let result = conn#exec query in
113          let rows = ref [] in
114          for i = 0 to result#ntuples - 1 do
115            let row = {
116              [%e pexp_record ~loc
117                (List.mapi (fun idx col ->
118                  (Located.mk ~loc (Longident.Lident col.Database.name),
119                   [%expr
120                     let v = result#getvalue i [%e eint ~loc idx] in
121                     (* Parse based on type *)
122                     [%e match col.sql_type with
123                       | BigInt -> [%expr Int64.of_string v]
124                       | VarChar _ -> [%expr v]
125                       | Decimal _ -> [%expr Float.of_string v]
126                       | Timestamp -> [%expr Ptime.of_rfc3339 v |> Result.get_ok |> fst]
127                       | Boolean -> [%expr bool_of_string v]
128                     ]
129                   ])
130                ) table.columns)
131                None]
132            } in
133            rows := row :: !rows
134          done;
135          List.rev !rows
136      
137      let insert row =
138        let columns = [%e elist ~loc
139          (List.map (fun col -> estring ~loc col.Database.name) table.columns)]
140        in
141        let values = [%e elist ~loc
142          (List.map (fun col ->
143            [%expr [%e evar ~loc ("row." ^ col.Database.name)]]
144          ) table.columns)]
145        in
146        fun conn ->
147          let query = Printf.sprintf
148            "INSERT INTO %s (%s) VALUES (%s)"
149            [%e estring ~loc table_name]
150            (String.concat ", " columns)
151            (String.concat ", "
152              (List.map (fun _ -> "?") columns))
153          in
154          conn#exec ~params:values query
155    ]
156end
157
158let expand ~loc ~path (connection_string : string) (table_name : string) =
159  (* Introspect at compile time *)
160  let table = Database.introspect_table ~connection_string ~table_name in
161  
162  [
163    Generator.generate_record_type ~loc table;
164    Generator.generate_query_builder ~loc table;
165  ]
166
167let extension =
168  Extension.declare
169    "sql_table"
170    Extension.Context.structure_item
171    Ast_pattern.(
172      single_expr_payload (
173        pexp_tuple (estring __ ^:: estring __ ^:: nil)))
174    (fun ~loc ~path conn table -> expand ~loc ~path conn table)
175
176let () =
177  Driver.register_transformation
178    ~rules:[Context_free.Rule.extension extension]
179    "ppx_sql_schema"
180

1(* orders.ml *)
2module%sql_table Orders = ("postgresql://localhost/trading", "orders")
3(* Generates:
4   type t = {
5     id: int64;
6     client_id: int64;
7     symbol: string;
8     side: string;
9     quantity: int64;
10     price: float;
11     status: string;
12     created_at: Ptime.t;
13   }
14   
15   val select_all : unit -> Postgresql.connection -> t list
16   val insert : t -> Postgresql.connection -> unit
17*)
18
19(* Usage *)
20let () =
21  let conn = Postgresql.new_connection "postgresql://localhost/trading" in
22  
23  (* Type-safe queries *)
24  let orders = Orders.select_all () conn in
25  List.iter (fun order ->
26    Printf.printf "Order %Ld: %s %Ld @ %.2f\n"
27      order.id order.symbol order.quantity order.price
28  ) orders;
29  
30  (* Type-safe insert *)
31  Orders.insert {
32    id = 0L;  (* Auto-generated *)
33    client_id = 123L;
34    symbol = "AAPL";
35    side = "BUY";
36    quantity = 100L;
37    price = 150.25;
38    status = "NEW";
39    created_at = Ptime_clock.now ();
40  } conn
41

1(* ppx_csv.ml *)
2open Ppxlib
3
4module CSV = struct
5  type column = {
6    name: string;
7    inferred_type: string;
8  }
9
10  let load_and_infer path =
11    let ic = open_in path in
12    let header = input_line ic in
13    let columns = String.split_on_char ',' header in
14    
15    (* Read first row to infer types *)
16    let first_row = input_line ic in
17    let values = String.split_on_char ',' first_row in
18    close_in ic;
19    
20    List.map2 (fun name value ->
21      let inferred_type =
22        if String.contains value '.' then "float"
23        else
24          try
25            let _ = Int64.of_string value in
26            "int64"
27          with _ -> "string"
28      in
29      { name; inferred_type }
30    ) columns values
31end
32
33module Generator = struct
34  let generate_type ~loc columns =
35    let fields =
36      List.map (fun col ->
37        let type_ = match col.CSV.inferred_type with
38          | "float" -> [%type: float]
39          | "int64" -> [%type: int64]
40          | _ -> [%type: string]
41        in
42        label_declaration ~loc
43          ~name:(Located.mk ~loc col.name)
44          ~mutable_:Immutable
45          ~type_
46      ) columns
47    in
48    
49    pstr_type ~loc Recursive
50      [type_declaration ~loc
51         ~name:(Located.mk ~loc "t")
52         ~params:[]
53         ~cstrs:[]
54         ~kind:(Ptype_record fields)
55         ~private_:Public
56         ~manifest:None]
57
58  let generate_parser ~loc columns =
59    [%stri
60      let of_row row =
61        let fields = String.split_on_char ',' row in
62        {
63          [%e pexp_record ~loc
64            (List.mapi (fun idx col ->
65              let parse_expr = match col.CSV.inferred_type with
66                | "float" -> [%expr Float.of_string (List.nth fields [%e eint ~loc idx])]
67                | "int64" -> [%expr Int64.of_string (List.nth fields [%e eint ~loc idx])]
68                | _ -> [%expr List.nth fields [%e eint ~loc idx]]
69              in
70              (Located.mk ~loc (Longident.Lident col.name), parse_expr)
71            ) columns)
72            None]
73        }
74      
75      let load_file path =
76        let ic = open_in path in
77        let _ = input_line ic in  (* Skip header *)
78        let rows = ref [] in
79        try
80          while true do
81            let line = input_line ic in
82            rows := of_row line :: !rows
83          done;
84          List.rev !rows
85        with End_of_file ->
86          close_in ic;
87          List.rev !rows
88    ]
89end
90
91let expand ~loc ~path csv_path =
92  let columns = CSV.load_and_infer csv_path in
93  [
94    Generator.generate_type ~loc columns;
95    Generator.generate_parser ~loc columns;
96  ]
97
98let extension =
99  Extension.declare
100    "csv_schema"
101    Extension.Context.structure_item
102    Ast_pattern.(single_expr_payload (estring __))
103    expand
104
105let () =
106  Driver.register_transformation
107    ~rules:[Context_free.Rule.extension extension]
108    "ppx_csv"
109

1(* market_data.csv:
2   symbol,price,volume,timestamp
3   AAPL,150.25,1000000,1609459200
4   GOOGL,2800.50,500000,1609459201
5*)
6
7type market_data = [%csv_schema "data/market_data.csv"]
8(* Generates:
9   type t = {
10     symbol: string;
11     price: float;
12     volume: int64;
13     timestamp: int64;
14   }
15   
16   val of_row : string -> t
17   val load_file : string -> t list
18*)
19
20let () =
21  let data = market_data.load_file "data/market_data.csv" in
22  List.iter (fun row ->
23    Printf.printf "%s: $%.2f (%Ld shares)\n"
24      row.symbol row.price row.volume
25  ) data
26

1// order.proto
2syntax = "proto3";
3
4message Order {
5  int64 id = 1;
6  string symbol = 2;
7  string side = 3;
8  int64 quantity = 4;
9  double price = 5;
10  int64 timestamp = 6;
11}
12

1(* ppx_protobuf.ml *)
2open Ppxlib
3
4module Protobuf = struct
5  type field_type =
6    | Int32
7    | Int64
8    | Double
9    | String
10    | Bool
11    | Message of string
12
13  type field = {
14    name: string;
15    field_type: field_type;
16    number: int;
17  }
18
19  type message = {
20    name: string;
21    fields: field list;
22  }
23
24  (* Parse .proto file *)
25  let parse_proto_file path =
26    let ic = open_in path in
27    let content = really_input_string ic (in_channel_length ic) in
28    close_in ic;
29    
30    (* Simple regex-based parser *)
31    let message_re = Str.regexp "message \\([A-Za-z0-9_]+\\) {\\([^}]+\\)}" in
32    let field_re = Str.regexp "\\([a-z0-9]+\\) \\([a-z_]+\\) = \\([0-9]+\\);" in
33    
34    let messages = ref [] in
35    let pos = ref 0 in
36    
37    while !pos < String.length content do
38      try
39        let _ = Str.search_forward message_re content !pos in
40        let name = Str.matched_group 1 content in
41        let body = Str.matched_group 2 content in
42        
43        let fields = ref [] in
44        let field_pos = ref 0 in
45        while !field_pos < String.length body do
46          try
47            let _ = Str.search_forward field_re body !field_pos in
48            let type_str = Str.matched_group 1 body in
49            let field_name = Str.matched_group 2 body in
50            let number = int_of_string (Str.matched_group 3 body) in
51            
52            let field_type = match type_str with
53              | "int32" -> Int32
54              | "int64" -> Int64
55              | "double" -> Double
56              | "string" -> String
57              | "bool" -> Bool
58              | msg -> Message msg
59            in
60            
61            fields := { name = field_name; field_type; number } :: !fields;
62            field_pos := Str.match_end ()
63          with Not_found ->
64            field_pos := String.length body
65        done;
66        
67        messages := { name; fields = List.rev !fields } :: !messages;
68        pos := Str.match_end ()
69      with Not_found ->
70        pos := String.length content
71    done;
72    
73    List.rev !messages
74end
75
76module Generator = struct
77  let ocaml_type_of_proto ~loc = function
78    | Protobuf.Int32 -> [%type: int32]
79    | Protobuf.Int64 -> [%type: int64]
80    | Protobuf.Double -> [%type: float]
81    | Protobuf.String -> [%type: string]
82    | Protobuf.Bool -> [%type: bool]
83    | Protobuf.Message msg ->
84        ptyp_constr ~loc (Located.mk ~loc (Longident.Lident msg)) []
85
86  let generate_message ~loc message =
87    let fields =
88      List.map (fun field ->
89        let type_ = ocaml_type_of_proto ~loc field.Protobuf.field_type in
90        label_declaration ~loc
91          ~name:(Located.mk ~loc field.name)
92          ~mutable_:Immutable
93          ~type_
94      ) message.Protobuf.fields
95    in
96    
97    [
98      pstr_type ~loc Recursive
99        [type_declaration ~loc
100           ~name:(Located.mk ~loc (String.lowercase_ascii message.name))
101           ~params:[]
102           ~cstrs:[]
103           ~kind:(Ptype_record fields)
104           ~private_:Public
105           ~manifest:None];
106      
107      (* Encoding function *)
108      [%stri
109        let encode msg =
110          let buf = Pbrt.Encoder.create () in
111          [%e
112            pexp_sequence ~loc
113              (List.map (fun field ->
114                let encode_fn = match field.Protobuf.field_type with
115                  | Int64 -> "int64"
116                  | Int32 -> "int32"
117                  | Double -> "double"
118                  | String -> "string"
119                  | Bool -> "bool"
120                  | Message _ -> "message"
121                in
122                [%expr
123                  Pbrt.Encoder.[%e evar ~loc ("encode_" ^ encode_fn)]
124                    [%e eint ~loc field.number]
125                    msg.[%e evar ~loc field.name]
126                    buf]
127              ) message.fields)
128          ];
129          Pbrt.Encoder.to_bytes buf
130      ];
131      
132      (* Decoding function *)
133      [%stri
134        let decode bytes =
135          let decoder = Pbrt.Decoder.of_bytes bytes in
136          let rec read_fields [%p pvar ~loc "acc"] =
137            match Pbrt.Decoder.read_field decoder with
138            | Some (field_number, field_type) ->
139                [%e
140                  pexp_match ~loc
141                    [%expr field_number]
142                    (List.map (fun field ->
143                      case ~lhs:(pint ~loc field.Protobuf.number)
144                        ~guard:None
145                        ~rhs:[%expr
146                          let value = [%e match field.field_type with
147                            | Int64 -> [%expr Pbrt.Decoder.int64 decoder]
148                            | Int32 -> [%expr Pbrt.Decoder.int32 decoder]
149                            | Double -> [%expr Pbrt.Decoder.double decoder]
150                            | String -> [%expr Pbrt.Decoder.string decoder]
151                            | Bool -> [%expr Pbrt.Decoder.bool decoder]
152                            | Message _ -> [%expr failwith "nested messages not implemented"]
153                          ] in
154                          read_fields {
155                            acc with [%e evar ~loc field.name] = value
156                          }]
157                    ) message.fields @
158                    [case ~lhs:(ppat_any ~loc)
159                       ~guard:None
160                       ~rhs:[%expr
161                         Pbrt.Decoder.skip decoder field_type;
162                         read_fields acc]])
163            | None -> acc
164          in
165          read_fields [%e
166            pexp_record ~loc
167              (List.map (fun field ->
168                (Located.mk ~loc (Longident.Lident field.Protobuf.name),
169                 match field.field_type with
170                 | Int64 -> [%expr 0L]
171                 | Int32 -> [%expr 0l]
172                 | Double -> [%expr 0.0]
173                 | String -> [%expr ""]
174                 | Bool -> [%expr false]
175                 | Message _ -> [%expr failwith "default message"])
176              ) message.fields)
177              None]
178      ];
179    ]
180end
181
182let expand ~loc ~path proto_path =
183  let messages = Protobuf.parse_proto_file proto_path in
184  List.concat_map (Generator.generate_message ~loc) messages
185
186let extension =
187  Extension.declare
188    "protobuf"
189    Extension.Context.structure_item
190    Ast_pattern.(single_expr_payload (estring __))
191    expand
192
193let () =
194  Driver.register_transformation
195    ~rules:[Context_free.Rule.extension extension]
196    "ppx_protobuf"
197

1module%protobuf Order = "protos/order.proto"
2(* Generates:
3   type order = {
4     id: int64;
5     symbol: string;
6     side: string;
7     quantity: int64;
8     price: float;
9     timestamp: int64;
10   }
11   
12   val encode : order -> bytes
13   val decode : bytes -> order
14*)
15
16let () =
17  let order = Order.{
18    id = 12345L;
19    symbol = "AAPL";
20    side = "BUY";
21    quantity = 100L;
22    price = 150.25;
23    timestamp = 1609459200L;
24  } in
25  
26  (* Encode to protobuf *)
27  let encoded = Order.encode order in
28  
29  (* Send over network *)
30  send_to_server encoded;
31  
32  (* Decode from protobuf *)
33  let received = receive_from_server () in
34  let decoded = Order.decode received in
35  Printf.printf "Received order for %s\n" decoded.symbol
36

1(* ppx_market_data.ml *)
2open Ppxlib
3
4module MarketAPI = struct
5  (* Fetch schema from API endpoint at compile time *)
6  let fetch_schema endpoint =
7    let curl = Printf.sprintf "curl -s %s/schema" endpoint in
8    let ic = Unix.open_process_in curl in
9    let json = Yojson.Basic.from_channel ic in
10    let _ = Unix.close_process_in ic in
11    json
12
13  let parse_schema json =
14    (* Parse JSON schema to field definitions *)
15    Yojson.Basic.Util.member "fields" json
16    |> Yojson.Basic.Util.to_assoc
17    |> List.map (fun (name, type_json) ->
18        let field_type = Yojson.Basic.Util.member "type" type_json
19          |> Yojson.Basic.Util.to_string
20        in
21        (name, field_type))
22end
23
24let expand ~loc ~path api_endpoint =
25  (* Fetch schema at compile time *)
26  let schema = MarketAPI.fetch_schema api_endpoint in
27  let fields = MarketAPI.parse_schema schema in
28  
29  (* Generate type *)
30  let type_decl = Generator.generate_type ~loc fields in
31  
32  (* Generate API client *)
33  let client = [%stri
34    let fetch symbol =
35      let url = Printf.sprintf "%s/quote/%s" [%e estring ~loc api_endpoint] symbol in
36      let response = Curl.get url in
37      of_json (Yojson.Basic.from_string response)
38    
39    let stream symbol callback =
40      let ws = Websocket.connect
41        (Printf.sprintf "%s/stream/%s" [%e estring ~loc api_endpoint] symbol)
42      in
43      Websocket.on_message ws (fun msg ->
44        callback (of_json (Yojson.Basic.from_string msg)))
45  ] in
46  
47  [type_decl; client]
48

1Without type provider:  2.3s compile time
2With JSON provider:     2.8s compile time (+21%)
3With SQL provider:      3.1s compile time (+35%, includes DB query)
4With API provider:      4.2s compile time (+83%, network request)
5

1let expand_cached ~loc ~path schema_path =
2  let cache_path = schema_path ^ ".cache" in
3  let schema =
4    if Sys.file_exists cache_path then
5      (* Load from cache *)
6      let ic = open_in_bin cache_path in
7      let schema = Marshal.from_channel ic in
8      close_in ic;
9      schema
10    else
11      (* Load and cache *)
12      let schema = load_schema schema_path in
13      let oc = open_out_bin cache_path in
14      Marshal.to_channel oc schema [];
15      close_out oc;
16      schema
17  in
18  generate ~loc schema
19

1(* test_ppx_json.ml *)
2open Ppxlib
3
4let test_json_generation () =
5  let ast = [%str
6    type market_data = [%json_of_schema "test_schema.json"]
7  ] in
8  
9  (* Run PPX transformation *)
10  let transformed = Driver.apply_rewriters ast in
11  
12  (* Verify generated code *)
13  let expected = [%str
14    type market_data = {
15      symbol: string;
16      price: float;
17      volume: int64;
18    }
19    
20    let of_json json = (* ... *)
21  ] in
22  
23  assert (Ast_helper.str_equal transformed expected)
24
25let test_roundtrip () =
26  let json_str = {|{"symbol":"AAPL","price":150.25,"volume":1000000}|} in
27  let data = Market_data.of_json (Yojson.Basic.from_string json_str) in
28  assert (data.symbol = "AAPL");
29  assert (data.price = 150.25);
30  assert (data.volume = 1000000L)
31