csv.ml

module type S = Util.SERIALIZABLE

module Kind =
struct
  type t =
    | Int
    | Float
    | String
    | Boolean
    | Optional of t
    | Serializable of (module S)
    | Xref
end

module Field =
struct

  type t =
    | Int of int
    | Float of float
    | String of string
    | Boolean of bool
    | Optional of t option
    | Serializable : ((module S with type t = 'a) * 'a) -> t
    | Xref of Xref.t

  let coercion f x =
    try Ok (f x)
    with _ -> Error.coercion x

  let f_int = coercion (fun x -> Int (int_of_string x))
  let f_float = coercion (fun x -> Float (float_of_string x))
  let f_string x = Ok (String x)

  let f_bool x =
    let test = String.lowercase_ascii x in
    if test = "true" || test = "false"
    then Ok (Boolean (test = "true"))
    else Error.coercion x


  let rec of_string = function
    | Kind.Int -> f_int
    | Kind.Float -> f_float
    | Kind.String -> f_string
    | Kind.Boolean -> f_bool
    | Kind.Xref ->
      let open Util.Result in
      (fun x ->
         (Xref.of_string x)
         >>| (fun xref -> Xref xref)
      )
    | Kind.Optional kind ->
      let open Util.Result in
      (fun x ->
         if String.length x = 0
         then Ok (Optional None)
         else
           of_string kind x
           >>| (fun x -> Optional (Some x))
      )
    | Kind.Serializable (module M : S) ->
      let open Util.Result in
      (fun x ->
         M.of_string x
         >>= (fun y -> Ok (Serializable ((module M), y)))
      )

  let rec to_string = function
    | Int x -> string_of_int x
    | Float x -> string_of_float x
    | String x -> x
    | Boolean true -> "true"
    | Boolean false -> "false"
    | Optional None -> ""
    | Optional (Some x) -> to_string x
    | Serializable ((module M), existential) ->
      M.to_string existential
    | Xref xref -> Xref.to_string xref

end

let parse_failure ln =
  Error.(error (Csv (Parse_failure ln)))

type meta =
  | Header of (string * Kind.t) list
  | Plain of Kind.t list

let finalize kind acc recipe rev =
  let open Util.Result in
  recipe
  |> Field.of_string kind
  >>= (fun x -> map acc (fun xs -> x :: xs))
  >>| (if rev then List.rev else Util.id)

let of_line ln sep stream =
  let rec aux escaped acc recipe kinds =
    match (Stream.next stream, kinds) with
    | (_, []) -> (parse_failure ln, false)
    | ('\\', kinds) -> aux true acc recipe kinds
    | ('\n', [last_kind]) -> (finalize last_kind acc recipe true, false)
    | (chr, kind :: kinds) when chr = sep && not escaped ->
      let new_acc = finalize kind acc recipe false
      in aux false new_acc "" kinds
    | (chr, kinds) ->
      aux false acc (Util.push_char recipe chr) kinds
    | exception Stream.Failure ->
      begin
        match kinds with
        | [last_kind] -> (finalize last_kind acc recipe true, true)
        | _ -> (parse_failure ln, true)
      end
  in aux false (Ok []) ""


let of_stream_when ?(separator=',') f meta stream =
  let rec aux ln kinds acc =
    match of_line ln separator stream kinds with
    | Ok line, true ->
      begin
        match f meta line with
        | Some l -> Ok (l :: acc)
        | None -> Ok []
      end
    | Ok line, false ->
      begin
        match (f meta line) with
        | Some l -> aux (succ ln) kinds (l :: acc)
        | None -> aux (succ ln) kinds acc
      end
    | (Error _) as e, _ -> e
  in
  match meta with
  | Header headers ->
    let (s_kinds, kinds) =
      List.fold_right
        (fun (_, k) (s, a) -> (Kind.String :: s, k :: a))
        headers ([], [])
    in
    let open Util.Result in
    let (result, _) = of_line 0 separator stream s_kinds in
    result >>= (fun _ -> aux 1 kinds [])
  | Plain kinds -> aux 1 kinds []

let of_stream ?(separator=',') f meta =
  let callback meta fields = Some (f meta fields) in
  of_stream_when ~separator callback meta

let to_hashtbl_when ?(separator=',') f keep_if meta stream =
  let (length, keys) =
    List.fold_right
      (fun elt (l, k) -> (succ l, (fst elt) :: k))
      meta
      (0, [])
  in
  let callback _ fields =
    let hashtbl = Hashtbl.create length in
    let _ =
      List.map2
        (fun key field ->
           let (k, v) = f key field in
           Hashtbl.add hashtbl k v
        ) keys fields
    in if keep_if hashtbl then Some hashtbl
    else None
  in
  let open Util.Result in
  of_stream_when ~separator callback (Header meta) stream
  >>| (fun result -> (keys, result))

let to_hashtbl ?(separator=',') f =
  to_hashtbl_when ~separator f (fun _ -> true)

let join ?(separator=',') fields =
  let s = Util.push_char "" separator in
  fields
  |> List.map Field.to_string
  |> (fun x -> Formatting.join s x)

let join_hashtbl ?(separator=',') keys hash =
  keys
  |> List.map (Hashtbl.find hash)
  |> join ~separator

csv.mli

(** Special thanks to @phink ~ Paul Laforgue *)

module type S = Util.SERIALIZABLE

(** Describes the type of a CSVfield *)
module Kind :
sig
  type t =
    | Int
    | Float
    | String
    | Boolean
    | Optional of t
    | Serializable of (module S)
    | Xref
end

(** Parsing/Unparsing of a field  *)
module Field :
sig

type t =
  | Int of int
  | Float of float
  | String of string
  | Boolean of bool
  | Optional of t option
  | Serializable : ((module S with type t = 'a) * 'a) -> t
  | Xref of Xref.t

  val of_string : Kind.t -> string -> (t, Error.t) result
  val to_string : t -> string

end

(** Describes the kind of CSV *)
type meta =
  | Header of (string * Kind.t) list
  | Plain of Kind.t list

(** Parse a specific line (stream) *)
val of_line :
  int
  -> char
  -> char Stream.t
  -> Kind.t list
  -> ((Field.t list, Error.t) result * bool)

(** filter result *)
val of_stream_when :
  ?separator:char
  -> (meta -> Field.t list -> 'a option)
  -> meta
  -> char Stream.t
  -> ('a list, Error.t) result

(** Parse a stream to a CSV *)
val of_stream :
  ?separator:char
  -> (meta -> Field.t list -> 'a)
  -> meta
  -> char Stream.t
  -> ('a list, Error.t) result

(** Parse a stream to a Hashtbl CSV *)
val to_hashtbl_when :
  ?separator:char
  -> (string -> Field.t -> ('a * 'b))
  -> (('a, 'b) Hashtbl.t -> bool)
  -> (string * Kind.t) list
  -> char Stream.t
  -> ((string list * ('a, 'b) Hashtbl.t list), Error.t) result

(** Parse a stream to a Hashtbl CSV *)
val to_hashtbl :
  ?separator:char
  -> (string -> Field.t -> ('a * 'b))
  -> (string * Kind.t) list
  -> char Stream.t
  -> ((string list * ('a, 'b) Hashtbl.t list), Error.t) result

(** Join a list of field *)
val join:
  ?separator:char
  -> Field.t list
  -> string

(** Join an Hashtbl of field *)
val join_hashtbl:
  ?separator:char
  -> string list
  -> (string, Field.t) Hashtbl.t
  -> string