(define-module (sph sql))

(use-modules (ice-9 match) (srfi srfi-1)
  (sph) (sph tree)
  ((sph alist) #:select (alist-bind)) ((sph list) #:select (flatten any->list contains? flat?))
  ((sph number) #:select (in-between?)) ((sph string) #:select (parenthesise string-replace-chars)))

(export sph-sql-description sql-columns
  sql-columns-list sql-create-index
  sql-create-table sql-delete
  sql-delete-table sql-insert
  sql-insert-values sql-select sql-string sql-update sql-value sql-where sql-where-condition)

(define sph-sql-description "create sql-statements from scheme data")

(define (sql-string a)
  "string -> string
   escapes string values for sql"
  (string-append "'" (string-replace-chars a (q ((#\' #\' #\') (#\\ #\\ #\\)))) "'"))

(define (sql-value a)
  "any -> string
   convert types, escape and quote strings"
  (if (number? a) (number->string a)
    (if (string? a) (sql-string a)
      (if (eq? (q null) a) "NULL"
        (if (eq? (q isnull) a) "ISNULL"
          (if (symbol? a) (sql-string (symbol->string a)) (sql-string (object->string a display))))))))

(define (sql-column a) "symbol/string -> string" (if (symbol? a) (symbol->string a) a))

(define (join-column-value c o v) "sql-column string sql-column -> string"
  (string-append (sql-column c) o (sql-value v)))

(define row-expr-prefixes (q (or and not)))

(define (operator->sql-operator a)
  "symbol/string -> string.
   not is already used for row-expressions, so use \"isnot\""
  (case a
    ((equal =) "=")
    ((greater >) ">")
    ((greater-or-equal >=) ">=")
    ((less <) "<")
    ((less-or-equal <=) "<=")
    ((like) " like ")
    ((isnot) " is not ")
    ((space) " ")
    (else
      (if (string? a) a
        (if (symbol? a) (string-append " " (symbol->string a) " ")
          (raise (q wrong-type-for-argument)))))))

(define (sql-where-column-expr-produce-proc column-name state->combinator)
  "this procedure might be doing too much at once, split if possible"
  (let*
    ( (join-values
        (l (c values operator sql-operator)
          (first
            (tree-map-lists-depth
              (l (values value-state)
                (let
                  ( (value-combinator (state->combinator value-state))
                    (use-sql-in?
                      (and (odd? value-state)
                        (or (eq? (q equal) operator) (eq? (q isnot) operator)) (flat? values))))
                  (let
                    (combine-with-values
                      (if (= 1 (length values))
                        ( (l (v) (l (c) (join-column-value (column-name c) sql-operator v)))
                          (first values))
                        (if use-sql-in?
                          (l (c)
                            (string-append (column-name c) (if (eq? (q isnot) operator) " not" "")
                              " in(" (string-join (map sql-value values) ",") ")"))
                          (l (c)
                            (parenthesise
                              (string-join
                                (map
                                  (l (v)
                                    (if (list? v) (first v) (join-column-value c sql-operator v)))
                                  values)
                                value-combinator))))))
                    ((if (eqv? 1 value-state) identity list) (combine-with-values c)))))
              (list (any->list values))))))
      (join-columns-values
        (l (columns values operator sql-operator)
          (first
            (tree-map-lists-depth
              (l (columns column-state)
                (let (column-combinator (state->combinator column-state))
                  ( (if (eq? 1 column-state) identity list)
                    (if (= 1 (length columns))
                      (if (list? (first columns)) (first (first columns))
                        (join-values (first columns) values operator sql-operator))
                      (parenthesise
                        (string-join
                          (map
                            (l (c)
                              (if (list? c) (first c) (join-values c values operator sql-operator)))
                            columns)
                          column-combinator))))))
              (list (any->list columns)))))))
    (lambda (operator columns values)
      (join-columns-values columns values operator (operator->sql-operator operator)))))

(define primitive-sql-where-condition
  (let*
    ( (row-expr-binary
        (l (prefix suffix level)
          ( (if (or (eqv? 1 level) (= 1 (length suffix))) identity parenthesise)
            (string-join suffix (if (eq? (q or) prefix) " or " " and ")))))
      (row-expr-unary (l (prefix suffix level) (string-append "not " (first suffix))))
      (state->combinator (l (state) (if (even? state) " and " " or ")))
      (column-name (l (c) (if (string? c) c (symbol->string c))))
      (column-expr-produce (sql-where-column-expr-produce-proc column-name state->combinator))
      (column-expr
        (l (prefix suffix) "add implicit operator to column-expression"
          (apply column-expr-produce
            (if (= (length suffix) 2) (list prefix (first suffix) (first (tail suffix)))
              (list (q equal) prefix (first suffix))))))
      (handle-row-expr
        (l (prefix suffix level)
          ( (case prefix
              ((or and) row-expr-binary)
              ((not) row-expr-unary)
              (else (pair (q invalid-row-expr-prefix) prefix)))
            prefix
            (if (pair? (first suffix))
              (map (l (a) (if (pair? a) (join-column-value (first a) "=" (tail a)) a)) suffix) suffix)
            level))))
    (lambda (a) "sql-where-condition -> sql-string"
      (if (sql-where-condition? a)
        (prefix-tree-map-c-depth handle-row-expr
          (l (lis proc continue level)
            (if (or (null? lis) (contains? row-expr-prefixes (first lis))) (continue lis level)
              (column-expr (first lis) (tail lis))))
          a)
        (raise (q not-a-sql-where-condition))))))

(define (sql-insert-values? a) "any -> boolean"
  (if (or (string? a) (every (l (a) (or (and (pair? a) (not (list? a))) (string? a))) a)) #t #f))

(define (sql-where-condition-column? expr) "any -> boolean"
  (and (list? expr) (in-between? (length expr) 1 5)
    (not (contains? row-expr-prefixes (first expr)))))

(define (sql-where-condition? a) "any -> boolean"
  (match a
    ( ( (or (quote or) (quote and) (quote not))
        (or (? sql-where-condition?) (? sql-where-condition-column?)) ...)
      #t)
    (_ #f)))

(define (sql-where-condition expr)
  "for creating a \"where\" part sql separately.
   \"not\" in row-expressions will always be in front of the column-condition in the resulting query. sqlite for example does not understand
   \"not c=NULL\" as one might expect. use \"ISNULL\" instead of \"NULL\" in this case."
  (if (list? expr)
    (if (null? expr) expr
      (primitive-sql-where-condition (if (pair? (first expr)) (pair (q and) expr) expr)))
    (if (pair? expr) (join-column-value (first expr) "=" (tail expr)) expr)))

(define sql-insert-values
  (let (handle-column (l (c) (if (symbol? (first c)) (symbol->string (first c)) (first c))))
    (l (a)
      "alist -> string
       convert to a sql values specification for the insert statement
       ((a . 1) (b . 2)) -> (a,b)values(1,2)"
      (if (pair? a)
        (if (null? a) #f
          (string-append "("
            (if (list? a) (string-join (map handle-column a) ",") (sql-value (handle-column a)))
            ")values("
            (if (list? a) (string-join (map (l (b) (sql-value (tail b))) a) ",")
              (sql-value (tail a)))
            ")"))
        #f))))

(define (sql-where conditions) "string/pair/list -> string"
  (if (null? conditions) ""
    (string-append " where "
      (if (pair? conditions) (sql-where-condition conditions)
        (if (string? conditions) conditions #f)))))

(define (sql-options options)
  "list:alist -> (string:begin-part string:end-part)
   constructs the additional options parts of an sql-statement, usually some part
   at the beginning of the statement or one at the end.
   alist keys can be the following symbols: order, limit, offset, begin, end
   order: string/(string:space-joined ...)
   limit: string/(integer:offset integer:limit)
   offset: string/integer"
  (alist-bind options (order limit offset begin end)
    (pair (if begin (string-append " " begin) "")
      (string-append
        (if offset (string-append " offset " (if (integer? offset) (number->string offset) offset))
          "")
        (if limit
          (cond
            ((number? limit) (string-append " limit " (number->string limit)))
            ( (and (pair? limit))
              (string-append " limit " (number->string (first limit))
                "," (if (list? limit) (number->string (list-ref limit 1)) (tail limit))))
            (else limit))
          "")
        (if order (string-append " order by " (if (list? order) (string-join order " ") order)) "")
        (if end (string-append " " end) "")))))

(define (sql-columns-list columns) "(pair/list/string ...) -> list"
  (flatten
    (map
      (l (column)
        (if (pair? column)
          (if (list? column)
            (let ((table-name (first column)))
              (map (l (column-name) (string-append table-name "." column-name)) (tail column)))
            (string-append (first column) "." (tail column)))
          column))
      columns)))

(define (sql-columns columns)
  "pair/list/string/boolean -> string
   construct the \"column\" part of an sql expression"
  (if (pair? columns)
    (if (list? columns) (if (null? columns) #f (string-join (sql-columns-list columns) ","))
      (string-append (first columns) "." (tail columns)))
    (if (string? columns) columns (if (and (boolean? columns) columns) "*" #f))))

(define* (sql-select tables #:optional (columns #t) where options)
  "string/(string ...) [string/(string ...)/boolean:all-columns string/list/pair string/list] -> string"
  (let
    ( (columns (sql-columns columns))
      (tables
        (if (and (list? tables) (not (null? tables))) (string-join tables ",")
          (if (string? tables) tables #f)))
      (where (if where (sql-where where) "")) (options (sql-options options)))
    (and columns tables
      where options
      (string-append "select " (first options) columns " from " tables where (tail options)))))

(define* (sql-update table-name set #:optional where options)
  "string pair/list/string sql-where list -> string
   example: (sql-update \"table-name\" ((a . 1) (b . 2))) -> \"update table-name set a=1 and b=2\""
  (let
    ( (set
        (if (list? set)
          (string-join
            (map (l (a) (string-append (sql-column (first a)) "=" (sql-value (tail a)))) set) ",")
          (if (pair? set) (string-append (sql-column (first set)) "=" (sql-value (tail set)))
            (if (string? set) set #f))))
      (where (if where (sql-where where) "")) (options (sql-options options)))
    (and table-name where
      options (string-append "update " (first options) table-name " set " set where (tail options)))))

(define* (sql-insert table-name data #:optional options)
  "string string/boolean/((column-name . data) ...) -> string"
  (let
    ( (options (sql-options options))
      (values
        (cond
          ((string? data) data)
          ((boolean? data) " default values")
          (else (sql-insert-values data)))))
    (and table-name (sql-insert-values? data)
      options (string-append "insert" (first options) " into " table-name values (tail options)))))

(define* (sql-delete table-name #:optional where options) "string sql-where sql-options -> string"
  (let (options (sql-options options))
    (string-append "delete from " table-name (if where (sql-where where) "") (tail options))))

(define* (sql-create-table table-name columns #:optional (replace #t) add)
  "string ((name type options ...)/string ...) [boolean string:custom-suffix]"
  (string-append "create table " (if replace "" "if not exists ")
    table-name "("
    (if (list? columns)
      (string-join (map (l (column) (if (list? column) (string-join column " ") column)) columns)
        ",")
      columns)
    (if add (string-append "," add) "") ")"))

(define* (sql-create-index name table-name columns #:optional (replace #t))
  "string string string ... -> string"
  (string-append "create index" (if replace "" " if not exists ")
    name " on " table-name " (" (string-join columns ",") ")"))

(define (sql-delete-table table-name) "string -> string"
  (string-append "drop table if exists " table-name))