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/.                 *)
(*                                                                           *)
(*****************************************************************************)

open Angstrom

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

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);
    ]

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);
    ]

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;
    ]

(* Float *)

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;
    ]

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