path: root/lib/expression/query.ml

(** 
 This module create an sql query from an expression.
 *)

open StdLabels

(** This type is used in the query builder (see [query_of_expression] just
    below in order to tell if we need to bind the parameters in the query, or
    if we can use plain literal as is (with some risk at the execution time. *)
type _ binded_query =
  | BindParam : ImportCSV.DataType.t Queue.t binded_query
  | NoParam : unit binded_query

module QueryParameter = struct
  (** Internaly, we need to keep a different type for the Literal chunks
    (which requires to be quoted), and raw (which should be given as is to the
    sql engine) 

    The Raw can be generated from both BindParam or NoParam queries. *)
  type t =
    | Literal
    | Queue of ImportCSV.DataType.t Queue.t
    | Raw of t

  (** Wrap the given parameter mode into the raw mode *)
  let raw : t -> t = function
    | Raw t -> Raw t
    | Literal -> Raw Literal
    | Queue q -> Raw (Queue q)

  (** Nest the parameter in order to use it inside another function call. 

      The rule is to get out of the Raw mode as soon as we dive into another
      one function. *)
  let nest : t -> t = function
    | Raw t -> t
    | other -> other
end

module TypeBuilder =
  Compose.Expression
    (Type_of)
    (struct
      let v = ignore
    end)

module Query = TypeBuilder.Make (struct
  type 'a repr = Format.formatter -> nested:QueryParameter.t -> unit
  type 'a obs = Format.formatter -> nested:QueryParameter.t -> unit
  type 'a path_repr = Format.formatter -> 'a -> unit

  let observe : 'a Type_of.obs * 'a repr -> 'a obs =
   fun (_, x) formatter ~nested ->
    let () = x formatter ~nested in
    Format.pp_print_flush formatter ()

  (** Unify an external reference with a given type, using the COALESCE
        function *)
  let unify :
      with_:Type_of.t ->
      nested:QueryParameter.t ->
      Format.formatter ->
      'a Type_of.obs * 'a repr ->
      unit =
   fun ~with_ ~nested format (type_of, expr) ->
    match (type_of, with_) with
    | ImportDataTypes.Types.Extern, Number
    | ImportDataTypes.Types.Extern, Extern ->
        Format.fprintf format "COALESCE(%a,0)"
          (fun f expr -> expr f ~nested)
          expr
    | ImportDataTypes.Types.Extern, String ->
        Format.fprintf format "COALESCE(%a,'')"
          (fun f expr -> expr f ~nested)
          expr
    | _, Float ->
        Format.fprintf format "CAST(%a AS REAL)"
          (fun f expr -> expr f ~nested)
          expr
    | _, _ -> expr ~nested format

  let empty : 'a Type_of.obs -> 'a repr =
   fun type_of formatter ~nested ->
    ignore type_of;
    ignore nested;
    Format.fprintf formatter "''"

  let expr : 'a Type_of.obs * 'a repr -> 'a Type_of.obs -> 'a repr =
   fun expr type_of formatter ~nested ->
    ignore type_of;
    Format.fprintf formatter "(";
    (snd expr) ~nested formatter;
    Format.fprintf formatter ")"

  let literal : string -> 'a Type_of.obs -> 'a repr =
   fun l type_of formatter ~nested ->
    ignore type_of;
    match nested with
    | QueryParameter.Literal ->
        (* If the text is a true literal, we insert it directly. This is
           only called from the [query_of_expression] function *)
        Format.fprintf formatter "'%s'" l
    | QueryParameter.Queue queue ->
        Format.fprintf formatter "?";
        Queue.add (ImportCSV.DataType.Content l) queue
    | QueryParameter.Raw _ -> Format.fprintf formatter "%s" l

  let integer : string -> 'a Type_of.obs -> 'a repr =
   fun l type_of formatter ~nested ->
    ignore type_of;
    ignore nested;
    Format.fprintf formatter "%s" l

  let path : 'b path_repr -> 'b -> 'a Type_of.obs -> 'a repr =
   fun repr p type_of formatter ~nested ->
    ignore nested;
    ignore type_of;
    repr formatter p

  let concat : ('a Type_of.obs * 'a repr) list -> 'a Type_of.obs -> 'a repr =
   fun expression type_of formatter ~nested ->
    ignore type_of;
    let nested' = QueryParameter.nest nested in

    Format.pp_print_list
      ~pp_sep:(fun f () -> Format.fprintf f " || ")
      (unify ~with_:ImportDataTypes.Types.String ~nested:nested')
      formatter expression

  let print_expression :
      ?sep:string ->
      QueryParameter.t ->
      Format.formatter ->
      ('a Type_of.obs * 'a repr) list ->
      unit =
   fun ?(sep = ", ") nested formatter expression ->
    (Format.pp_print_list
       ~pp_sep:(fun f () -> Format.fprintf f "%s" sep)
       (fun f v -> (snd v) f ~nested))
      formatter expression

  (** Format the partition expression. This function is used internally and
      only form the expression inside the clause. *)
  let group_windows :
      QueryParameter.t ->
      Format.formatter ->
      ('a Type_of.obs * 'a repr) list
      * ('a Type_of.obs * 'a repr) list
      * string option ->
      unit =
   fun nested formatter (expressions, order, range) ->
    match (expressions, order) with
    | [], _ -> ()
    | _, [] ->
        Format.fprintf formatter " OVER (PARTITION BY %a%a)"
          (print_expression nested) expressions
          (Format.pp_print_option (fun f v -> Format.fprintf f "%s" v))
          range
    | _, _ ->
        Format.fprintf formatter " OVER (PARTITION BY %a ORDER BY %a%a)"
          (print_expression nested) expressions (print_expression nested) order
          (Format.pp_print_option (fun f v -> Format.fprintf f "%s" v))
          range

  let window :
      ('a Type_of.obs * 'a repr) T.window ->
      ('a Type_of.obs * 'a repr) list ->
      ('a Type_of.obs * 'a repr) list ->
      'a Type_of.obs ->
      'a repr =
   fun name expressions order type_of formatter ~nested ->
    ignore type_of;
    let nested' = QueryParameter.nest nested in

    (* By default, the range is defined like this

       [RANGE BETWEEN UNBOUNDED PRECEDING AND CURRENT ROW EXCLUDE NO OTHERS]

       this only build a range until the current row, but in some cases (min,
       last), we want to scan the whole group in order to evaluate the value to
       keep.
    *)
    let range = " RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING" in
    match name with
    | T.Min expr ->
        Format.fprintf formatter "FIRST_VALUE(%a)%a "
          (fun f v -> (snd v) f ~nested:nested')
          expr (group_windows nested')
          (expressions, order, Some range)
    | T.Max expr ->
        Format.fprintf formatter "LAST_VALUE(%a)%a"
          (fun f v -> (snd v) f ~nested:nested')
          expr (group_windows nested')
          (expressions, order, Some range)
    | T.Counter ->
        (* If no order is given, return the number of elements in the
           whole group *)
        let operator =
          match order with
          | [] -> "COUNT"
          | _ -> "ROW_NUMBER"
        in
        Format.fprintf formatter "%s()%a" operator (group_windows nested')
          (expressions, order, None)
    | T.Previous expr ->
        Format.fprintf formatter "LAG(%a)%a"
          (fun f v -> (snd v) f ~nested:nested')
          expr (group_windows nested') (expressions, order, None)
    | T.Sum expr ->
        Format.fprintf formatter "SUM(%a)%a"
          (fun f v -> (snd v) f ~nested:nested')
          expr (group_windows nested') (expressions, order, None)

  let nvl : ('a Type_of.obs * 'a repr) list -> 'a Type_of.obs -> 'a repr =
   fun expression type_of formatter ~nested ->
    ignore type_of;
    let nested' = QueryParameter.nest nested in
    Format.fprintf formatter "COALESCE(%a)" (print_expression nested')
      expression

  let join :
      string -> ('a Type_of.obs * 'a repr) list -> 'a Type_of.obs -> 'a repr =
   fun sep expression type_of formatter ~nested ->
    ignore type_of;
    let nested' = QueryParameter.nest nested in

    (* Directly call the literal function for the first argument *)
    Format.fprintf formatter "CONCAT(%a, %a)"
      (fun f v -> (literal v ImportDataTypes.Types.String) f ~nested:nested')
      sep (print_expression nested') expression

  let boperator :
      T.binary_operator ->
      'a Type_of.obs * 'a repr ->
      'a Type_of.obs * 'a repr ->
      'a Type_of.obs ->
      'a repr =
   fun name e1 e2 type_of formatter ~nested ->
    ignore type_of;
    (* When dividing, we need to be sure that the type is a float,
       otherwise SQL will truncate the result *)
    let with_ =
      match name with
      | T.Division -> ImportDataTypes.Types.Float
      | _ -> fst e2
    in

    let nested' = QueryParameter.nest nested in
    Format.fprintf formatter "%a%s%a"
      (unify ~with_ ~nested:nested')
      e1
      (* The operator *)
      (T.name_of_operator name)
      (unify ~with_:(fst e1) ~nested:nested')
      e2

  let gequality :
      T.binary_operator ->
      'a Type_of.obs * 'a repr ->
      ('a Type_of.obs * 'a repr) list ->
      'a Type_of.obs ->
      'a repr =
   fun name e1 group type_of ->
    ignore type_of;
    let group_type = List.map ~f:fst group in
    fun formatter ~nested ->
      let nested' = QueryParameter.nest nested in
      let op_name =
        match name with
        | T.Equal -> " IN("
        | T.Different -> " NOT IN("
        | _ -> ""
      in

      Format.fprintf formatter "%a%s%a)"
        (unify ~with_:(Type_of.group' group_type) ~nested:nested')
        e1 op_name (print_expression nested') group

  let exprs expressions formatter ~nested =
    (* Literal expression, starting from now, all the quoted string are
       directly given to the sql engine *)
    let nested' = QueryParameter.raw nested in

    Format.fprintf formatter "(%a)"
      (print_expression ~sep:" " nested')
      expressions

  let rec funct :
      string -> ('a Type_of.obs * 'a repr) list -> 'a Type_of.obs -> 'a repr =
   fun name expressions type_of formatter ~nested ->
    ignore type_of;
    let nested' = QueryParameter.nest nested in
    match name with
    | "expr" ->
        (* Raw expression are parsed directly *)
        exprs expressions formatter ~nested
    | "if" ->
        (* The if is renamed into IIF *)
        funct "IIF" expressions type_of formatter ~nested
    | _ ->
        (* Default case *)
        Format.fprintf formatter "%s(%a)" name (print_expression nested')
          expressions

  let function' :
      T.funct -> ('a Type_of.obs * 'a repr) list -> 'a Type_of.obs -> 'a repr =
   fun name expressions type_of formatter ~nested ->
    ignore type_of;
    let nested' = QueryParameter.nest nested in
    match name with
    | Upper | Trim ->
        Format.fprintf formatter "%s(%a)" (T.name_of_function name)
          (print_expression nested') expressions
end)

module M = Sym.M (Query)

let query_of_expression :
    type b.
    b binded_query ->
    Format.formatter ->
    (Format.formatter -> 'a -> unit) ->
    'a T.t ->
    b =
 fun parameter formatter printer expr ->
  let repr = M.eval ~path_repr:printer expr in
  match parameter with
  | BindParam ->
      let p = Queue.create () in
      let parameter = QueryParameter.Queue p in
      Query.observe repr formatter ~nested:parameter;
      p
  | NoParam ->
      Query.observe repr formatter ~nested:Literal;
      ()