Source file parser.ml

(*****************************************************************************)
(*                                                                           *)
(*  Copyright (C) 2026 Yves Ndiaye                                           *)
(*                                                                           *)
(* This Source Code Form is subject to the terms of the Mozilla Public       *)
(* License, v. 2.0. If a copy of the MPL was not distributed with this       *)
(* file, You can obtain one at https://mozilla.org/MPL/2.0/.                 *)
(*                                                                           *)
(*****************************************************************************)
module Date = struct
  let mk ~year ~month ~day ~hours ~minutes ~secondes =
    (* caml year are start at 1900 *)
    let year = year - 1900 in
    (* month are 0-11 but input is 1-12 *)
    let month = Option.fold ~none:0 ~some:(fun m -> m - 1) month in
    let day = Option.value ~default:1 day in
    let hours = Option.value ~default:0 hours in
    let minutes = Option.value ~default:0 minutes in
    let secondes = Option.value ~default:0 secondes in
    let date =
      Unix.
        {
          tm_sec = secondes;
          tm_min = minutes;
          tm_hour = hours;
          tm_mday = day;
          tm_mon = month;
          tm_year = year;
          (* ignore when mktime (cf doc)*)
          tm_wday = 0;
          tm_yday = 0;
          tm_isdst = false;
        }
    in
    let t, _ = Unix.mktime date in
    t

  let of_rel_now value instant rel =
    let now = Unix.time () in
    let now = Unix.localtime now in
    let f =
      match rel with `Ago -> fun v -> v - value | `Ahead -> ( + ) value
    in
    let date =
      match instant with
      | `Year ->
          { now with tm_year = f now.tm_year }
      | `Month ->
          { now with tm_mon = f now.tm_mon }
      | `Day ->
          { now with tm_mday = f now.tm_mday }
      | `Hour ->
          { now with tm_hour = f now.tm_hour }
      | `Minute ->
          { now with tm_min = f now.tm_min }
      | `Seconde ->
          { now with tm_sec = f now.tm_sec }
    in
    let t, _ = Unix.mktime date in
    t
end

open Angstrom

let is_digit = function '0' .. '9' -> true | _ -> false
let pwhitespace = skip_while (function ' ' | '\t' -> true | _ -> false)
let whitespace next = pwhitespace *> next
let number_pos = map ~f:int_of_string (take_while1 is_digit)
let number64 = map ~f:Int64.of_string (take_while1 is_digit)
let number = choice [ number_pos; map ~f:( ~- ) @@ (char '-' *> number_pos) ]
let number64 = choice [ number64; map ~f:Int64.neg @@ (char '-' *> number64) ]

let float_with_dot =
  let float = map number_pos ~f:Fun.id in
  map2 number
    (char '.' *> option None (map ~f:Option.some float))
    ~f:(fun min sec ->
      let sec = Option.value ~default:0 sec in
      let s = Printf.sprintf "%u.%u" min sec in
      Float.of_string s
    )

let float = choice [ float_with_dot; map ~f:Float.of_int number ]

let time =
  let snumber = char ':' *> number_pos in
  choice
    [
      map3 number_pos snumber snumber ~f:(fun h m s -> (h, Some m, Some s));
      map2 number_pos snumber ~f:(fun h m -> (h, Some m, None));
      map number_pos ~f:(fun h -> (h, None, None));
    ]

let date =
  let snumber = char '-' *> number_pos in
  choice
    [
      map3 number_pos snumber snumber ~f:(fun h m s -> (h, Some m, Some s));
      map2 number_pos snumber ~f:(fun h m -> (h, Some m, None));
      map number_pos ~f:(fun h -> (h, None, None));
    ]

let date_rel =
  let instant =
    choice
      [
        map (char 'y') ~f:(fun _ -> `Year);
        map (char 'm') ~f:(fun _ -> `Month);
        map (char 'd') ~f:(fun _ -> `Day);
        map (char 's') ~f:(fun _ -> `Seconde);
        map (char 'i') ~f:(fun _ -> `Minute);
        map (char 'h') ~f:(fun _ -> `Hour);
      ]
  in
  let futur =
    choice
      [
        map (string "ago") ~f:(fun _ -> `Ago);
        map (string "ahead") ~f:(fun _ -> `Ahead);
      ]
  in
  map3 number_pos instant futur ~f:(fun n instant futur -> (n, instant, futur))

let date_time =
  (* the parser order is relevent*)
  choice
    [
      (* year-month-dayThour(:minutes)?(:secondes)? *)
      map2 date
        (char 'T' *> time)
        ~f:(fun (year, month, day) (hours, minutes, secondes) ->
          Date.mk ~year ~month ~day ~hours:(Some hours) ~minutes ~secondes
        );
      map date_rel ~f:(fun (value, instant, rel) ->
          Date.of_rel_now value instant rel
      );
      float_with_dot;
      map date ~f:(fun (year, month, day) ->
          Date.mk ~year ~month ~day ~hours:None ~minutes:None ~secondes:None
      );
      map (string_ci "now") ~f:(fun _ -> Unix.time ());
    ]

let length =
  choice
    [
      map2 number (char ':' *> number) ~f:(fun min sec -> (min * 60) + sec);
      number;
    ]

let string_escape espace_chars f =
  let scanner_quoted state =
    let parser =
      scan_state (state, String.empty) (fun (state, buffer) c ->
          match state with
          | `Escaped ->
              (* Horrendous but can not use buffer. *)
              let buffer = Printf.sprintf "%s%c" buffer c in
              Some (`Unscaped, buffer)
          | `Unscaped -> (
              match c with
              | '\\' ->
                  Some (`Escaped, buffer)
              | '"' ->
                  None
              | _ ->
                  let buffer = Printf.sprintf "%s%c" buffer c in
                  Some (state, buffer)
            )
      )
    in
    map ~f:(fun (_, buffer) -> buffer) parser
  in
  let p =
    choice
      [
        char '"' *> scanner_quoted `Unscaped <* char '"';
        Angstrom.take_while (fun c -> not (List.mem c espace_chars));
      ]
  in
  map p ~f

let string_arbitrary_key f = string_escape [ ':' ] f
let string_sexp f = string_escape Util.sexp_escape_char f
let string_all k = map (take_while (Fun.const true)) ~f:k

let key_string =
  let s ~f m = map ~f (string m) in
  let sa = string Util.arbitrary_prefix *> string_arbitrary_key Fun.id in
  let sa = map ~f:(fun s -> Field.String.Key.Arbitrary s) sa in
  choice
    [
      sa;
      s Keys.title ~f:(Fun.const Field.String.Key.Title);
      s Keys.sort_name ~f:(Fun.const Field.String.Key.SortName);
      s Keys.artist ~f:(Fun.const Field.String.Key.Artist);
      s Keys.album_artist ~f:(Fun.const Field.String.Key.AlbumArtist);
      s Keys.album ~f:(Fun.const Field.String.Key.Album);
      s Keys.composer ~f:(Fun.const Field.String.Key.Composer);
      s Keys.genre ~f:(Fun.const Field.String.Key.Genre);
      s Keys.path ~f:(Fun.const Field.String.Key.Path);
      s Keys.extension ~f:(Fun.const Field.String.Key.FileExtension);
    ]

let key_bool =
  let s ~f m = map ~f (string m) in
  choice
    [
      s Keys.art ~f:(Fun.const Field.Bool.Key.Art);
      s Keys.flag ~f:(Fun.const Field.Bool.Key.Flag);
    ]

let key_int64 =
  let s ~f m = map ~f (string m) in
  choice
    [
      s Keys.id ~f:(Fun.const Field.Int64.Key.Id);
      s Keys.size ~f:(Fun.const Field.Int64.Key.Size);
    ]

let key_int =
  let s ~f m = map ~f (string m) in
  choice
    [
      s Keys.track ~f:(Fun.const Field.Int.Key.Track);
      s Keys.year ~f:(Fun.const Field.Int.Key.Year);
      s Keys.disc ~f:(Fun.const Field.Int.Key.Disc);
      s Keys.plays ~f:(Fun.const Field.Int.Key.Plays);
      s Keys.length ~f:(Fun.const Field.Int.Key.Length);
      s Keys.rating ~f:(Fun.const Field.Int.Key.Rating);
      s Keys.album_count ~f:(Fun.const Field.Int.Key.AlbumCount);
      s Keys.music_count ~f:(Fun.const Field.Int.Key.MusicCount);
    ]

let key_float =
  let s ~f m = map ~f (string m) in
  choice
    [
      s Keys.avg_duration ~f:(Fun.const Field.Float.Key.AvgDuration);
      s Keys.avg_rating ~f:(Fun.const Field.Float.Key.AvgRating);
      s Keys.avg_size ~f:(Fun.const Field.Float.Key.AvgSize);
      s Keys.created_at ~f:(Fun.const Field.Float.Key.CreatedAt);
      s Keys.modified_at ~f:(Fun.const Field.Float.Key.ModifiedAt);
      s Keys.played_at ~f:(Fun.const Field.Float.Key.PlayedAt);
    ]

let keys =
  choice
    [
      (* key int need to be before key_string for allowing
        the key %album_count before %album
      *)
      map ~f:(fun s -> `Int s) key_int;
      map ~f:(fun s -> `String s) key_string;
      map ~f:(fun s -> `Bool s) key_bool;
      map ~f:(fun s -> `Int64 s) key_int64;
      map ~f:(fun s -> `Float s) key_float;
    ]

let to_field = function
  | `String k ->
      Field.(string @@ String.init false false k ())
  | `Bool b ->
      Field.(bool @@ Bool.init b ())
  | `Int64 i ->
      Field.(int64 @@ Int64.init i @@ Range.value ())
  | `Int i ->
      Field.(int @@ Int.init i @@ Range.value ())
  | `Float i ->
      Field.(float @@ Float.init i @@ Range.value ())

let keys_with_negation =
  let negation_parser = option false @@ map ~f:(Fun.const true) @@ char '^' in
  map2
    ~f:(fun b k ->
      let k = to_field k in
      (b, k)
    )
    negation_parser keys

let key_unit_node = map ~f:to_field keys

let parser_format_string =
  let not_variable_parser =
    map ~f:(fun s -> `String s) @@ take_while (( <> ) '%')
  in
  let parser_variable_or =
    choice
      [ map ~f:(fun v -> `Field v) keys; map ~f:(fun c -> `Char c) @@ char '%' ]
  in
  fix (fun p ->
      let p2 =
        at_end_of_input
        >>= function
        | true ->
            return @@ [ `String String.empty ]
        | false ->
            map2 ~f:List.cons parser_variable_or p
      in
      map2 ~f:List.cons not_variable_parser p2
  )

let sfield_value ~pstring i f =
  choice
    [
      (* [true] for regex, i for case sensibility. *)
      char ':' *> pstring (fun s -> f true i s);
      pstring (fun s -> f false i s);
    ]

let sfield_choice ~pstring p i f = p *> char ':' *> sfield_value ~pstring i f

let sfield_cs ~pstring parser f =
  let parser = char '%' *> parser in
  sfield_choice ~pstring parser false f

let sfield_ci ~pstring parser f = sfield_choice ~pstring parser true f

let sfield_artibrary ~pstring parser f =
  let p1 = string Util.arbitrary_prefix *> parser in
  let p1 =
    choice
      [
        map ~f:(fun s -> (false, s)) (char '%' *> p1);
        map ~f:(fun s -> (true, s)) p1;
      ]
  in
  p1 >>= fun (i, s) -> char ':' *> sfield_value ~pstring i (f s)

let sfield ~pstring name f =
  let parser = string name in
  choice [ sfield_cs ~pstring parser f; sfield_ci ~pstring parser f ]

let string_field ~pstring =
  let arbitrary key r i v = Field.String.arbitrary r i key v in
  choice
    [
      sfield_artibrary ~pstring (string_arbitrary_key Fun.id) arbitrary;
      sfield ~pstring Keys.title Field.String.title;
      sfield ~pstring Keys.sort_name Field.String.sort_name;
      sfield ~pstring Keys.artist Field.String.artist;
      sfield ~pstring Keys.album_artist Field.String.album_artist;
      sfield ~pstring Keys.album Field.String.album;
      sfield ~pstring Keys.composer Field.String.composer;
      sfield ~pstring Keys.genre Field.String.genre;
      sfield ~pstring Keys.path Field.String.path;
      sfield ~pstring Keys.extension Field.String.extension;
    ]

(** Bool *)

let bfield name f =
  string name *> char ':'
  *> choice
       [
         map (string_ci "true") ~f:(fun _ -> f true);
         map (string_ci "false") ~f:(fun _ -> f false);
         map number ~f:(fun n -> f (n <> 0));
       ]

let flag = bfield Keys.flag Field.Bool.flag
let art = bfield Keys.art Field.Bool.art
let bool_field = choice [ art; flag ]

(* Int *)

let range parser =
  let oparser = option None (map ~f:Option.some parser) in
  map2 oparser (string ".." *> oparser) ~f:Range.range

let field_range name parser k =
  string name *> char ':'
  *> map ~f:k (choice [ range parser; map parser ~f:Range.value ])

let int64_field =
  choice
    [
      field_range Keys.id number64 Field.Int64.id;
      field_range Keys.size number64 Field.Int64.size;
    ]

let int_field =
  choice
    [
      field_range Keys.track number Field.Int.track;
      field_range Keys.year number Field.Int.year;
      field_range Keys.disc number Field.Int.disc;
      field_range Keys.plays number Field.Int.plays;
      field_range Keys.length length Field.Int.length;
      field_range Keys.rating number Field.Int.rating;
      field_range Keys.album_count number Field.Int.album_count;
      field_range Keys.music_count number Field.Int.music_count;
    ]

(* Float *)

let float_field =
  choice
    [
      field_range Keys.avg_duration float Field.Float.avg_duration;
      field_range Keys.avg_rating float Field.Float.avg_rating;
      field_range Keys.avg_size float Field.Float.avg_size;
      field_range Keys.created_at date_time Field.Float.created_at;
      field_range Keys.modified_at date_time Field.Float.modified_at;
      field_range Keys.played_at date_time Field.Float.played_at;
    ]

let field ~pstring =
  choice
    [
      (* key int need to be before key_string for allowing
        the key %album_count before %album
      *)
      map ~f:Field.int int_field;
      map ~f:Field.string (string_field ~pstring);
      map ~f:Field.int64 int64_field;
      map ~f:Field.bool bool_field;
      map ~f:Field.float float_field;
    ]

let substring ~pstring = pstring Node.substring

let node ~pstring ~substr =
  choice [ map ~f:Node.field (field ~pstring); substring ~pstring:substr ]

let node_cli = node ~pstring:string_all ~substr:string_all
let node_sexp = node ~pstring:string_sexp ~substr:string_sexp