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 t = Node of Node.t | And of (t * t) | Or of (t * t) | Not of 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 : t -> 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 = function
  | Node node ->
      Node.to_string node
  | And (lhs, rhs) ->
      Printf.sprintf "(%s and %s)" (to_string lhs) (to_string rhs)
  | Or (lhs, rhs) ->
      Printf.sprintf "(%s || %s)" (to_string lhs) (to_string rhs)
  | Not e ->
      Printf.sprintf "not %s" (to_string e)

let rec to_sexp = function
  | Node node ->
      Node.to_sexp node
  | And (lhs, rhs) ->
      Printf.sprintf "(and %s %s)" (to_sexp lhs) (to_sexp rhs)
  | Or (lhs, rhs) ->
      Printf.sprintf "(or %s %s)" (to_sexp lhs) (to_sexp rhs)
  | Not e ->
      Printf.sprintf "(not %s)" (to_sexp 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_sexp s =
  let module P = struct
    open Angstrom

    let whitespace = Parser.whitespace
    let query = Parser.node_sexp
    let parenthesis parser = char '(' *> parser <* char ')'

    let sexp =
      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) query ]
      )
  end in
  Result.to_option @@ Angstrom.parse_string ~consume:All P.sexp 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 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