exception UnknownSymbol of (string * string)
exception UnknownExpression of string
exception ExpressionEmpty
exception UnbalancedParenthesis
exception MalformedExpression
exception InvalidDependencyName of string
exception CannotParseConstraints of (string * string)

type version = string

module Token = struct
  type t =
    | VER of string (* version *)
    | ID of string (* ident *)
    | LPAREN
    | RPAREN
    | AND
    | OR
    | NOT
    | EQ
    | NE
    | GT
    | LT
    | GE
    | LE

  let to_string = function
    | VER v -> v
    | ID s -> s
    | LPAREN -> "("
    | RPAREN -> ")"
    | AND -> "&"
    | OR -> "|"
    | NOT -> "!"
    | EQ -> "=="
    | NE -> "!="
    | GT -> ">"
    | LT -> "<"
    | GE -> ">="
    | LE -> "<="

  let of_string symbol s =
    match symbol with
    | "&&" | "&" -> AND
    | "||" | "|" -> OR
    | ">" -> GT
    | "<" -> LT
    | ">=" -> GE
    | "<=" -> LE
    | "==" | "=" -> EQ
    | "!=" | "/=" -> NE
    | "!" -> NOT
    | _ -> raise (UnknownSymbol (symbol, s))

  let process_one_char c next =
    match (c, next) with
    | '(', _ -> LPAREN
    | ')', _ -> RPAREN
    | '!', Some '=' -> raise Not_found (* should be parsed as a string != *)
    | '!', _ -> NOT
    | _ -> raise Not_found

  (* valid char per types *)
  let is_symbol_char c =
    try
      let _ = String.index "&/|!+=><()" c in
      true
    with Not_found -> false

  let is_ident_char c =
    (c >= 'a' && c <= 'z')
    || (c >= 'A' && c <= 'Z')
    || (c >= '0' && c <= '9')
    || c == '_' || c == '.' || c == '-'

  let is_version_char c = (c >= '0' && c <= '9') || c = '.' || c = '*'

  let lexer s =
    let len = String.length s in
    let while_pred pred o =
      let i = ref o in
      while !i < len && pred s.[!i] do
        i := !i + 1
      done;
      (String.sub s o (!i - o), !i)
    in
    (* Per type lexer *)
    let eat_symbol o =
      let tok, no =
        let next = if o + 1 < len then Some s.[o + 1] else None in
        try
          let tok = process_one_char s.[o] next in
          (tok, o + 1)
        with Not_found ->
          let p, no = while_pred is_symbol_char o in
          let tok = of_string p s in
          (tok, no)
      in
      (tok, no)
    in
    let eat_version o = while_pred is_version_char o in
    let eat_ident o = while_pred is_ident_char o in
    (* main lexing loop *)
    let rec loop o =
      if o >= len then
        []
      else begin (* TODO skip chunk of space in one go *)
        if
          s.[o] == ' ' || s.[o] == '\t'
        then
          loop (o + 1)
        else if is_symbol_char s.[o] then
          let sym, no = eat_symbol o in
          sym :: loop no
        else if (s.[o] >= 'a' && s.[o] <= 'z') || (s.[o] >= 'A' && s.[o] <= 'Z') then
          let id, no = eat_ident o in
          ID id :: loop no
        else if is_version_char s.[o] then
          let ver, no = eat_version o in
          VER ver :: loop no
        else
          failwith (Printf.sprintf "unknown character in expression '%c'" s.[o])
      end
    in
    loop 0
end

type t =
  | And of t * t
  | Or of t * t
  | Not of t
  | Paren of t
  | Eq of version
  | Le of version
  | Lt of version
  | Ge of version
  | Gt of version
  | Ne of version

let compare_version v1 v2 =
  let skip i p s e =
    let rec loop i = if i = e then i else if p s.[i] then loop (i + 1) else i in
    loop i
  in
  let split_version v =
    let p1, rest =
      match String_utils.split ':' v ~limit:2 with
      | [ _ ] -> ("", v)
      | [ p1; rest ] -> (p1, rest)
    in
    let p1, p2, p3 =
      match String_utils.split '-' rest ~limit:2 with
      | [ _ ] -> (p1, rest, "")
      | [ p2; p3 ] -> (p1, p2, p3)
    in
    (p1, p2, p3)
  in
  let compare_part p1 p2 =
    let l1 = String.length p1 in
    let l2 = String.length p2 in
    let is_digit = function
      | '0' .. '9' -> true
      | _ -> false
    in
    let rec loop i1 i2 =
      let compare_numbers i1 i2 =
        let rec loop_numbers n1 n2 last =
          if n2 = last then
            loop n1 n2
          else
            let comp = Char.compare p1.[n1] p2.[n2] in
            if comp = 0 then loop_numbers (n1 + 1) (n2 + 1) last else comp
        in
        let end1 = skip i1 is_digit p1 l1 in
        let end2 = skip i2 is_digit p2 l2 in
        let comp = compare (end1 - i1) (end2 - i2) in
        if comp = 0 then loop_numbers i1 i2 end1 else comp
      in
      match (i1 = l1, i2 = l2) with
      | true, true -> 0
      | true, false ->
          let end2 = skip i2 (fun c -> c = '0') p2 l2 in
          if end2 = l2 then 0 else -1
      | false, true ->
          let end1 = skip i1 (fun c -> c = '0') p1 l1 in
          if end1 = l1 then 0 else 1
      | false, false -> (
          match (is_digit p1.[i1], is_digit p2.[i2]) with
          | true, true ->
              compare_numbers (skip i1 (fun c -> c = '0') p1 l1) (skip i2 (fun c -> c = '0') p2 l2)
          | true, false -> -1
          | false, true -> 1
          | false, false ->
              let comp = Char.compare p1.[i1] p2.[i2] in
              if comp = 0 then loop (i1 + 1) (i2 + 1) else comp)
    in
    loop 0 0
  in
  if v1 = v2 then
    0
  else
    let v1_1, v1_2, v1_3 = split_version v1 in
    let v2_1, v2_2, v2_3 = split_version v2 in
    let c1 = compare_part v1_1 v2_1 in
    if c1 <> 0 then
      c1
    else
      let c2 = compare_part v1_2 v2_2 in
      if c2 <> 0 then
        c2
      else
        compare_part v1_3 v2_3

let rec eval version constr =
  match constr with
  | And (e1, e2) -> eval version e1 && eval version e2
  | Or (e1, e2) -> eval version e1 || eval version e2
  | Not e -> not (eval version e)
  | Paren e -> eval version e
  | Eq v -> compare_version version v = 0
  | Le v -> compare_version version v <= 0
  | Lt v -> compare_version version v < 0
  | Ge v -> compare_version version v >= 0
  | Gt v -> compare_version version v > 0
  | Ne v -> compare_version version v <> 0

let rec to_string = function
  | And (e1, e2) -> to_string e1 ^ " && " ^ to_string e2
  | Or (e1, e2) -> to_string e1 ^ " || " ^ to_string e2
  | Not e -> "! " ^ to_string e
  | Paren e -> "(" ^ to_string e ^ ")"
  | Eq v -> "=" ^ v
  | Le v -> "<=" ^ v
  | Lt v -> "<" ^ v
  | Ge v -> ">=" ^ v
  | Gt v -> ">" ^ v
  | Ne v -> "!=" ^ v

let showList sep f l = String.concat sep (List.map f l)

let parse_expr l =
  let rec parse_sub_expr l =
    match l with
    | [] -> raise MalformedExpression
    | Token.NOT :: r ->
        let e, r = parse_sub_expr r in
        (Not e, r)
    | Token.LPAREN :: r ->
        let e, r = parse_sub_expr r in
        let rec loop e r =
          match r with
          | Token.RPAREN :: r -> (Paren e, r)
          | Token.OR :: _ | Token.AND :: _ ->
              let e, r = parse_bin_expr e r in
              loop e r
          | _ -> raise UnbalancedParenthesis
        in
        loop e r
    | Token.GT :: Token.VER v :: r -> (Gt v, r)
    | Token.GE :: Token.VER v :: r -> (Ge v, r)
    | Token.EQ :: Token.VER v :: r -> (Eq v, r)
    | Token.LT :: Token.VER v :: r -> (Lt v, r)
    | Token.LE :: Token.VER v :: r -> (Le v, r)
    | Token.NE :: Token.VER v :: r -> (Ne v, r)
    | z -> raise (UnknownExpression (showList "," Token.to_string z))
  and parse_bin_expr expr l =
    match l with
    | Token.OR :: r ->
        let e, r = parse_sub_expr r in
        (Or (expr, e), r)
    | Token.AND :: r ->
        let e, r = parse_sub_expr r in
        (And (expr, e), r)
    | _ -> raise MalformedExpression
  in
  let e, r = parse_sub_expr l in
  let rec loop e r =
    match r with
    | [] -> e
    | _ ->
      let e, r = parse_bin_expr e r in
      loop e r
  in
  loop e r

let parse_constraints name cs =
  try
    match cs with
    | [] -> None
    | expr ->
        let e = parse_expr expr in
        Some e
  with e ->
    let err =
      match e with
      | UnknownExpression z -> "unknown constraints expression \"" ^ z ^ "\""
      | UnbalancedParenthesis -> "unbalanced parenthesis"
      | MalformedExpression -> "malformed expression"
      | _ -> Printexc.to_string e
    in
    raise (CannotParseConstraints (name, err))

let parse name s =
  match Token.lexer s with
  | [] -> raise ExpressionEmpty
  | constraints -> parse_constraints name constraints

let parse_builddep s =
  match Token.lexer s with
  | [] -> raise ExpressionEmpty
  | Token.ID name :: constraints -> (name, parse_constraints name constraints)
  | x :: _ -> raise (InvalidDependencyName (Token.to_string x))
