(* parse config file
   https://docs.taler.net/manpages/taler-exchange.conf.5.html

   do not support "$"-path expansion*)

(* TODO
   - integer
   - duration
   - YES|NO
   - alt_unit_names json pair

type duration_element = {
  number: int;
  unit_: [ `Year | `Week | `Day | `Hour | `Minute | `Second ];
}

let integer =
  take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s ->
  match int_of_string_opt s with
  | None -> fail "not an integer"
  | Some i -> return i

let duration_value =
  let number = whitespace *> integer in
  let unit =
    whitespace *> take_while1 (fun c -> not (is_whitespace c || is_eol c))
    >>= function
    | "year" | "years" -> return `Year
    | "week" | "weeks" -> return `Week
    | "day" | "days" -> return `Day
    | "hour" | "hours" -> return `Hour
    | "minute" | "minutes" -> return `Minute
    | "s" -> return `Second
    | _ -> fail "not a valid duration unit"
  in
  many1 (lift2 (fun number unit_ -> { number; unit_ }) number unit)
*)

let read_file file = In_channel.with_open_bin file In_channel.input_all

module Untyped = struct
  type item = {
    key: string;
    value: string;
  }

  type line =
    | Blank
    | Comment of string
    | Header of string
    | Item of item

  type section = {
    header: string;
    items: item list;
  }

  open Angstrom

  let is_eol = function '\n' | '\r' -> true | _ -> false
  let is_whitespace = function ' ' | '\t' -> true | _ -> false
  let whitespace = skip_while is_whitespace

  let id =
    let ident_char = function
      | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true
      | _ -> false
    in
    take_while1 ident_char >>| String.lowercase_ascii

  let take_till_end_of_line =
    take_till is_eol >>= fun s -> return s <* end_of_line

  let blank = whitespace <* end_of_line >>| fun () -> Blank

  let comment =
    whitespace *> (char '#' <|> char '%') *> take_till_end_of_line >>| fun s ->
    Comment s

  let header = char '[' *> id <* char ']' <* end_of_line >>| fun s -> Header s

  let item_value =
    let unquoted_value =
      take_while1 (fun c -> not (is_whitespace c || is_eol c))
    in
    let quoted_value =
      char '"' *> take_till is_eol >>= fun s ->
      match String.ends_with ~suffix:"\"" s with
      | false -> fail "invalid quoted value"
      | true ->
          let value = String.sub s 0 (String.length s - 1) in
          return value
    in
    quoted_value <|> unquoted_value

  let item =
    lift2
      (fun key value -> Item { key; value })
      id
      (whitespace *> char '=' *> whitespace *> item_value)
    <* end_of_line

  let config = many (choice [ blank; comment; header; item ]) <* end_of_input

  let fold_sections l =
    let rec loop section_l item_l l =
      match l with
      | [] ->
          if List.is_empty item_l then section_l
          else Fmt.failwith "invalid config structure"
      | Blank :: tl | Comment _ :: tl -> loop section_l item_l tl
      | Item item :: tl -> loop section_l (item :: item_l) tl
      | Header header :: tl ->
          let section = { header; items= item_l } in
          loop (section :: section_l) [] tl
    in
    loop [] [] (List.rev l)

  let parse s =
    match parse_string ~consume:All config s with
    | Error msg -> Fmt.failwith "config parse error: %s" msg
    | Ok v -> fold_sections v

  module Pp_debug = struct
    let pp_item ppf { key; value } =
      let open Fmt in
      match String.contains value '"' || String.contains value ' ' with
      | false -> pf ppf "%s = %s" key value
      | true -> pf ppf "%s = \"%s\"" key value

    let pp_line ppf line =
      let open Fmt in
      match line with
      | Blank -> Fmt.nop ppf ()
      | Comment s -> pf ppf "#%s" s
      | Header s -> pf ppf "[%s]" s
      | Item item -> pf ppf "%a" pp_item item

    let _pp_lines ppf raw_line_l =
      let open Fmt in
      pf ppf "%a" (list ~sep:(any "\n") pp_line) raw_line_l

    let pp_section ppf { header; items } =
      let open Fmt in
      pf ppf "[%s]@\n%a" header (list ~sep:(any "\n") pp_item) items

    let pp_config ppf l =
      let open Fmt in
      pf ppf "%a" (list ~sep:(any "\n") pp_section) l
  end
end

let () =
  let content = read_file "default.config" in
  (*Fmt.pr "%s" content;*)
  let config = Untyped.parse content in
  (*Fmt.pr "%a@." pp_lines config;*)
  Fmt.pr "%a@." Untyped.Pp_debug.pp_config config;

  ()