Source file conv.ml

open Import

(* Mini clone of Dune_lang.Decoder. Main advantage is that it forbids all the
   crazy stuff and is automatically bi-directional *)

(* TODO error handling is complete crap for now.

   This should be unified with [Dune_lang.Decoder] eventually. *)

type error =
  | Parse_error of
      { message : string
      ; payload : (string * Sexp.t) list
      }
  | Version_error of
      { since : int * int
      ; until : (int * int) option
      ; message : string
      ; payload : (string * Sexp.t) list
      }

let dyn_of_error =
  let open Dyn in
  function
  | Version_error { message; payload; until; since } ->
    record
      [ "message", string message
      ; "payload", list (pair string Sexp.to_dyn) payload
      ; "until", option (pair int int) until
      ; "since", (pair int int) since
      ]
  | Parse_error { message; payload } ->
    record
      [ "message", string message; "payload", list (pair string Sexp.to_dyn) payload ]
;;

exception Of_sexp of error

let raise_of_sexp ?(payload = []) message =
  raise (Of_sexp (Parse_error { message; payload }))
;;

let raise_version_error ?until ?(payload = []) ~since message =
  raise (Of_sexp (Version_error { since; until; message; payload }))
;;

let () =
  Printexc.register_printer (function
    | Of_sexp (Parse_error { message; payload }) ->
      Some (message ^ " " ^ Sexp.to_string (Sexp.record payload))
    | _ -> None)
;;

module Fields = struct
  type t = Unparsed of Sexp.t String.Map.t

  let check_empty (Unparsed s) =
    if not (String.Map.is_empty s)
    then (
      let payload =
        [ ( "unparsed"
          , Sexp.List
              (String.Map.to_list s
               |> List.map ~f:(fun (k, v) -> Sexp.List [ Sexp.Atom k; v ])) )
        ]
      in
      raise_of_sexp ~payload "unexpected fields")
  ;;

  let empty = Unparsed String.Map.empty

  let merge (Unparsed a) (Unparsed b) =
    Unparsed
      (String.Map.union a b ~f:(fun _ _ _ ->
         (* field names are guaranteed to be different at construction time in
            [Both] *)
         assert false))
  ;;

  let of_field name sexp = Unparsed (String.Map.singleton name sexp)

  let of_sexp (x : Sexp.t) =
    match x with
    | Atom _ -> raise_of_sexp "Unexpected atom"
    | List x ->
      (match
         String.Map.of_list_map x ~f:(function
           | List [ Atom s; v ] -> s, v
           | _ -> raise_of_sexp "unable to read field")
       with
       | Error (s, _, _) -> raise_of_sexp "duplicate fields" ~payload:[ "field", Atom s ]
       | Ok s -> Unparsed s)
  ;;

  let optional (Unparsed t) name =
    match String.Map.find t name with
    | None -> None, Unparsed t
    | Some v -> Some v, Unparsed (String.Map.remove t name)
  ;;

  let required t name =
    let r, t = optional t name in
    match r with
    | Some s -> s, t
    | None -> raise_of_sexp "missing required field" ~payload:[ "name", Atom name ]
  ;;

  let to_sexp (Unparsed t) : Sexp.t =
    List (String.Map.to_list t |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; v ]))
  ;;
end

type values = Sexp.t
type fields = Fields.t

type version =
  { since : int * int
  ; until : (int * int) option
  }

type ('a, 'kind) t =
  | String : (string, values) t
  | Int : (int, values) t
  | Float : (float, values) t
  | Unit : (unit, values) t
  | Char : (char, values) t
  | Iso : ('a, 'kind) t * ('a -> 'b) * ('b -> 'a) -> ('b, 'kind) t
  | Iso_result : ('a, 'kind) t * ('a -> ('b, exn) result) * ('b -> 'a) -> ('b, 'kind) t
  | Version : ('a, 'kind) t * version -> ('a, 'kind) t
  | Both :
      (* Invariant: field names must be different *)
      ('a, fields) t
      * ('b, fields) t
      -> ('a * 'b, fields) t
  | Sexp : (Sexp.t, values) t
  | List : ('a, values) t -> ('a list, values) t
  | Field : string * 'a field -> ('a, fields) t
  | Enum : (string * 'a) list -> ('a, values) t
  | Sum : 'a econstr list * ('a -> case) -> ('a, values) t
  | Pair : ('a, values) t * ('b, values) t -> ('a * 'b, values) t
  | Triple : ('a, values) t * ('b, values) t * ('c, values) t -> ('a * 'b * 'c, values) t
  | Fdecl : int * ('a, 'k) t Fdecl.t -> ('a, 'k) t
  | Either :
      (* Invariant: field names must be different *)
      ('a, fields) t
      * ('b, fields) t
      -> (('a, 'b) Either.t, fields) t
  | Record : ('a, fields) t -> ('a, values) t

and ('a, 'arg) constr =
  { (* TODO allow constructors without an argument *)
    name : string
  ; arg : ('arg, values) t
  ; inj : 'arg -> 'a
  }

and 'a econstr = Constr : ('a, 'arg) constr -> 'a econstr
and case = Case : 'arg * ('a, 'arg) constr -> case

and 'a field =
  | Required : ('a, values) t -> 'a field
  | Optional : ('a, values) t -> 'a option field

and 'k ret =
  | Values : values ret
  | Fields : Fields.t -> fields ret

type 'a value = ('a, values) t

let case a c = Case (a, c)
let constr name arg inj = { name; arg; inj }
let econstr c = Constr c
let both x y = Both (x, y)
let list x = List x
let sum x y = Sum (x, y)
let pair x y = Pair (x, y)
let triple x y z = Triple (x, y, z)

let discard_values ((a, x) : _ * values ret) =
  match (x : values ret) with
  | Values -> a
;;

let string = String
let int = Int
let float = Float
let unit = Unit

let option x =
  let none = constr "None" unit (fun () -> None) in
  let some = constr "Some" x (fun x -> Some x) in
  sum
    [ econstr none; econstr some ]
    (function
      | None -> case () none
      | Some s -> case s some)
;;

let char = Char

let sexp_for_digest t =
  let rec iter : type a b. int list -> (a, b) t -> Sexp.t =
    fun ids -> function
      | String -> Atom "String"
      | Int -> Atom "Int"
      | Float -> Atom "Float"
      | Unit -> Atom "Unit"
      | Char -> Atom "Char"
      | Iso (t, _, _) -> List [ Atom "Iso"; iter ids t ]
      | Iso_result (t, _, _) -> List [ Atom "Iso_result"; iter ids t ]
      | Version (t, { since = a, b; until }) ->
        let items : Sexp.t list =
          [ Atom "Version"
          ; iter ids t
          ; List [ Atom "since"; Atom (Int.to_string a); Atom (Int.to_string b) ]
          ]
        in
        let items =
          match until with
          | None -> items
          | Some (a, b) ->
            items
            @ [ List [ Atom "until"; Atom (Int.to_string a); Atom (Int.to_string b) ] ]
        in
        List items
      | Both (a, b) -> List [ Atom "Both"; iter ids a; iter ids b ]
      | Sexp -> Atom "Sexp"
      | List t -> List [ Atom "List"; iter ids t ]
      | Field (name, field) ->
        let field : Sexp.t =
          match field with
          | Required t -> List [ Atom "Required"; iter ids t ]
          | Optional t -> List [ Atom "Optional"; iter ids t ]
        in
        List [ Atom "Field"; Atom name; field ]
      | Enum cases ->
        List (Atom "Enum" :: List.map cases ~f:(fun (name, _) : Sexp.t -> Atom name))
      | Sum (constrs, _) ->
        List
          (Atom "Sum"
           :: List.map constrs ~f:(fun (Constr { name; arg; inj = _ }) : Sexp.t ->
             List [ Atom name; iter ids arg ]))
      | Pair (a, b) -> List [ Atom "Pair"; iter ids a; iter ids b ]
      | Triple (a, b, c) -> List [ Atom "Triple"; iter ids a; iter ids b; iter ids c ]
      | Fdecl (id, fdecl) ->
        (* Although the id is represented as an auto-incrementing integer, we
         find De Bruijn indices to put in the digest so that equivalent
         structures produce the same digest. *)
        (match List.findi ids ~f:(Int.equal id) with
         | Some (_, index) -> List [ Atom "Recurse"; Atom (Int.to_string index) ]
         | None -> List [ Atom "Fixpoint"; iter (id :: ids) (Fdecl.get fdecl) ])
      | Either (a, b) -> List [ Atom "Either"; iter ids a; iter ids b ]
      | Record t -> List [ Atom "Record"; iter ids t ]
  in
  iter [] t
;;

let to_sexp : 'a. ('a, values) t -> 'a -> Sexp.t =
  fun t a ->
  let rec loop : type a k. (a, k) t -> a -> k =
    fun t a ->
    match t with
    | String -> Atom a
    | Int -> Atom (Int.to_string a)
    | Float -> Atom (Float.to_string a)
    | Unit -> List []
    | Char -> Atom (String.make 1 a)
    | Sexp -> a
    | Version (t, _) -> loop t a
    | Fdecl (_, t) -> loop (Fdecl.get t) a
    | List t -> List (List.map a ~f:(loop t))
    | Pair (x, y) ->
      let a, b = a in
      List [ loop x a; loop y b ]
    | Triple (x, y, z) ->
      let a, b, c = a in
      List [ loop x a; loop y b; loop z c ]
    | Record r ->
      let fields = loop r a in
      Fields.to_sexp fields
    | Field (name, spec) ->
      (match spec with
       | Required t -> Fields.of_field name (loop t a)
       | Optional t ->
         (match a with
          | None -> Fields.empty
          | Some a -> Fields.of_field name (loop t a)))
    | Iso_result (t, _, from) -> loop t (from a)
    | Iso (t, _, from) -> loop t (from a)
    | Both (x, y) ->
      let x = loop x (fst a) in
      let y = loop y (snd a) in
      Fields.merge x y
    | Either (x, y) ->
      (match a with
       | Left a -> loop x a
       | Right a -> loop y a)
    | Sum (_, constr) ->
      let (Case (a, constr)) = constr a in
      let arg = loop constr.arg a in
      Sexp.List [ Atom constr.name; arg ]
    | Enum choices ->
      (match
         List.find_map choices ~f:(fun (s, a') ->
           if Poly.equal a a' then Some s else None)
       with
       | Some v -> Atom v
       | None ->
         let open Dyn in
         Code_error.raise
           "enum does not include this value"
           [ "valid values", list (fun (x, _) -> string x) choices ])
  in
  loop t a
;;

let check_version ~version ~since ~until _ctx =
  if
    version < since
    ||
    match until with
    | None -> false
    | Some until -> version > until
  then raise_version_error ?until ~since "invalid version"
;;

let of_sexp : 'a. ('a, values) t -> version:int * int -> Sexp.t -> 'a =
  fun t ~version sexp ->
  let rec loop : type a k. (a, k) t -> k -> a * k ret =
    fun (type a k) (t : (a, k) t) (ctx : k) : (a * k ret) ->
    match t with
    | String ->
      (match ctx with
       | Atom s -> s, Values
       | List _ as list ->
         raise_of_sexp ~payload:[ "list", list ] "string: expected atom. received list")
    | Int ->
      (match ctx with
       | List _ as list ->
         raise_of_sexp ~payload:[ "list", list ] "int: expected atom. received list"
       | Atom s ->
         (match Int.of_string s with
          | None -> raise_of_sexp "unable to read int"
          | Some i -> i, Values))
    | Float ->
      (match ctx with
       | List _ as list ->
         raise_of_sexp ~payload:[ "list", list ] "float: expected atom. received list"
       | Atom s ->
         (match Float.of_string_opt s with
          | None -> raise_of_sexp "unable to read float"
          | Some i -> i, Values))
    | Unit ->
      (match ctx with
       | List [] -> (), Values
       | _ -> raise_of_sexp "expected empty list")
    | Char ->
      (match ctx with
       | Atom s ->
         if String.length s = 1
         then s.[0], Values
         else raise_of_sexp "expected only a single character"
       | List _ -> raise_of_sexp "expected a string of length 1")
    | Sexp -> ctx, Values
    | Version (t, { since; until }) ->
      check_version ~version ~since ~until ctx;
      loop t ctx
    | Fdecl (_, t) -> loop (Fdecl.get t) ctx
    | List t ->
      (match ctx with
       | List xs -> List.map xs ~f:(fun x -> discard_values (loop t x)), Values
       | Atom _ -> raise_of_sexp "expected list")
    | Pair (x, y) ->
      (match ctx with
       | List [ a; b ] ->
         let a, Values = loop x a in
         let b, Values = loop y b in
         (a, b), Values
       | _ -> raise_of_sexp "expected field entry")
    | Triple (x, y, z) ->
      (match ctx with
       | List [ a; b; c ] ->
         let a, Values = loop x a in
         let b, Values = loop y b in
         let c, Values = loop z c in
         (a, b, c), Values
       | _ -> raise_of_sexp "expected field entry")
    | Record (r : (a, fields) t) ->
      let (fields : Fields.t) = Fields.of_sexp ctx in
      let a, Fields f = loop r fields in
      Fields.check_empty f;
      a, Values
    | Field (name, spec) ->
      (match spec with
       | Required v ->
         let field, rest = Fields.required ctx name in
         let t, Values = loop v field in
         t, Fields rest
       | Optional v ->
         let field, rest = Fields.optional ctx name in
         let t =
           match field with
           | None -> None
           | Some f ->
             let a, Values = loop v f in
             Some a
         in
         t, Fields rest)
    | Either (x, y) ->
      (try
         (* TODO share computation somehow *)
         let a, x = loop x ctx in
         Left a, x
       with
       | Of_sexp _ ->
         let a, y = loop y ctx in
         Right a, y)
    | Iso (t, f, _) ->
      let a, k = loop t ctx in
      f a, k
    | Iso_result (t, f, _) ->
      let a, k = loop t ctx in
      (match f a with
       | Error exn -> raise exn
       | Ok a -> a, k)
    | Both (x, y) ->
      let a, Fields k = loop x ctx in
      let b, k = loop y k in
      (a, b), k
    | Sum (constrs, _) ->
      (match ctx with
       | List [ Atom head; args ] ->
         (match
            List.find_map constrs ~f:(fun (Constr c) ->
              if head = c.name
              then
                Some
                  (let a, k = loop c.arg args in
                   c.inj a, k)
              else None)
          with
          | None -> raise_of_sexp "invalid constructor name"
          | Some p -> p)
       | _ -> raise_of_sexp "expected constructor")
    | Enum choices ->
      (match ctx with
       | List _ -> raise_of_sexp "expected list"
       | Atom a ->
         (match List.assoc choices a with
          | None -> raise_of_sexp "unable to read enum"
          | Some s -> s, Values))
  in
  discard_values (loop t sexp)
;;

let of_sexp conv ~version sexp =
  match of_sexp conv ~version sexp with
  | s -> Ok s
  | exception Of_sexp e -> Error e
;;

let record r = Record r
let either x y = Either (x, y)
let iso a t f = Iso (a, t, f)
let iso_result a t f = Iso_result (a, t, f)
let version ?until t ~since = Version (t, { until; since })
let field name spec = Field (name, spec)
let enum choices = Enum choices

let three a b c =
  iso (Both (a, Both (b, c))) (fun (x, (y, z)) -> x, y, z) (fun (x, y, z) -> x, (y, z))
;;

let four a b c d =
  iso
    (both (both a b) (both c d))
    (fun ((w, x), (y, z)) -> w, x, y, z)
    (fun (w, x, y, z) -> (w, x), (y, z))
;;

let five a b c d e =
  iso
    (both (both a b) (three c d e))
    (fun ((a, b), (c, d, e)) -> a, b, c, d, e)
    (fun (a, b, c, d, e) -> (a, b), (c, d, e))
;;

let six a b c d e f =
  iso
    (both (three a b c) (three d e f))
    (fun ((a, b, c), (d, e, f)) -> a, b, c, d, e, f)
    (fun (a, b, c, d, e, f) -> (a, b, c), (d, e, f))
;;

let seven a b c d e f g =
  iso
    (both (three a b c) (four d e f g))
    (fun ((a, b, c), (d, e, f, g)) -> a, b, c, d, e, f, g)
    (fun (a, b, c, d, e, f, g) -> (a, b, c), (d, e, f, g))
;;

let eight a b c d e f g h =
  iso
    (both (four a b c d) (four e f g h))
    (fun ((a, b, c, d), (e, f, g, h)) -> a, b, c, d, e, f, g, h)
    (fun (a, b, c, d, e, f, g, h) -> (a, b, c, d), (e, f, g, h))
;;

let sexp = Sexp
let required x = Required x
let optional x = Optional x
let fdecl_id = ref 0

let fixpoint f =
  let fdecl = Fdecl.create Dyn.opaque in
  let id = !fdecl_id in
  incr fdecl_id;
  let result = Fdecl (id, fdecl) in
  Fdecl.set fdecl (f result);
  result
;;

let error e = raise (Of_sexp e)