(* Ara *)
(* $Id: ara.ml,v 1.2 2004/10/26 09:44:54 berke Exp $ *)

module Make(Dpkg:Dpkg.DB) =
  struct
open Ast
open Dpkg
open Util

type statement = Ast.statement
and query = set_query
and result = Dpkg.IS.t

(*** Predicate construction *)
let hierarchical = Util.hierarchical;;

let predicate = function
| Exact(x) -> ((=) x)
| Lexicographic_le(x) -> fun y -> Debver.compare_versions y x <= 0
| Lexicographic_lt(x) -> fun y -> Debver.compare_versions y x < 0
| Lexicographic_ge(x) -> fun y -> Debver.compare_versions y x >= 0 (* hierarchical *)
| Lexicographic_gt(x) -> fun y -> Debver.compare_versions y x > 0 (* hierarchical *)
| Regular(x,o) ->
    let reg =
      let x' = if List.mem Word_boundary o then "\\b"^x^"\\b" else x in
      if List.mem Case_insensitive o then
        Str.regexp_case_fold x'
      else
        Str.regexp x'
    in
    fun y -> try ignore (Str.search_forward reg y 0); true with Not_found -> false
;;

exception Yes;;

(* let dependencies st =
  let rec loop l = function
    | And(qb1,qb2)|Or(qb1,qb2) ->
        let l = loop l qb1 in
        loop l qb2
    | Not(qb) -> loop l qb
    | True|False -> l
    | Meta(_,qb) -> loop l qb
    | Atom(Reference(id)) -> if List.mem id l then l else id::l
    | Atom(_) -> l
  in
  match st with
  | Statement(st) -> 
  loop [] qb *)

let default_field = Some_field(Regular("^\\(description\\|package\\)$",[]));;

let rec eval_statement ~get ~set ?(cf=default_field) db = function
| Display(q) -> eval ~get ~set ~cf db q
| Assign(id,s1,s2,qb) ->
    let r = eval ~get ~set ~cf db qb in
    set id r s1 s2 qb;
    r
and eval ~get ~set ~cf db = function
| And(qb1,qb2) -> IS.inter (eval ~get ~set ~cf db qb1) (eval ~get ~set ~cf db qb2)
| Or(qb1,qb2) -> IS.union (eval ~get ~set ~cf db qb1) (eval ~get ~set ~cf db qb2)
| Not(qb) -> IS.diff (get_universe db) (eval ~get ~set ~cf db qb)
| True -> get_universe db
| False -> IS.empty
| Atom(x) -> eval_atom ~get ~set ~cf db x
| Meta(With_field(cf),qb) -> eval ~get ~set ~cf db qb
| _ -> assert false
and eval_atom ~get ~set ~cf db = function
| Reference(id) -> get id
| Matches(Current_field,pat) -> eval_atom ~get ~set ~cf db (Matches(cf,pat))
| Matches(Some_field(fdpat),pat) ->
    let fdp = predicate fdpat
    and p = predicate pat
    in
    let fields = get_fields db in
    let m = get_count db in
    let rec loop acc i =
      if i = Array.length fields then
        acc
      else
        loop (if fdp fields.(i) then (i::acc) else acc) (i + 1)
    in
    let fds = loop [] 0 in
    (* List.iter (fun fd ->
      debug 0 (sf "selected field %d named %s" fd db.fields.(fd))) fds; *)
    let rec loop i x =
      if i = m then
        x
      else
        if List.exists (fun fd -> p (get_field db i fd)) fds then
          loop (i + 1) (IS.add i x)
        else
          loop (i + 1) x
    in
    loop 0 IS.empty
| Matches(Either_field(f1,f2),pat) ->
   IS.union
     (eval_atom ~get ~set ~cf db (Matches(f1,pat)))
     (eval_atom ~get ~set ~cf db (Matches(f2,pat)))
| Matches(This_field(fd),pat) ->
    let fdi = field_of_string db fd in
    let p = predicate pat in
    let m = get_count db in
    let rec loop i x =
      if i = m then
        x
      else
        if
          try
            p (get_field db i fdi)
          with
          | Not_found -> false
        then
          loop (i + 1) (IS.add i x)
        else
          loop (i + 1) x
    in
    loop 0 IS.empty
;;

(* Predicate construction and evaluation ***)

exception Parse_error of int * int * string;;

let statement_of_string w : statement =
  let l = Lexing.from_string w in
  try
    Syntax.statement Lexic.token l
  with
  | Parsing.Parse_error ->
      raise (Parse_error(Lexing.lexeme_start l,Lexing.lexeme_end l,"Parse error"))
  | Failure x ->
      raise (Parse_error(Lexing.lexeme_start l,Lexing.lexeme_end l,"Failure: "^x))
  | Lexic.Parse_error(i,j,x) ->
      raise (Parse_error(i,j,x))
;;

let sorted_list_of_query db x =
  List.sort (fun i j -> compare (name_of db i) (name_of db j)) (IS.elements x)
;;

let compute_raw_query db ~get ~set q =
  let x = eval_statement db ~get ~set q in
  let xl = List.sort (fun i j -> compare (name_of db i) (name_of db j)) (IS.elements x) in
  xl
;;

let compute_query db ~get ~set q = sorted_list_of_query db (eval_statement db ~get ~set q);;

let filter_old_versions db x =
  let h = Hashtbl.create 256 in
  List.iter (fun i ->
    try
      let p = name_of db i
      and v = version_of db i
      in
      try
        let (v',i') = Hashtbl.find h p in
        if Debver.compare_versions v' v < 0 then
          Hashtbl.replace h p (v, i)
        else
          ()
      with
      | Not_found -> Hashtbl.add h p (version_of db i, i)
    with
    | Not_found -> ()) x;
  let x' = ref [] in
  Hashtbl.iter (fun _ (_,i) -> x' := i::!x') h;
  !x'
;;

(* let db : Dpkg.db option ref = ref None;; *)
end
