151 lines
4.0 KiB
OCaml
151 lines
4.0 KiB
OCaml
type nil = Nil
|
|
|
|
type param
|
|
|
|
type dir
|
|
|
|
type ('a, 'b) directive =
|
|
{ name : string
|
|
; params : 'a
|
|
; children : 'b
|
|
}
|
|
|
|
module Field_type = struct
|
|
type _ t =
|
|
| String : string t
|
|
| Bool : bool t
|
|
| Int : int t
|
|
| Float : float t
|
|
end
|
|
|
|
type (_, _) t =
|
|
| Field : 'a Field_type.t -> ('a, param) t
|
|
| Directive :
|
|
string * ('a, param) t * ('b, dir) t
|
|
-> (('a, 'b) directive, dir) t
|
|
| Product : ('i * ('a, 'i, 'k) product) -> ('a, 'k) t
|
|
|
|
and (_, _, _) product =
|
|
| Proj_end : ('a, 'a, 'k) product
|
|
| Proj : (('b, 'k) t * ('a, 'i, 'k) product) -> ('a, 'b -> 'i, 'k) product
|
|
|
|
type _ kt =
|
|
| P : string list -> param kt
|
|
| D : Types.directive list -> dir kt
|
|
|
|
exception Schema_exn of string
|
|
|
|
let error msg = raise (Schema_exn (Fmt.str "invalid schema: %s" msg))
|
|
|
|
let rec length : type a k. (a, k) t -> int =
|
|
fun ty ->
|
|
match ty with
|
|
| Field _ -> 1
|
|
| Directive _ -> 1
|
|
| Product (_i, prod) -> length_prod prod
|
|
|
|
and length_prod : type a b k. (a, b, k) product -> int =
|
|
fun p ->
|
|
match p with Proj_end -> 0 | Proj (tk, prod) -> length tk + length_prod prod
|
|
|
|
let conv_field : type a. a Field_type.t -> string -> a =
|
|
fun ty v ->
|
|
match ty with
|
|
| String -> v
|
|
| Bool -> (
|
|
match bool_of_string_opt v with
|
|
| None -> error (Fmt.str "%s does not match a bool" v)
|
|
| Some b -> b )
|
|
| Int -> (
|
|
match int_of_string_opt v with
|
|
| None -> error (Fmt.str "%s does not match a int" v)
|
|
| Some b -> b )
|
|
| Float -> (
|
|
match float_of_string_opt v with
|
|
| None -> error (Fmt.str "%s does not match a float" v)
|
|
| Some b -> b )
|
|
|
|
let singleton l = match l with [ v ] -> v | _ -> error "expected singleton"
|
|
|
|
let rec conv : type a k. (a, k) t -> k kt -> a =
|
|
fun ty k ->
|
|
match (ty, k) with
|
|
| Field ty, P l -> conv_field ty (singleton l)
|
|
| Directive (name, p_ty, c_ty), D l -> (
|
|
let v = singleton l in
|
|
match String.equal v.name name with
|
|
| false -> error (Fmt.str "name mismatch: `%s` <> `%s`" name v.name)
|
|
| true ->
|
|
let params = conv p_ty (P v.params) in
|
|
let children = conv c_ty (D v.children) in
|
|
{ name; params; children } )
|
|
| Product ty, k -> conv_prod ty k
|
|
|
|
and conv_prod : type a i k. i * (a, i, k) product -> k kt -> a =
|
|
fun (intro, ty) k ->
|
|
match (ty, k) with
|
|
| Proj_end, P l -> (
|
|
match l with [] -> intro | _ -> error "too many items" )
|
|
| Proj_end, D l -> (
|
|
match l with [] -> intro | _ -> error "too many items" )
|
|
| Proj (ty, prod), P l ->
|
|
let i = length ty in
|
|
let l1 = List.take i l in
|
|
let l2 = List.drop i l in
|
|
let b = conv ty (P l1) in
|
|
let a = conv_prod (intro b, prod) (P l2) in
|
|
a
|
|
| Proj (ty, prod), D l ->
|
|
let i = length ty in
|
|
let l1 = List.take i l in
|
|
let l2 = List.drop i l in
|
|
let b = conv ty (D l1) in
|
|
let a = conv_prod (intro b, prod) (D l2) in
|
|
a
|
|
|
|
let string = Field Field_type.String
|
|
|
|
let bool = Field Field_type.Bool
|
|
|
|
let int = Field Field_type.Int
|
|
|
|
let float = Field Field_type.Float
|
|
|
|
let directive name params children = Directive (name, params, children)
|
|
|
|
let nil = Product (Nil, Proj_end)
|
|
|
|
let product intro prod = Product (intro, prod)
|
|
|
|
let proj t prod = Proj (t, prod)
|
|
|
|
let proj_end = Proj_end
|
|
|
|
let custom : type a b k. (a -> (b, string) result) -> (a, k) t -> (b, k) t =
|
|
fun decode t ->
|
|
let intro s = match decode s with Ok x -> x | Error msg -> error msg in
|
|
product intro @@ proj t @@ proj_end
|
|
|
|
let t1 t1 =
|
|
let intro = fun x1 -> x1 in
|
|
product intro @@ proj t1 proj_end
|
|
|
|
let t2 t1 t2 =
|
|
let intro = fun x1 x2 -> (x1, x2) in
|
|
product intro @@ proj t1 @@ proj t2 proj_end
|
|
|
|
let t3 t1 t2 t3 =
|
|
let intro = fun x1 x2 x3 -> (x1, x2, x3) in
|
|
product intro @@ proj t1 @@ proj t2 @@ proj t3 proj_end
|
|
|
|
let t4 t1 t2 t3 t4 =
|
|
let intro = fun x1 x2 x3 x4 -> (x1, x2, x3, x4) in
|
|
product intro @@ proj t1 @@ proj t2 @@ proj t3 @@ proj t4 proj_end
|
|
|
|
let t5 t1 t2 t3 t4 t5 =
|
|
let intro = fun x1 x2 x3 x4 x5 -> (x1, x2, x3, x4, x5) in
|
|
product intro @@ proj t1 @@ proj t2 @@ proj t3 @@ proj t4 @@ proj t5 proj_end
|
|
|
|
let conv schema (config : Types.config) =
|
|
try Ok (conv schema (D config)) with Schema_exn s -> Error (`Msg s)
|