(**************************************************************************)
(*  Copyright © 2009 Stéphane Glondu <steph@glondu.net>                   *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

open Printf
open Benl_error
open Benl_types
open Benl_base

type t = Benl_types.expr

let rec simplify query = match query with
  | EMatch (field, EString package) ->
     let packages = Benl_core.simple_split '|' package in
     let packages = List.map Re.Pcre.quote packages in
     let r_string = String.concat "|" packages in
     let rex = Re.Pcre.regexp (Printf.sprintf "(^| )(%s)\\s*([,(:<]|$)" r_string) in
     EMatch (field, ERegexp (package, rex))
  | EMatch (_, (EDep _ | ERegexp _)) -> query
  | Etrue | Efalse | ESource | EVersion _ | EString _ | ERegexp _ | EDep _ -> query
  | EMatch (f, e) -> EMatch (f, simplify e)
  | EList l -> begin match l with
    | [] -> Etrue
    | h::[] -> simplify h
    | _::_ -> EList (List.map simplify l)
  end
  | ENot e -> begin match (simplify e) with
    | Etrue -> Efalse
    | Efalse -> Etrue
    | e -> ENot e
  end
  | EOr (e1, e2) -> begin match (simplify e1, simplify e2) with
    | Efalse, e | e, Efalse -> e
    | Etrue, _ | _, Etrue -> Etrue
    | e1, e2 -> EOr (e1, e2)
  end
  | EAnd (e1, e2) -> begin match (simplify e1, simplify e2) with
    | Efalse, _ | _, Efalse -> Efalse
    | Etrue, e | e, Etrue -> e
    | e1, e2 -> EAnd (e1, e2)
  end

let of_expr x = simplify x

let of_string s =
  let lexbuf = Lexing.from_string s in
  try
    simplify (Benl_parser.full_expr Benl_lexer.token lexbuf)
  with Benl_parser.Error ->
    let pos = Lexing.lexeme_start_p lexbuf in
    raise (Parsing_error
             (s,
              false,
              pos.Lexing.pos_lnum,
              pos.Lexing.pos_cnum-pos.Lexing.pos_bol))

let parens show expr =
  if show
  then sprintf "(%s)" expr
  else expr

let rec to_string_b ?(escape = true) last_op = function
  | EMatch (f, ERegexp r) ->
      sprintf ".%s ~ %s" f (string_of_regexp r)
  | ENot e ->
      sprintf "!%s" (to_string_b "!" e)
  | Etrue -> sprintf "true"
  | Efalse -> sprintf "false"
  | EAnd (e1, e2) ->
    parens
      (last_op <> "&" && last_op <> "")
      (sprintf "%s & %s" (to_string_b "&" e1) (to_string_b "&" e2))
  | EOr (e1, e2) ->
    parens
      (last_op <> "|" && last_op <> "")
      (sprintf "%s | %s" (to_string_b "|" e1) (to_string_b "|" e2))
  | EList xs ->
      sprintf "[%s]" (String.concat "; " (List.map (to_string_b "") xs))
  | ESource -> "source"
  | EString x -> string_of_string escape x
  | EVersion (cmp, x) ->
    parens (last_op <> "") (sprintf ".%s \"%s\"" (string_of_cmp cmp) x)
  | EMatch (field, EDep (package, cmp, ref_version)) ->
    parens (last_op <> "") (sprintf ".%s ~ \"%s\" %s \"%s\""
                field
                package
                (string_of_cmp cmp)
                ref_version)
  | EMatch (field, EString package) ->
    parens (last_op <> "") (sprintf ".%s ~ \"%s\"" field package)
  | _ -> raise (Unexpected_expression "<unable to convert to string>")

let to_string ?(escape = true) = to_string_b ~escape ""

let rec eval kind pkg = function
  | EMatch (field, ERegexp (_, rex)) ->
      begin try
        let value = Package.get field pkg in
        ignore (Re.Pcre.exec ~rex value);
        true
      with Not_found ->
        false
      end
  | Etrue -> true
  | Efalse -> false
  | ESource ->
      kind = `source
  | EOr (e1, e2) ->
      eval kind pkg e1 || eval kind pkg e2
  | EAnd (e1, e2) ->
      eval kind pkg e1 && eval kind pkg e2
  | ENot e ->
      not (eval kind pkg e)
  | EVersion (cmp, ref_version) ->
      let value = Package.get "version" pkg in
      version_compare cmp value ref_version
  | EMatch (field, EDep (package, cmp, refv)) ->
    let deps = Package.dependencies field pkg in
    List.exists
      (fun x ->
        x.Package.dep_name = package && begin
          match x.Package.dep_version with
            | None -> false
            | Some (rcmp, rrefv) ->
              match rcmp, cmp with
                | Ge, Ge | Gt, Ge | Gt, Gt -> Version.compare rrefv refv >= 0
                | Ge, Gt -> Version.compare rrefv refv > 0
                | _, _ -> false  (* FIXME: missing cases *)
        end)
      deps
  | EMatch (field, EString package) ->
    begin try
      let deps = Package.dependencies field pkg in
      List.exists
        (fun x -> x.Package.dep_name = package)
        deps
    with Not_found ->
      false
    end
  | x ->
      raise (Unexpected_expression (to_string x))

let eval_source x = eval `source x
let eval_binary x = eval `binary x

let rec fields accu = function
  | EMatch (f, _) ->
      Fields.add f accu
  | ENot e ->
      fields accu e
  | Etrue | Efalse -> accu
  | EAnd (e1, e2) | EOr (e1, e2) ->
      fields (fields accu e1) e2
  | EList xs ->
      List.fold_left fields accu xs
  | ESource | EString _ | ERegexp _ | EDep _ ->
      accu
  | EVersion _ ->
      Fields.add "version" accu
