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

type 'a t =
  | Node of 'a
  | And of ('a t * 'a t)
  | Or of ('a t * 'a t)
  | Not of 'a t

let node n = Node n
let ( land ) lhs rhs = And (lhs, rhs)
let ( lor ) lhs rhs = Or (lhs, rhs)
let lnot lhs = Not lhs
let equal : 'a t -> 'a t -> bool = Stdlib.( = )
let verum = node @@ Node.field @@ Field.id @@ Range.range None None
let always = verum
let falsum = lnot verum
let never = falsum
let union = ( lor )
let diff lhs rhs = lhs land lnot rhs

let rec to_string_f f = function
  | Node node ->
      f node
  | And (lhs, rhs) ->
      Printf.sprintf "(%s and %s)" (to_string_f f lhs) (to_string_f f rhs)
  | Or (lhs, rhs) ->
      Printf.sprintf "(%s || %s)" (to_string_f f lhs) (to_string_f f rhs)
  | Not e ->
      Printf.sprintf "not %s" (to_string_f f e)

let to_string = to_string_f Node.to_string

let rec to_sexp_f f = function
  | Node node ->
      f node
  | And (lhs, rhs) ->
      Printf.sprintf "(and %s %s)" (to_sexp_f f lhs) (to_sexp_f f rhs)
  | Or (lhs, rhs) ->
      Printf.sprintf "(or %s %s)" (to_sexp_f f lhs) (to_sexp_f f rhs)
  | Not e ->
      Printf.sprintf "(not %s)" (to_sexp_f f e)

let to_sexp = to_sexp_f Node.to_sexp

let to_sexp_keys e =
  let ( $ ) g f s = g (f s) in
  let s = Field.String.(Key.to_string $ key) in
  let b = Field.Bool.(Key.to_string $ key) in
  let i = Field.Int.(Key.to_string $ key) in
  let i64 = Field.Int64.(Key.to_string $ key) in
  let float = Field.Float.(Key.to_string $ key) in
  to_sexp_f (Field.fold s b i i64 float) e

let comsume combine node s =
  match Angstrom.parse_string ~consume:All Parser.node_cli s with
  | Ok node' ->
      combine node (Node node')
  | Error _ ->
      node

let of_string_keys s =
  let parser = Angstrom.(sep_by Parser.pwhitespace Parser.key_string) in
  Result.to_option @@ Angstrom.parse_string ~consume:All parser (String.trim s)

let of_keys_with_negation ?sep s =
  let sep =
    Option.fold ~none:Parser.pwhitespace
      ~some:(fun s -> Angstrom.(map ~f:ignore @@ string s))
      sep
  in
  let parser = Angstrom.(sep_by sep Parser.keys_with_negation) in
  Result.to_option @@ Angstrom.parse_string ~consume:All parser (String.trim s)

let sexp n =
  let open Angstrom in
  let whitespace = Parser.whitespace in
  let parenthesis parser = char '(' *> parser <* char ')' in

  Angstrom.fix (fun sexp ->
      let sand =
        string_ci "and"
        *> map2 (whitespace sexp) (whitespace sexp) ~f:(fun lhs rhs ->
            And (lhs, rhs)
        )
        |> parenthesis
      in
      let sor =
        string_ci "or"
        *> map2 (whitespace sexp) (whitespace sexp) ~f:(fun lhs rhs ->
            Or (lhs, rhs)
        )
        |> parenthesis
      in
      let snot =
        string_ci "not" *> map (whitespace sexp) ~f:(fun lhs -> Not lhs)
        |> parenthesis
      in
      choice [ sand; sor; snot; map ~f:(fun node -> Node node) n ]
  )

let of_sexp s =
  Result.to_option
  @@ Angstrom.parse_string ~consume:All (sexp Parser.node_sexp) s

let of_sexp_keys s =
  Result.to_option
  @@ Angstrom.parse_string ~consume:All (sexp Parser.key_unit_node) s

let rec of_strings_advance = function
  | [] ->
      (None, [])
  | ("," | "^") :: q ->
      of_strings_advance q
  | t :: q ->
      (Some t, q)

let rec of_strings' node s =
  match s with
  | [] ->
      node
  | "," :: q ->
      let head, q = of_strings_advance q in
      let node =
        match head with
        | None ->
            node
        | Some t ->
            comsume (fun lhs rhs -> Or (lhs, rhs)) node t
      in
      of_strings' node q
  | "^" :: q ->
      let head, q = of_strings_advance q in
      let node =
        match head with
        | None ->
            node
        | Some t ->
            comsume (fun lhs rhs -> And (lhs, Not rhs)) node t
      in
      of_strings' node q
  | s :: q ->
      let node = comsume (fun lhs rhs -> And (lhs, rhs)) node s in
      of_strings' node q

let rec of_strings s =
  match s with
  | [] ->
      None
  | "," :: q ->
      of_strings q
  | "^" :: q -> (
      let head, q = of_strings_advance q in
      match head with
      | None ->
          of_strings q
      | Some t -> (
          match Angstrom.parse_string ~consume:All Parser.node_cli t with
          | Ok node' ->
              Some (of_strings' (Not (Node node')) q)
          | Error _ ->
              of_strings q
        )
    )
  | t :: q -> (
      match Angstrom.parse_string ~consume:All Parser.node_cli t with
      | Ok node' ->
          Some (of_strings' (Node node') q)
      | Error _ ->
          of_strings q
    )

let compare_music_key = QueryMusic.compare_key
let compare_album_key = QueryAlbum.compare_key
let compare_artist_key = QueryArtist.compare_key

let rec mk_compare keys compare lhs rhs =
  match keys with
  | [] ->
      0
  | key :: keys ->
      let cmp = compare key lhs rhs in
      if cmp = 0 then
        mk_compare keys compare lhs rhs
      else
        cmp

let sort_with_keys fsort keys compare list =
  match keys with
  | [] ->
      list
  | _ :: _ as keys ->
      let compare = mk_compare keys compare in
      fsort compare list

let rec matches f query =
  match query with
  | Node node ->
      f node
  | And (lhs, rhs) ->
      matches f lhs && matches f rhs
  | Or (lhs, rhs) ->
      matches f lhs || matches f rhs
  | Not t ->
      not (matches f t)

let matches_musics subfields music_file album participants properties query =
  matches
    (QueryMusic.matches_node subfields
       (music_file, album, participants, properties)
    )
    query

let matches_albums subfields album stats participants query =
  matches (QueryAlbum.matches_node subfields (album, stats, participants)) query

let matches_artists subfields artist query =
  matches (QueryArtist.matches_node subfields artist) query

let matches_metadata_subset bmetadata m2 query =
  matches (QueryMusic.matches_metadata bmetadata m2) query