gistfile1.ml

type 'a ty =
  | Int: int ty
  | String: string ty
  | List: 'a ty -> 'a list ty
  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
  | Record: ('a, 'a) record -> 'a ty
 
and (_, _) record =
| Build : 'b -> ('b, 'r) record
| Field : ('a -> 'builder, 'r) record * string * 'a ty * ('r -> 'a) -> ('builder, 'r) record
;;

type my_record  =
    {
     a: int;
     b: string list;
    }
 
let fields =
  Field (Field (Build (fun a b -> {a;b}),
                "a", Int, (fun {a} -> a)),
         "b", List String, (fun {b} -> b))

let onefield str ty get tail =
  Field(tail, str, ty, get)

let build k = Build k

let fields' =
  build (fun a b -> {a;b}) |>
  onefield "a" Int (fun {a}->a) |>
  onefield "b" (List String) (fun {b} -> b)

let my_record = Record fields

let rec identity : type a . a ty -> a -> a = function
  | Int -> (fun n -> n+0)
  | String -> (fun s -> s^"")
  | List t -> List.map (identity t)
  | Pair (ta, tb) -> (fun (a, b) -> identity ta a, identity tb b)
  | Record recty -> fun record ->
    let rec fid : type b . (b, a) record -> (b -> a) -> a =
    fun field k -> match field with
      | Build b -> k b
      | Field (rest, _name, ty, read) ->
        let field' = identity ty (read record) in
        fid rest (fun b -> k (b field'))
    in fid recty (fun r -> r)

module Json = struct
  type t =
    | Int of int
    | String of string
    | List of t list
    | Assoc of (string * t) list

end

let rec to_json : type a. a ty -> a -> Json.t
  = fun ty x -> match ty with
    | Int -> Json.Int x
    | String -> Json.String x
    | Pair (tya,tyb) ->
        let a, b = x in
        Json.List [to_json tya a; to_json tyb b]
    | List tya ->
        Json.List (List.map (to_json tya) x)
    | Record r ->
        let rec buildassoc : type b. (b,a) record -> (string*Json.t) list -> Json.t
        = fun r list_ -> match r with
        | Build _ -> Json.Assoc list_
        | Field(rest, name, ty_field, get) ->
            let value = to_json ty_field (get x) in
            buildassoc rest ((name,value)::list_)
        in buildassoc r []