{- |

Module "Database.PostgreSQL.PQTypes.SQL.Builder" offers a nice
monadic DSL for building SQL statements on the fly. Some examples:

>>> :{
>>> | sqlSelect "documents" $ do
>>> |  sqlResult "id"
>>> |  sqlResult "title"
>>> |  sqlResult "mtime"
>>> |  sqlOrderBy "documents.mtime DESC"
>>> |  sqlWhereILike "documents.title" "%pattern%"
>>> :}
SQL " SELECT  id, title, mtime FROM documents WHERE (documents.title ILIKE <\"%pattern%\">)   ORDER BY documents.mtime DESC  "

@SQL.Builder@ supports SELECT as 'sqlSelect' and data manipulation using
'sqlInsert', 'sqlInsertSelect', 'sqlDelete' and 'sqlUpdate'.

>>> import Data.Time.Clock
>>> now <- getCurrentTime
>>> :{
>>> | sqlInsert "documents" $ do
>>> |   sqlSet "title" title
>>> |   sqlSet "ctime" now
>>> |   sqlResult "id"
>>> :}
SQL " INSERT INTO documents (title, ctime) VALUES (<\"title\">, <\"2017-02-01 17:56:20.324894547 UTC\">) RETURNING id"

The 'sqlInsertSelect' is particulary interesting as it supports INSERT
of values taken from a SELECT clause from same or even different
tables.

There is a possibility to do multiple inserts at once. Data given by
'sqlSetList' will be inserted multiple times, data given by 'sqlSet'
will be multiplied as many times as needed to cover all inserted rows
(it is common to all rows). If you use multiple 'sqlSetList' then
lists will be made equal in length by appending @DEFAULT@ as fill
element.

>>> :{
>>> | sqlInsert "documents" $ do
>>> |   sqlSet "ctime" now
>>> |   sqlSetList "title" ["title1", "title2", "title3"]
>>> |   sqlResult "id"
>>> :}
SQL " INSERT INTO documents (ctime, title) VALUES (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title1\">) , (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title2\">) , (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title3\">) RETURNING id"

The above will insert 3 new documents.

@SQL.Builder@ provides quite a lot of SQL magic, including @ORDER BY@ as
'sqlOrderBy', @GROUP BY@ as 'sqlGroupBy'.

>>> :{
>>> | sqlSelect "documents" $ do
>>> |   sqlResult "id"
>>> |   sqlResult "title"
>>> |   sqlResult "mtime"
>>> |   sqlOrderBy "documents.mtime DESC"
>>> |   sqlOrderBy "documents.title"
>>> |   sqlGroupBy "documents.status"
>>> |   sqlJoinOn "users" "documents.user_id = users.id"
>>> |   sqlWhere $ mkSQL "documents.title ILIKE" <?> "%pattern%"
>>> :}
SQL " SELECT  id, title, mtime FROM documents  JOIN  users  ON  documents.user_id = users.id WHERE (documents.title ILIKE <\"%pattern%\">) GROUP BY documents.status  ORDER BY documents.mtime DESC, documents.title  "

Joins are done by 'sqlJoinOn', 'sqlLeftJoinOn', 'sqlRightJoinOn',
'sqlJoinOn', 'sqlFullJoinOn'. If everything fails use 'sqlJoin' and
'sqlFrom' to set join clause as string. Support for a join grammars as
some kind of abstract syntax data type is lacking.

>>> :{
>>> | sqlDelete "mails" $ do
>>> |   sqlWhere "id > 67"
>>> :}
SQL " DELETE FROM mails  WHERE (id > 67) "

>>> :{
>>> | sqlUpdate "document_tags" $ do
>>> |   sqlSet "value" (123 :: Int)
>>> |   sqlWhere "name = 'abc'"
>>> :}
SQL " UPDATE document_tags SET value=<123>  WHERE (name = 'abc') "

Exception returning and 'kWhyNot' are a subsystem for querying why a
query did not provide expected results. For example:

> let query = sqlUpdate "documents" $ do
>   sqlSet "deleted" True
>   sqlWhereEq "documents.id" 12345
>   sqlWhereEqE DocumentDeleteFlagMustBe "documents.deleted" False
>   sqlWhereILikeE DocumentTitleMustContain "documents.title" "%important%"
> result <- kRun query

If the result is zero then no document was updated. We would like to
know what happened. In query we have three filtering clauses. One is a
baseline: the one mentioning @documents.id@. Baseline clauses define
what objects we are talking about. Other clauses are correctness
checks and may fail if status of on object is unexpected. Using
'kWhyNot' we can see what is wrong with an object:

> problems <- kWhyNot query

Now @problems@ should contain a list of issues with rows that could be
possibly be affected by weren't due to correctness clauses. For
example it may state:

> problems = [[ DocumentDeleteFlagMustBe { documentDeleteFlagMustBe = False
>                                        , documentDeleteFlagReallyIs = True
>                                        }
>             , DocumentTitleMustContain { documentTitleMustContain = "%important%"
>                                        , documentTitleReallyIs = "Some contract v2"
>                                        }
>             ]]

Note: problems is a nested array, for each object we get a list of
issues pertaining to that object. If that list is empty, then it means
that baseline conditions failed or there is no such object that
fullfills all conditions at the same time although there are some that
fullfill each one separatelly.

Note: @kWhyNot@ is currently disabled. Use 'kWhyNot1' instead, which
returns a single exception.

-}

-- TODO: clean this up and fix the mess with
-- "randomly" wrapping stuff in parentheses.

module Database.PostgreSQL.PQTypes.SQL.Builder
  ( sqlWhere
  , sqlWhereE
  , sqlWhereEV
  , sqlWhereEVV
  , sqlWhereEVVV
  , sqlWhereEVVVV
  , sqlWhereEq
  , sqlWhereEqE
  , sqlWhereEqSql
  , sqlWhereNotEq
  , sqlWhereNotEqE
  , sqlWhereIn
  , sqlWhereInSql
  , sqlWhereInE
  , sqlWhereNotIn
  , sqlWhereNotInSql
  , sqlWhereNotInE
  , sqlWhereExists
  , sqlWhereNotExists
  , sqlWhereLike
  , sqlWhereLikeE
  , sqlWhereILike
  , sqlWhereILikeE
  , sqlWhereIsNULL
  , sqlWhereIsNotNULL
  , sqlWhereIsNULLE

  , sqlIgnore

  , sqlFrom
  , sqlJoin
  , sqlJoinOn
  , sqlLeftJoinOn
  , sqlRightJoinOn
  , sqlFullJoinOn
  , sqlSet
  , sqlSetInc
  , sqlSetList
  , sqlSetListWithDefaults
  , sqlSetCmd
  , sqlSetCmdList
  , sqlCopyColumn
  , sqlResult
  , sqlOrderBy
  , sqlGroupBy
  , sqlHaving
  , sqlOffset
  , sqlLimit
  , sqlDistinct
  , sqlWith

  , SqlTurnIntoSelect
  , sqlTurnIntoSelect
  , sqlTurnIntoWhyNotSelect

  , sqlSelect
  , sqlSelect2
  , SqlSelect(..)
  , sqlInsert
  , SqlInsert(..)
  , sqlInsertSelect
  , SqlInsertSelect(..)
  , sqlUpdate
  , SqlUpdate(..)
  , sqlDelete
  , SqlDelete(..)

  , sqlWhereAny
  , sqlWhereAnyE

  , SqlResult
  , SqlSet
  , SqlFrom
  , SqlWhere
  , SqlOrderBy
  , SqlGroupByHaving
  , SqlOffsetLimit
  , SqlDistinct


  , SqlCondition(..)
  , sqlGetWhereConditions

  , SqlWhyNot(..)

  , kWhyNot1
  --, DBExceptionCouldNotParseValues(..)
  , kRun1OrThrowWhyNot
  , kRun1OrThrowWhyNotAllowIgnore
  , kRunManyOrThrowWhyNot
  , kRunAndFetch1OrThrowWhyNot

  , DBExtraException(..)
  , SomeDBExtraException(..)
  , catchDBExtraException
  , DBBaseLineConditionIsFalse(..)

  , Sqlable(..)
  , sqlOR
  , sqlConcatComma
  , sqlConcatAND
  , sqlConcatOR
  , parenthesize
  , AscDesc(..)
  )
  where

import Control.Exception.Lifted as E
import Control.Monad.Catch
import Control.Monad.State
import Control.Monad.Trans.Control
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Monoid.Utils
import Data.String
import Data.Typeable
import Database.PostgreSQL.PQTypes
import Prelude
import Safe (atMay)
import qualified Text.JSON.Gen as JSON

class Sqlable a where
  toSQLCommand :: a -> SQL

instance Sqlable SQL where
  toSQLCommand = id

smintercalate :: (IsString m, Monoid m) => m -> [m] -> m
smintercalate m = mintercalate $ mconcat [mspace, m, mspace]

sqlOR :: SQL -> SQL -> SQL
sqlOR s1 s2 = sqlConcatOR [s1, s2]

sqlConcatComma :: [SQL] -> SQL
sqlConcatComma = mintercalate ", "

sqlConcatAND :: [SQL] -> SQL
sqlConcatAND = smintercalate "AND" . map parenthesize

sqlConcatOR :: [SQL] -> SQL
sqlConcatOR = smintercalate "OR" . map parenthesize

parenthesize :: SQL -> SQL
parenthesize s = "(" <> s <> ")"

-- | 'AscDesc' marks ORDER BY order as ascending or descending.
-- Conversion to SQL adds DESC marker to descending and no marker
-- to ascending order.
data AscDesc a = Asc a | Desc a
  deriving (Eq, Show)

data Multiplicity a = Single a | Many [a]
  deriving (Eq, Ord, Show, Typeable)

-- | 'SqlCondition' are clauses that are part of the WHERE block in
-- SQL statements. Each statement has a list of conditions, all of
-- them must be fulfilled.  Sometimes we need to inspect internal
-- structure of a condition. For now it seems that the only
-- interesting case is EXISTS (SELECT ...), because that internal
-- SELECT can have explainable clauses.
data SqlCondition = SqlPlainCondition SQL SqlWhyNot
                  | SqlExistsCondition SqlSelect
                    deriving (Typeable, Show)

-- | 'SqlWhyNot' contains a recipe for how to query the database for
-- some values we're interested in and construct a proper exception
-- object using that information. For @SqlWhyNot mkException queries@
-- the @mkException@ should take as input a list of the same length
-- list as there are queries. Each query will be run in a JOIN context
-- with all referenced tables, so it can extract values from there.
data SqlWhyNot =
  forall e row. (FromRow row, DBExtraException e) =>
  SqlWhyNot Bool (row -> e) [SQL]

{-
instance Eq SqlCondition where
  (SqlPlainCondition a _) == (SqlPlainCondition b _) = a == b
  (SqlExistsCondition a) == (SqlExistsCondition b) = a == b
  _ == _ = False
  -}

instance Show SqlWhyNot where
  show (SqlWhyNot _important exc expr) = "SqlWhyNot " ++ show (typeOf (exc $undefined)) ++ " " ++ show expr

instance Sqlable SqlCondition where
  toSQLCommand (SqlPlainCondition a _) = a
  toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a { sqlSelectResult = ["TRUE"] }) <> ")"

data SqlSelect = SqlSelect
  { sqlSelectFrom     :: SQL
  , sqlSelectDistinct :: Bool
  , sqlSelectResult   :: [SQL]
  , sqlSelectWhere    :: [SqlCondition]
  , sqlSelectOrderBy  :: [SQL]
  , sqlSelectGroupBy  :: [SQL]
  , sqlSelectHaving   :: [SQL]
  , sqlSelectOffset   :: Integer
  , sqlSelectLimit    :: Integer
  , sqlSelectWith     :: [(SQL, SQL)]
  }

data SqlUpdate = SqlUpdate
  { sqlUpdateWhat   :: SQL
  , sqlUpdateFrom   :: SQL
  , sqlUpdateWhere  :: [SqlCondition]
  , sqlUpdateSet    :: [(SQL,SQL)]
  , sqlUpdateResult :: [SQL]
  , sqlUpdateWith   :: [(SQL, SQL)]
  }

data SqlInsert = SqlInsert
  { sqlInsertWhat   :: SQL
  , sqlInsertSet    :: [(SQL, Multiplicity SQL)]
  , sqlInsertResult :: [SQL]
  , sqlInsertWith   :: [(SQL, SQL)]
  }

data SqlInsertSelect = SqlInsertSelect
  { sqlInsertSelectWhat     :: SQL
  , sqlInsertSelectDistinct :: Bool
  , sqlInsertSelectSet      :: [(SQL, SQL)]
  , sqlInsertSelectResult   :: [SQL]
  , sqlInsertSelectFrom     :: SQL
  , sqlInsertSelectWhere    :: [SqlCondition]
  , sqlInsertSelectOrderBy  :: [SQL]
  , sqlInsertSelectGroupBy  :: [SQL]
  , sqlInsertSelectHaving   :: [SQL]
  , sqlInsertSelectOffset   :: Integer
  , sqlInsertSelectLimit    :: Integer
  , sqlInsertSelectWith     :: [(SQL, SQL)]
  }

data SqlDelete = SqlDelete
  { sqlDeleteFrom   :: SQL
  , sqlDeleteUsing  :: SQL
  , sqlDeleteWhere  :: [SqlCondition]
  , sqlDeleteResult :: [SQL]
  , sqlDeleteWith   :: [(SQL, SQL)]
  }

-- | This is not exported and is used as an implementation detail in
-- 'sqlWhereAll'.
data SqlAll = SqlAll
  { sqlAllWhere :: [SqlCondition]
  }

instance Show SqlSelect where
  show = show . toSQLCommand

instance Show SqlInsert where
  show = show . toSQLCommand

instance Show SqlInsertSelect where
  show = show . toSQLCommand

instance Show SqlUpdate where
  show = show . toSQLCommand

instance Show SqlDelete where
  show = show . toSQLCommand

instance Show SqlAll where
  show = show . toSQLCommand

emitClause :: Sqlable sql => SQL -> sql -> SQL
emitClause name s = case toSQLCommand s of
  sql
    | isSqlEmpty sql -> ""
    | otherwise   -> name <+> sql

emitClausesSep :: SQL -> SQL -> [SQL] -> SQL
emitClausesSep _name _sep [] = mempty
emitClausesSep name sep sqls = name <+> smintercalate sep (filter (not . isSqlEmpty) $ map parenthesize sqls)

emitClausesSepComma :: SQL -> [SQL] -> SQL
emitClausesSepComma _name [] = mempty
emitClausesSepComma name sqls = name <+> sqlConcatComma (filter (not . isSqlEmpty) sqls)

instance IsSQL SqlSelect where
  withSQL = withSQL . toSQLCommand

instance IsSQL SqlInsert where
  withSQL = withSQL . toSQLCommand

instance IsSQL SqlInsertSelect where
  withSQL = withSQL . toSQLCommand

instance IsSQL SqlUpdate where
  withSQL = withSQL . toSQLCommand

instance IsSQL SqlDelete where
  withSQL = withSQL . toSQLCommand

instance Sqlable SqlSelect where
  toSQLCommand cmd =
        emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlSelectWith cmd)) <+>
        "SELECT" <+> (if sqlSelectDistinct cmd then "DISTINCT" else mempty) <+>
        sqlConcatComma (sqlSelectResult cmd) <+>
        emitClause "FROM" (sqlSelectFrom cmd) <+>
        emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlSelectWhere cmd) <+>
        emitClausesSepComma "GROUP BY" (sqlSelectGroupBy cmd) <+>
        emitClausesSep "HAVING" "AND" (sqlSelectHaving cmd) <+>
        emitClausesSepComma "ORDER BY" (sqlSelectOrderBy cmd) <+>
        (if sqlSelectOffset cmd > 0
           then unsafeSQL ("OFFSET " ++ show (sqlSelectOffset cmd))
           else "") <+>
        (if sqlSelectLimit cmd >= 0
           then unsafeSQL ("LIMIT " ++ show (sqlSelectLimit cmd))
           else "")

instance Sqlable SqlInsert where
  toSQLCommand cmd =
    emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlInsertWith cmd)) <+>
    "INSERT INTO" <+> sqlInsertWhat cmd <+>
    parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd))) <+>
    emitClausesSep "VALUES" "," (map sqlConcatComma (transpose (map (makeLongEnough . snd) (sqlInsertSet cmd)))) <+>
    emitClausesSepComma "RETURNING" (sqlInsertResult cmd)
   where
      -- this is the longest list of values
      longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd)))
      lengthOfEither (Single _) = 1
      lengthOfEither (Many x)   = length x
      makeLongEnough (Single x) = take longest (repeat x)
      makeLongEnough (Many x)   = take longest (x ++ repeat "DEFAULT")

instance Sqlable SqlInsertSelect where
  toSQLCommand cmd =
    "INSERT INTO" <+> sqlInsertSelectWhat cmd <+>
    parenthesize (sqlConcatComma (map fst (sqlInsertSelectSet cmd))) <+>
    parenthesize (toSQLCommand (SqlSelect { sqlSelectFrom    = sqlInsertSelectFrom cmd
                                          , sqlSelectDistinct = sqlInsertSelectDistinct cmd
                                          , sqlSelectResult  = fmap snd $ sqlInsertSelectSet cmd
                                          , sqlSelectWhere   = sqlInsertSelectWhere cmd
                                          , sqlSelectOrderBy = sqlInsertSelectOrderBy cmd
                                          , sqlSelectGroupBy = sqlInsertSelectGroupBy cmd
                                          , sqlSelectHaving  = sqlInsertSelectHaving cmd
                                          , sqlSelectOffset  = sqlInsertSelectOffset cmd
                                          , sqlSelectLimit   = sqlInsertSelectLimit cmd
                                          , sqlSelectWith    = sqlInsertSelectWith cmd
                                          })) <+>
    emitClausesSepComma "RETURNING" (sqlInsertSelectResult cmd)

instance Sqlable SqlUpdate where
  toSQLCommand cmd =
    emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlUpdateWith cmd)) <+>
    "UPDATE" <+> sqlUpdateWhat cmd <+> "SET" <+>
    sqlConcatComma (map (\(name, command) -> name <> "=" <> command) (sqlUpdateSet cmd)) <+>
    emitClause "FROM" (sqlUpdateFrom cmd) <+>
    emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlUpdateWhere cmd) <+>
    emitClausesSepComma "RETURNING" (sqlUpdateResult cmd)

instance Sqlable SqlDelete where
  toSQLCommand cmd =
    emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlDeleteWith cmd)) <+>
    "DELETE FROM" <+> sqlDeleteFrom cmd <+>
    emitClause "USING" (sqlDeleteUsing cmd) <+>
        emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlDeleteWhere cmd) <+>
    emitClausesSepComma "RETURNING" (sqlDeleteResult cmd)

instance Sqlable SqlAll where
  toSQLCommand cmd | null (sqlAllWhere cmd) = "TRUE"
  toSQLCommand cmd =
    "(" <+> smintercalate "AND" (map (parenthesize . toSQLCommand) (sqlAllWhere cmd)) <+> ")"


sqlSelect :: SQL -> State SqlSelect () -> SqlSelect
sqlSelect table refine =
  execState refine (SqlSelect table False [] [] [] [] [] 0 (-1) [])

sqlSelect2 :: SQL -> State SqlSelect () -> SqlSelect
sqlSelect2 from refine =
  execState refine (SqlSelect from False [] [] [] [] [] 0 (-1) [])

sqlInsert :: SQL -> State SqlInsert () -> SqlInsert
sqlInsert table refine =
  execState refine (SqlInsert table mempty [] [])

sqlInsertSelect :: SQL -> SQL -> State SqlInsertSelect () -> SqlInsertSelect
sqlInsertSelect table from refine =
  execState refine (SqlInsertSelect
                    { sqlInsertSelectWhat    = table
                    , sqlInsertSelectDistinct = False
                    , sqlInsertSelectSet     = []
                    , sqlInsertSelectResult  = []
                    , sqlInsertSelectFrom    = from
                    , sqlInsertSelectWhere   = []
                    , sqlInsertSelectOrderBy = []
                    , sqlInsertSelectGroupBy = []
                    , sqlInsertSelectHaving  = []
                    , sqlInsertSelectOffset  = 0
                    , sqlInsertSelectLimit   = -1
                    , sqlInsertSelectWith    = []
                    })

sqlUpdate :: SQL -> State SqlUpdate () -> SqlUpdate
sqlUpdate table refine =
  execState refine (SqlUpdate table mempty [] [] [] [])

sqlDelete :: SQL -> State SqlDelete () -> SqlDelete
sqlDelete table refine =
  execState refine (SqlDelete  { sqlDeleteFrom   = table
                               , sqlDeleteUsing  = mempty
                               , sqlDeleteWhere  = []
                               , sqlDeleteResult = []
                               , sqlDeleteWith   = []
                               })

class SqlWith a where
  sqlWith1 :: a -> SQL -> SQL -> a


instance SqlWith SqlSelect where
  sqlWith1 cmd name sql = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql)] }

instance SqlWith SqlInsertSelect where
  sqlWith1 cmd name sql = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql)] }

instance SqlWith SqlUpdate where
  sqlWith1 cmd name sql = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql)] }

instance SqlWith SqlDelete where
  sqlWith1 cmd name sql = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql)] }

sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()
sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql))



class SqlWhere a where
  sqlWhere1 :: a -> SqlCondition -> a
  sqlGetWhereConditions :: a -> [SqlCondition]

instance SqlWhere SqlSelect where
  sqlWhere1 cmd cond = cmd { sqlSelectWhere = sqlSelectWhere cmd ++ [cond] }
  sqlGetWhereConditions = sqlSelectWhere

instance SqlWhere SqlInsertSelect where
  sqlWhere1 cmd cond = cmd { sqlInsertSelectWhere = sqlInsertSelectWhere cmd ++ [cond] }
  sqlGetWhereConditions = sqlInsertSelectWhere

instance SqlWhere SqlUpdate where
  sqlWhere1 cmd cond = cmd { sqlUpdateWhere = sqlUpdateWhere cmd ++ [cond] }
  sqlGetWhereConditions = sqlUpdateWhere

instance SqlWhere SqlDelete where
  sqlWhere1 cmd cond = cmd { sqlDeleteWhere = sqlDeleteWhere cmd ++ [cond] }
  sqlGetWhereConditions = sqlDeleteWhere

instance SqlWhere SqlAll where
  sqlWhere1 cmd cond = cmd { sqlAllWhere = sqlAllWhere cmd ++ [cond] }
  sqlGetWhereConditions = sqlAllWhere

newtype SqlWhereIgnore a = SqlWhereIgnore { unSqlWhereIgnore :: a }


ignoreWhereClause :: SqlCondition -> SqlCondition
ignoreWhereClause (SqlPlainCondition sql (SqlWhyNot _b f s)) =
  SqlPlainCondition sql (SqlWhyNot False f s)
ignoreWhereClause (SqlExistsCondition sql) =
  SqlExistsCondition (sql { sqlSelectWhere = map ignoreWhereClause (sqlSelectWhere sql)})

instance (SqlWhere a) => SqlWhere (SqlWhereIgnore a) where
  sqlWhere1 (SqlWhereIgnore cmd) cond =
        SqlWhereIgnore (sqlWhere1 cmd (ignoreWhereClause cond))
  sqlGetWhereConditions (SqlWhereIgnore cmd) = sqlGetWhereConditions cmd


sqlIgnore :: (MonadState s m)
          => State (SqlWhereIgnore s) a
          -> m ()
sqlIgnore clauses = modify (\cmd -> unSqlWhereIgnore (execState clauses (SqlWhereIgnore cmd)))

-- | The @WHERE@ part of an SQL query. See above for a usage
-- example. See also 'SqlCondition'.
sqlWhere :: (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere sql = sqlWhereE (DBBaseLineConditionIsFalse sql) sql

-- | Like 'sqlWhere', but also takes an exception value that is thrown
-- in case of error. See 'SqlCondition' and 'SqlWhyNot'.
sqlWhereE :: (MonadState v m, SqlWhere v, DBExtraException e) => e -> SQL -> m ()
sqlWhereE exc sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [])))
  where
    exc2 (_::()) = exc

-- | Like 'sqlWhereE', but takes a one-argument function that
-- constructs an exception value plus an SQL fragment for querying the
-- database for the argument that is fed into the exception
-- constructor function. See 'SqlCondition' and 'SqlWhyNot'.
--
-- The SQL fragment should be of form @TABLENAME.COLUMNAME@, as it is
-- executed as part of a @SELECT@ query involving all referenced
-- tables.
sqlWhereEV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a) => (a -> e, SQL) -> SQL -> m ()
sqlWhereEV (exc, vsql) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql])))
  where
    exc2 (Identity v1) = exc v1

-- | Like 'sqlWhereEV', but the exception constructor function takes
-- two arguments.
sqlWhereEVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b) => (a -> b -> e, SQL, SQL) -> SQL -> m ()
sqlWhereEVV (exc, vsql1, vsql2) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2])))
  where
    exc2 (v1, v2) = exc v1 v2

-- | Like 'sqlWhereEV', but the exception constructor function takes
-- three arguments.
sqlWhereEVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c) => (a -> b -> c -> e, SQL, SQL, SQL) -> SQL -> m ()
sqlWhereEVVV (exc, vsql1, vsql2, vsql3) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3])))
  where
    exc2 (v1, v2, v3) = exc v1 v2 v3

-- | Like 'sqlWhereEV', but the exception constructor function takes
-- four arguments.
sqlWhereEVVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c, FromSQL d) => (a -> b -> c -> d -> e, SQL, SQL, SQL, SQL) -> SQL -> m ()
sqlWhereEVVVV (exc, vsql1, vsql2, vsql3, vsql4) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3, vsql4])))
  where
    exc2 (v1, v2, v3, v4) = exc v1 v2 v3 v4

sqlWhereEq :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereEq name value = sqlWhere $ name <+> "=" <?> value

sqlWhereEqE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, FromSQL a, ToSQL a)
            => (a -> a -> e) -> SQL -> a -> m ()
sqlWhereEqE exc name value = sqlWhereEV (exc value, name) $ name <+> "=" <?> value

sqlWhereEqSql :: (MonadState v m, SqlWhere v, Sqlable sql) => SQL -> sql -> m ()
sqlWhereEqSql name1 name2 = sqlWhere $ name1 <+> "=" <+> toSQLCommand name2

sqlWhereNotEq :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereNotEq name value = sqlWhere $ name <+> "<>" <?> value

sqlWhereNotEqE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
               => (a -> a -> e) -> SQL -> a -> m ()
sqlWhereNotEqE exc name value = sqlWhereEV (exc value, name) $ name <+> "<>" <?> value

sqlWhereLike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereLike name value = sqlWhere $ name <+> "LIKE" <?> value

sqlWhereLikeE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
              => (a -> a -> e) -> SQL -> a -> m ()
sqlWhereLikeE exc name value = sqlWhereEV (exc value, name) $ name <+> "LIKE" <?> value

sqlWhereILike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereILike name value = sqlWhere  $ name <+> "ILIKE" <?> value

sqlWhereILikeE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
               => (a -> a -> e) -> SQL -> a -> m ()
sqlWhereILikeE exc name value = sqlWhereEV (exc value, name) $ name <+> "ILIKE" <?> value

sqlWhereIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m ()
sqlWhereIn _name [] = sqlWhere "FALSE"
sqlWhereIn name [value] = sqlWhereEq name value
sqlWhereIn name values = do
  -- Unpack the array to give query optimizer more options.
  sqlWhere $ name <+> "IN (SELECT UNNEST(" <?> Array1 values <+> "))"

sqlWhereInSql :: (MonadState v m, Sqlable a, SqlWhere v) => SQL -> a -> m ()
sqlWhereInSql name sql = sqlWhere $ name <+> "IN" <+> parenthesize (toSQLCommand sql)

sqlWhereInE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
            => ([a] -> a -> e) -> SQL -> [a] -> m ()
sqlWhereInE exc name [] = sqlWhereEV (exc [], name) "FALSE"
sqlWhereInE exc name [value] = sqlWhereEqE (exc . (\x -> [x])) name value
sqlWhereInE exc name values =
  sqlWhereEV (exc values, name) $ name <+> "IN (SELECT UNNEST(" <?> Array1 values <+> "))"

sqlWhereNotIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m ()
sqlWhereNotIn _name [] = sqlWhere "TRUE"
sqlWhereNotIn name [value] = sqlWhereNotEq name value
sqlWhereNotIn name values = sqlWhere $ name <+> "NOT IN (SELECT UNNEST(" <?> Array1 values <+> "))"

sqlWhereNotInSql :: (MonadState v m, Sqlable a, SqlWhere v) => SQL -> a -> m ()
sqlWhereNotInSql name sql = sqlWhere $ name <+> "NOT IN" <+> parenthesize (toSQLCommand sql)

sqlWhereNotInE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
               => ([a] -> a -> e) -> SQL -> [a] -> m ()
sqlWhereNotInE exc name [] = sqlWhereEV (exc [], name) "TRUE"
sqlWhereNotInE exc name [value] = sqlWhereNotEqE (exc . (\x -> [x])) name value
sqlWhereNotInE exc name values =
  sqlWhereEV (exc values, name) $ name <+> "NOT IN (SELECT UNNEST(" <?> Array1 values <+> "))"

sqlWhereExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m ()
sqlWhereExists sql = do
  modify (\cmd -> sqlWhere1 cmd (SqlExistsCondition sql))

sqlWhereNotExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m ()
sqlWhereNotExists sqlSelectD = do
  sqlWhere ("NOT EXISTS (" <+> toSQLCommand (sqlSelectD { sqlSelectResult = ["TRUE"] }) <+> ")")

sqlWhereIsNULL :: (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNULL col = sqlWhere $ col <+> "IS NULL"

sqlWhereIsNotNULL :: (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNotNULL col = sqlWhere $ col <+> "IS NOT NULL"

sqlWhereIsNULLE :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a)
                => (a -> e) -> SQL -> m ()
sqlWhereIsNULLE exc col = sqlWhereEV (exc, col) $ col <+> "IS NULL"

-- | Add a condition in the WHERE statement that holds if any of the given
-- condition holds.
sqlWhereAny :: (MonadState v m, SqlWhere v) => [State SqlAll ()] -> m ()
sqlWhereAny = sqlWhere . sqlWhereAnyImpl

-- | Add a condition just like 'sqlWhereAny' but throw the given exception if
-- none of the given conditions hold.
sqlWhereAnyE :: (DBExtraException e, MonadState v m, SqlWhere v)
             => e -> [State SqlAll ()] -> m ()
sqlWhereAnyE e = sqlWhereE e . sqlWhereAnyImpl

sqlWhereAnyImpl :: [State SqlAll ()] -> SQL
sqlWhereAnyImpl [] = "FALSE"
sqlWhereAnyImpl l =
  "(" <+> smintercalate "OR" (map (parenthesize . toSQLCommand
                                   . flip execState (SqlAll [])) l) <+> ")"

class SqlFrom a where
  sqlFrom1 :: a -> SQL -> a

instance SqlFrom SqlSelect where
  sqlFrom1 cmd sql = cmd { sqlSelectFrom = sqlSelectFrom cmd <+> sql }

instance SqlFrom SqlInsertSelect where
  sqlFrom1 cmd sql = cmd { sqlInsertSelectFrom = sqlInsertSelectFrom cmd <+> sql }

instance SqlFrom SqlUpdate where
  sqlFrom1 cmd sql = cmd { sqlUpdateFrom = sqlUpdateFrom cmd <+> sql }

instance SqlFrom SqlDelete where
  sqlFrom1 cmd sql = cmd { sqlDeleteUsing = sqlDeleteUsing cmd <+> sql }

sqlFrom :: (MonadState v m, SqlFrom v) => SQL -> m ()
sqlFrom sql = modify (\cmd -> sqlFrom1 cmd sql)

sqlJoin :: (MonadState v m, SqlFrom v) => SQL -> m ()
sqlJoin table = sqlFrom (", " <+> table)

sqlJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlJoinOn table condition = sqlFrom (" JOIN " <+>
                                     table <+>
                                     " ON " <+>
                                     condition)

sqlLeftJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlLeftJoinOn table condition = sqlFrom (" LEFT JOIN " <+>
                                         table <+>
                                         " ON " <+>
                                         condition)

sqlRightJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlRightJoinOn table condition = sqlFrom (" RIGHT JOIN " <+>
                                          table <+>
                                          " ON " <+>
                                          condition)

sqlFullJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlFullJoinOn table condition = sqlFrom (" FULL JOIN " <+>
                                         table <+>
                                         " ON " <+>
                                         condition)

class SqlSet a where
  sqlSet1 :: a -> SQL -> SQL -> a

instance SqlSet SqlUpdate where
  sqlSet1 cmd name v = cmd { sqlUpdateSet = sqlUpdateSet cmd ++ [(name, v)] }

instance SqlSet SqlInsert where
  sqlSet1 cmd name v = cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Single v)] }

instance SqlSet SqlInsertSelect where
  sqlSet1 cmd name v = cmd { sqlInsertSelectSet = sqlInsertSelectSet cmd ++ [(name, v)] }

sqlSetCmd :: (MonadState v m, SqlSet v) => SQL -> SQL -> m ()
sqlSetCmd name sql = modify (\cmd -> sqlSet1 cmd name sql)

sqlSetCmdList :: (MonadState SqlInsert m) => SQL -> [SQL] -> m ()
sqlSetCmdList name as = modify (\cmd -> cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Many as)] })

sqlSet :: (MonadState v m, SqlSet v, Show a, ToSQL a) => SQL -> a -> m ()
sqlSet name a = sqlSetCmd name (sqlParam a)

sqlSetInc :: (MonadState v m, SqlSet v) => SQL -> m ()
sqlSetInc name = sqlSetCmd name $ name <+> "+ 1"

sqlSetList :: (MonadState SqlInsert m, Show a, ToSQL a) => SQL -> [a] -> m ()
sqlSetList name as = sqlSetCmdList name (map sqlParam as)

sqlSetListWithDefaults :: (MonadState SqlInsert m, Show a, ToSQL a) => SQL -> [Maybe a] -> m ()
sqlSetListWithDefaults name as = sqlSetCmdList name (map (maybe "DEFAULT" sqlParam) as)

sqlCopyColumn :: (MonadState v m, SqlSet v) => SQL -> m ()
sqlCopyColumn column = sqlSetCmd column column

class SqlResult a where
  sqlResult1 :: a -> SQL -> a

instance SqlResult SqlSelect where
  sqlResult1 cmd sql = cmd { sqlSelectResult = sqlSelectResult cmd ++ [sql] }

instance SqlResult SqlInsert where
  sqlResult1 cmd sql = cmd { sqlInsertResult = sqlInsertResult cmd ++ [sql] }

instance SqlResult SqlInsertSelect where
  sqlResult1 cmd sql = cmd { sqlInsertSelectResult = sqlInsertSelectResult cmd ++ [sql] }

instance SqlResult SqlUpdate where
  sqlResult1 cmd sql = cmd { sqlUpdateResult = sqlUpdateResult cmd ++ [sql] }



sqlResult :: (MonadState v m, SqlResult v) => SQL -> m ()
sqlResult sql = modify (\cmd -> sqlResult1 cmd sql)

class SqlOrderBy a where
  sqlOrderBy1 :: a -> SQL -> a

instance SqlOrderBy SqlSelect where
  sqlOrderBy1 cmd sql = cmd { sqlSelectOrderBy = sqlSelectOrderBy cmd ++ [sql] }

instance SqlOrderBy SqlInsertSelect where
  sqlOrderBy1 cmd sql = cmd { sqlInsertSelectOrderBy = sqlInsertSelectOrderBy cmd ++ [sql] }


sqlOrderBy :: (MonadState v m, SqlOrderBy v) => SQL -> m ()
sqlOrderBy sql = modify (\cmd -> sqlOrderBy1 cmd sql)

class SqlGroupByHaving a where
  sqlGroupBy1 :: a -> SQL -> a
  sqlHaving1 :: a -> SQL -> a

instance SqlGroupByHaving SqlSelect where
  sqlGroupBy1 cmd sql = cmd { sqlSelectGroupBy = sqlSelectGroupBy cmd ++ [sql] }
  sqlHaving1 cmd sql = cmd { sqlSelectHaving = sqlSelectHaving cmd ++ [sql] }

instance SqlGroupByHaving SqlInsertSelect where
  sqlGroupBy1 cmd sql = cmd { sqlInsertSelectGroupBy = sqlInsertSelectGroupBy cmd ++ [sql] }
  sqlHaving1 cmd sql = cmd { sqlInsertSelectHaving = sqlInsertSelectHaving cmd ++ [sql] }

sqlGroupBy :: (MonadState v m, SqlGroupByHaving v) => SQL -> m ()
sqlGroupBy sql = modify (\cmd -> sqlGroupBy1 cmd sql)

sqlHaving :: (MonadState v m, SqlGroupByHaving v) => SQL -> m ()
sqlHaving sql = modify (\cmd -> sqlHaving1 cmd sql)


class SqlOffsetLimit a where
  sqlOffset1 :: a -> Integer -> a
  sqlLimit1 :: a -> Integer -> a

instance SqlOffsetLimit SqlSelect where
  sqlOffset1 cmd num = cmd { sqlSelectOffset = num }
  sqlLimit1 cmd num = cmd { sqlSelectLimit = num }

instance SqlOffsetLimit SqlInsertSelect where
  sqlOffset1 cmd num = cmd { sqlInsertSelectOffset = num }
  sqlLimit1 cmd num = cmd { sqlInsertSelectLimit = num }

sqlOffset :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m ()
sqlOffset val = modify (\cmd -> sqlOffset1 cmd $ toInteger val)

sqlLimit :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m ()
sqlLimit val = modify (\cmd -> sqlLimit1 cmd $ toInteger val)

class SqlDistinct a where
  sqlDistinct1 :: a -> a

instance SqlDistinct SqlSelect where
  sqlDistinct1 cmd = cmd { sqlSelectDistinct = True }

instance SqlDistinct SqlInsertSelect where
  sqlDistinct1 cmd = cmd { sqlInsertSelectDistinct = True }

sqlDistinct :: (MonadState v m, SqlDistinct v) => m ()
sqlDistinct = modify (\cmd -> sqlDistinct1 cmd)


class (SqlWhere a, Sqlable a) => SqlTurnIntoSelect a where
  sqlTurnIntoSelect :: a -> SqlSelect

instance SqlTurnIntoSelect SqlSelect where
  sqlTurnIntoSelect = id


-- | The 'sqlTurnIntoWhyNotSelect' turns a failed query into a
-- why-not-query that can explain why query altered zero rows or
-- returned zero results.
--
-- Lets consider an example of explanation:
--
-- > UPDATE t1
-- >    SET a = 1
-- >  WHERE cond1
-- >    AND cond2                       -- with value2
-- >    AND EXISTS (SELECT TRUE
-- >                  FROM t2
-- >                 WHERE cond3        -- with value3a and value3b
-- >                   AND EXISTS (SELECT TRUE
-- >                                 FROM t3
-- >                                WHERE cond4))
--
-- 'sqlTurnIntoWhyNotSelect' will produce a @SELECT@ of the form:
--
-- > SELECT
-- >   EXISTS (SELECT TRUE ... WHERE cond1),
-- >   EXISTS (SELECT TRUE ... WHERE cond1 AND cond2),
-- >   EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3),
-- >   EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3 AND cond4);
--
-- Now, after this statement is executed we see which of these
-- returned @FALSE@ as the first one. This is the condition that failed
-- the whole query.
--
-- We can get more information at this point. If failed condition was
-- @cond2@, then @value2@ can be extracted by this statement:
--
-- > SELECT value2 ... WHERE cond1;
--
-- If failed condition was @cond3@, then statement executed can be:
--
-- > SELECT value3a, value3b ... WHERE cond1 AND cond2;
--
-- Rationale: @EXISTS@ clauses should pinpoint which @condX@ was the first
-- one to produce zero rows.  @SELECT@ clauses after @EXISTS@ should
-- explain why condX filtered out all rows.
--
-- 'DB.WhyNot.kWhyNot1' looks for first @EXISTS@ clause that is @FALSE@
-- and then tries to construct an @Exception@ object with values that come
-- after. If values that comes after cannot be sensibly parsed
-- (usually they are @NULL@ when a value is expected), this exception is
-- skipped and next one is tried.
--
-- If first @EXISTS@ clause is @TRUE@ but no other exception was properly
-- generated then @DBExceptionCouldNotParseValues@ is thrown with pair
-- of 'typeRef' of first exception that could not be parsed and with
-- list of SqlValues that it could not parse.
--
-- The 'DB.WhyNot.kRun1OrThrowWhyNot' throws first exception on the
-- list.
--
-- We have a theorem to use in this transformation:
--
-- > EXISTS (SELECT t1 WHERE cond1 AND EXISTS (SELECT t2 WHERE cond2))
--
-- is equivalent to
--
-- > EXISTS (SELECT t1, t2 WHERE cond1 AND cond2)
--
-- and it can be used recursivelly.
sqlTurnIntoWhyNotSelect :: (SqlTurnIntoSelect a) => a -> SqlSelect
sqlTurnIntoWhyNotSelect command =
    sqlSelect "" . sqlResult $ mconcat [
        "ARRAY["
      , mintercalate ", " $ map emitExists [0..(count-1)]
      , "]::boolean[]"
      ]
    where select = sqlTurnIntoSelect command
          count :: Int
          count = sum (map count' (sqlSelectWhere select))
          count' (SqlPlainCondition {}) = 1
          count' (SqlExistsCondition select') = sum (map count' (sqlSelectWhere select'))

          emitExists :: Int -> SQL
          emitExists current =
            case runState (run current select) 0 of
              (s, _) -> if null (sqlSelectWhere s)
                        then "TRUE"
                        else "EXISTS (" <> (toSQLCommand $ s { sqlSelectResult = [ "TRUE" ]}) <> ")"

          run :: (MonadState Int m) => Int -> SqlSelect -> m SqlSelect
          run current select' = do
            new <- mapM (around current) (sqlSelectWhere select')
            return (select' { sqlSelectWhere = concat new })

          around :: (MonadState Int m) => Int -> SqlCondition -> m [SqlCondition]
          around current cond@(SqlPlainCondition{}) = do
            index <- get
            modify (+1)
            if current >= index
              then return [cond]
              else return []
          around current (SqlExistsCondition subSelect) = do
            subSelect' <- run current subSelect
            return [SqlExistsCondition subSelect']


instance SqlTurnIntoSelect SqlUpdate where
  sqlTurnIntoSelect s = SqlSelect
                        { sqlSelectFrom    = sqlUpdateWhat s <>
                                             if isSqlEmpty (sqlUpdateFrom s)
                                             then ""
                                             else "," <+> sqlUpdateFrom s
                        , sqlSelectDistinct = False
                        , sqlSelectResult  = if null (sqlUpdateResult s)
                                             then ["TRUE"]
                                             else sqlUpdateResult s
                        , sqlSelectWhere   = sqlUpdateWhere s
                        , sqlSelectOrderBy = []
                        , sqlSelectGroupBy = []
                        , sqlSelectHaving  = []
                        , sqlSelectOffset  = 0
                        , sqlSelectLimit   = -1
                        , sqlSelectWith    = sqlUpdateWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE
                        }

instance SqlTurnIntoSelect SqlDelete where
  sqlTurnIntoSelect s = SqlSelect
                        { sqlSelectFrom    = sqlDeleteFrom s <>
                                             if isSqlEmpty (sqlDeleteUsing s)
                                             then ""
                                             else "," <+> sqlDeleteUsing s
                        , sqlSelectDistinct = False
                        , sqlSelectResult  = if null (sqlDeleteResult s)
                                             then ["TRUE"]
                                             else sqlDeleteResult s
                        , sqlSelectWhere   = sqlDeleteWhere s
                        , sqlSelectOrderBy = []
                        , sqlSelectGroupBy = []
                        , sqlSelectHaving  = []
                        , sqlSelectOffset  = 0
                        , sqlSelectLimit   = -1
                        , sqlSelectWith    = sqlDeleteWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE
                        }

instance SqlTurnIntoSelect SqlInsertSelect where
  sqlTurnIntoSelect s = SqlSelect
                        { sqlSelectFrom    = sqlInsertSelectFrom s
                        , sqlSelectDistinct = False
                        , sqlSelectResult  = sqlInsertSelectResult s
                        , sqlSelectWhere   = sqlInsertSelectWhere s
                        , sqlSelectOrderBy = sqlInsertSelectOrderBy s
                        , sqlSelectGroupBy = sqlInsertSelectGroupBy s
                        , sqlSelectHaving  = sqlInsertSelectHaving s
                        , sqlSelectOffset  = sqlInsertSelectOffset s
                        , sqlSelectLimit   = sqlInsertSelectLimit s
                        , sqlSelectWith    = sqlInsertSelectWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE
                        }
{-
data DBExceptionCouldNotParseValues = DBExceptionCouldNotParseValues TypeRep ConvertError [SqlValue]
  deriving (Eq, Show, Typeable)

instance DBExtraException DBExceptionCouldNotParseValues

instance JSON.ToJSValue DBExceptionCouldNotParseValues where
  toJSValue _ = JSON.runJSONGen $ do
                JSON.value "message" "DBExceptionCouldNotParseValues"
                JSON.value "http_status" (500::Int)
                -}
data DBBaseLineConditionIsFalse = DBBaseLineConditionIsFalse SQL
  deriving (Show, Typeable)

instance DBExtraException DBBaseLineConditionIsFalse

--
-- It it quite tempting to put the offending SQL as text in the JSON
-- that we produce.  This would aid debugging greatly, but could
-- possibly also reveal too much information to a potential attacker.
instance JSON.ToJSValue DBBaseLineConditionIsFalse where
  toJSValue _sql = JSON.runJSONGen $ do
                     JSON.value "message" ("DBBaseLineConditionIsFalse"::String)

{- Warning: use kWhyNot1 for now as kWhyNot does not work in expected way.

kWhyNot should return a list of rows, where each row is a list of
exceptions.  Right now we are not able to differentiate between rows
because we do not support a concept of a row identity. kWhyNot can
return rows in any order, returns empty rows for successful hits, does
not return a row if baseline conditions weren't met. This effectivelly
renders it useless.

kWhyNot will be resurrected when we get a row identity concept.

-}

{-
-- | If 'kWhyNot1' returns an empty list of exceptions when none of
-- @EXISTS@ clauses generated by 'sqlTurnIntoWhyNotSelect' was
-- @FALSE@. Should not happen in real life, file a bug report if you see
-- such a case.
kWhyNot :: (SqlTurnIntoSelect s, MonadDB m) => s -> m [[SomeDBExtraException]]
kWhyNot cmd = do
  let newSelect = sqlTurnIntoWhyNotSelect cmd
  if null (sqlSelectResult newSelect)
     then return [[]]
     else do
       kRun_ newSelect
       kFold2 (decodeListOfExceptionsFromWhere (sqlGetWhereConditions cmd)) []
-}


-- | 'DBExtraException' and 'SomeDBExtraException' mimic 'Exception' and
-- 'SomeException', but we need our own class and data type to limit its
-- use to only those which describe semantic exceptions.
--
-- Our data types also feature conversion to JSON type so that
-- external representation is known in place where exception is
-- defined.
class (Show e, Typeable e, JSON.ToJSValue e) => DBExtraException e where
  toDBExtraException :: e -> SomeDBExtraException
  toDBExtraException = SomeDBExtraException
  fromDBExtraException :: SomeDBExtraException -> Maybe e
  fromDBExtraException (SomeDBExtraException e) = cast e

catchDBExtraException :: (MonadBaseControl IO m, DBExtraException e) => m a -> (e -> m a) -> m a
catchDBExtraException m f = m `E.catch` (\e -> case fromDBExtraException e of
                                         Just ke -> f ke
                                         Nothing -> throw e)


data SomeDBExtraException = forall e. (Show e, DBExtraException e) => SomeDBExtraException e
  deriving Typeable

deriving instance Show SomeDBExtraException

instance Exception SomeDBExtraException where
  toException = SomeException
  fromException (SomeException e) = msum [ cast e
                                         , do
                                              DBException {dbeError = e'} <- cast e
                                              cast e'
                                         ]

{-
instance Show SomeDBExtraException where
  show (SomeDBExtraException e) = show e
-}

data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeDBExtraException)

data DBKwhyNotInternalError = DBKwhyNotInternalError String
  deriving (Show, Typeable)

instance DBExtraException DBKwhyNotInternalError

instance JSON.ToJSValue DBKwhyNotInternalError where
  toJSValue (DBKwhyNotInternalError msg) = JSON.runJSONGen $
    JSON.value "message"
    ("Internal error in Database.PostgreSQL.PQTypes.SQL.Builder.kWhyNot1Ex: "
     ++ msg)

kWhyNot1Ex :: forall m s. (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
           => s -> m (Bool, SomeDBExtraException)
kWhyNot1Ex cmd = do
  let newSelect = sqlTurnIntoSelect cmd
      newWhyNotSelect = sqlTurnIntoWhyNotSelect newSelect
  let findFirstFalse :: Identity (Array1 Bool) -> Int
      findFirstFalse (Identity (Array1 row)) = fromMaybe 0 (findIndex (== False) row)
  runQuery_ (newWhyNotSelect { sqlSelectLimit = 1 })
  indexOfFirstFailedCondition <- fetchOne findFirstFalse

  let logics = enumerateWhyNotExceptions ((sqlSelectFrom newSelect),[]) (sqlGetWhereConditions newSelect)

  let mcondition = logics `atMay` indexOfFirstFailedCondition

  case mcondition of
    Nothing -> return
      (True, toDBExtraException . DBKwhyNotInternalError $
        "list of failed conditions is empty")
    Just (important, ExceptionMaker exception, _from, []) ->
      return (important, exception $ error "this argument should've been ignored")
    Just (important, ExceptionMaker exception, (from, conds), sqls) -> do
       let statement' = sqlSelect2 from $ do
             mapM_ sqlResult sqls
             sqlLimit (1::Int)
             sqlOffset (0::Int)
           statement = statement' { sqlSelectWhere = conds }
       --Log.debug $ "Explanation SQL:\n" ++ show statement
       runQuery_ statement
       result <- fetchOne exception
       return (important, result)

-- | Function 'kWhyNot1' is a workhorse for explainable SQL
-- failures. SQL fails if it did not affect any rows or did not return
-- any rows.  When that happens 'kWhyNot1' should be called. 'kWhyNot1'
-- returns an exception describing why a row could not be
-- returned or affected by a query.
kWhyNot1 :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
         => s -> m SomeDBExtraException
kWhyNot1 cmd = snd `fmap` kWhyNot1Ex cmd

enumerateWhyNotExceptions :: (SQL, [SqlCondition])
                          -> [SqlCondition]
                          -> [( Bool
                              , ExceptionMaker
                              , (SQL, [SqlCondition])
                              , [SQL]
                              )]
enumerateWhyNotExceptions (from,condsUpTillNow) conds = concatMap worker (zip conds (inits conds))
  where
    worker (SqlPlainCondition _ (SqlWhyNot b f s), condsUpTillNow2) =
      [(b, ExceptionMaker (SomeDBExtraException . f), (from, condsUpTillNow ++ condsUpTillNow2), s)]
    worker (SqlExistsCondition s, condsUpTillNow2) =
      enumerateWhyNotExceptions (newFrom, condsUpTillNow ++ condsUpTillNow2)
                                  (sqlGetWhereConditions s)
      where
        newFrom = if isSqlEmpty from
                  then sqlSelectFrom s
                  else if isSqlEmpty (sqlSelectFrom s)
                       then from
                       else from <> ", " <> sqlSelectFrom s


kRunManyOrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
                   => s -> m ()
kRunManyOrThrowWhyNot sqlable = do
  success <- runQuery $ toSQLCommand sqlable
  when (success == 0) $ do
    exception <- kWhyNot1 sqlable
    throwDB exception


kRun1OrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
                   => s -> m ()
kRun1OrThrowWhyNot sqlable = do
  success <- runQuery01 $ toSQLCommand sqlable
  when (not success) $ do
    exception <- kWhyNot1 sqlable
    throwDB exception


kRun1OrThrowWhyNotAllowIgnore :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
                                => s -> m ()
kRun1OrThrowWhyNotAllowIgnore sqlable = do
  success <- runQuery01 $ toSQLCommand sqlable
  when (not success) $ do
    (important, exception) <- kWhyNot1Ex sqlable
    when (important) $
      throwDB exception

kRunAndFetch1OrThrowWhyNot :: (IsSQL s, FromRow row, MonadDB m, MonadThrow m, SqlTurnIntoSelect s)
                           => (row -> a) -> s -> m a
kRunAndFetch1OrThrowWhyNot decoder sqlcommand = do
  runQuery_ sqlcommand
  results <- fetchMany decoder
  case results of
    [] -> do
      exception <- kWhyNot1 sqlcommand
      throwDB exception
    [r] -> return r
    _ -> throwDB AffectedRowsMismatch {
      rowsExpected = [(1, 1)]
    , rowsDelivered = length results
    }