{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Database.Esqueleto.Utils
  ( true, false
  , justVal, justValList
  , isJust, alt
  , isInfixOf, hasInfix
  , strConcat, substring
  , or, and
  , any, all
  , subSelectAnd, subSelectOr
  , mkExactFilter, mkExactFilterWith
  , mkContainsFilter, mkContainsFilterWith
  , mkExistsFilter
  , anyFilter, allFilter
  , orderByList
  , orderByOrd, orderByEnum
  , strip, lower, ciEq
  , selectExists, selectNotExists
  , SqlHashable
  , sha256
  , maybe, maybe2, maybeEq, unsafeCoalesce
  , bool
  , max, min
  , abs
  , SqlProject(..)
  , (->.), (#>>.)
  , fromSqlKey
  , unKey
  , selectCountRows
  , selectMaybe
  , day, diffDays
  , exprLift
  , module Database.Esqueleto.Utils.TH
  ) where


import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min, abs)
import Data.Universe
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Foldable as F
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Internal.Internal as E
import Database.Esqueleto.Utils.TH

import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.ByteString.Lazy as Lazy (ByteString)

import Crypto.Hash (Digest, SHA256)

import Data.Coerce (Coercible)

{-# ANN any ("HLint: ignore Use any" :: String) #-}
{-# ANN all ("HLint: ignore Use all" :: String) #-}


{-# ANN any ("HLint: ignore Use any" :: String) #-}
{-# ANN all ("HLint: ignore Use all" :: String) #-}


--
-- Description : Convenience for using `Esqueleto`,
--               intended to be imported qualified
--               just like @Esqueleto@


-- ezero = E.val (0 :: Int64)

-- | Often needed with this concrete type
true :: E.SqlExpr (E.Value Bool)
true  = E.val True

-- | Often needed with this concrete type
false :: E.SqlExpr (E.Value Bool)
false = E.val False

justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
justVal = E.val . Just

justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
justValList = E.valList . map Just

-- | Negation of `isNothing` which is missing
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
isJust = E.not_ . E.isNothing

alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ))
alt a b = E.case_ [(isJust a, a), (isJust b, b)] b

infix 4 `isInfixOf`, `hasInfix`

-- | Check if the first string is contained in the text derived from the second argument
isInfixOf :: ( E.SqlString s1
             , E.SqlString s2
             )
          => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool)
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)

hasInfix :: ( E.SqlString s1
            , E.SqlString s2
            )
         => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool)
hasInfix = flip isInfixOf

infixl 6 `strConcat`

strConcat :: E.SqlString s
          => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
strConcat = E.unsafeSqlBinOp " || "

substring :: ( E.SqlString str
             , Num from, Num for
             )
          => E.SqlExpr (E.Value str)
          -> E.SqlExpr (E.Value from)
          -> E.SqlExpr (E.Value for)
          -> E.SqlExpr (E.Value str)
substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3)
  = E.ERaw E.Never $ \info ->
      let (strTLB, strVals) = f1 info
          (fromiTLB, fromiVals) = f2 info
          (foriTLB, foriVals) = f3 info
       in ( "SUBSTRING" <> E.parens (E.parensM p1 strTLB <> " FROM " <> E.parensM p2 fromiTLB <> " FOR " <> E.parensM p3 foriTLB)
          , strVals <> fromiVals <> foriVals
          )
substring a b c = substring (construct a) (construct b) (construct c)
    where construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
          construct (E.ERaw p f)        = E.ERaw E.Parens $ \info ->
            let (b1, vals) = f info
                build ("?", [E.PersistList vals']) =
                  (E.uncommas $ replicate (length vals') "?", vals')
                build expr = expr
             in  build (E.parensM p b1, vals)
          construct (E.ECompositeKey f) =
            E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty)
          construct (E.EAliasedValue i _) = 
            E.ERaw E.Never $ E.aliasedValueIdentToRawSql i
          construct (E.EValueReference i i') = 
            E.ERaw E.Never $ E.valueReferenceToRawSql i i'

and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
and = F.foldr (E.&&.) true
or = F.foldr (E.||.) false

-- | Given a test and a set of values, check whether anyone succeeds the test
--   WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)
any :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool)
any test = or . map test . otoList

-- | Given a test and a set of values, check whether all succeeds the test
--   WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated)
all :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool)
all test = and . map test . otoList

subSelectAnd, subSelectOr :: E.SqlQuery (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
subSelectAnd q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction "bool_and" E.AggModeAll) [] <$> q
subSelectOr  q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction "bool_or"  E.AggModeAll) [] <$> q

parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
parens = E.unsafeSqlFunction ""


-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
$(sqlInTuples [2..16])

-- | Example for usage of unValueN
_exampleUnValueN :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
_exampleUnValueN = $(unValueN 3)

-- | Example for usage of unValueNIs
_exampleUnValueNIs :: (E.Value a, b, E.Value c) -> (a,b,c)
_exampleUnValueNIs = $(unValueNIs 3 [1,3])

-- | Example for usage of sqlIJproj
_queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
_queryFeaturesDegree  = $(sqlIJproj 3 2)


-- | generic filter creation for dbTable
--   Given a lens-like function, make filter for exact matches in a collection
--   (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
mkExactFilter :: (PersistField a)
  => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
  -> t                             -- ^ query row
  -> Set.Set a                     -- ^ needle collection
  -> E.SqlExpr (E.Value Bool)
mkExactFilter = mkExactFilterWith id

-- | like `mkExactFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
mkExactFilterWith :: (PersistField b)
  => (a -> b)                      -- ^ type conversion
  -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
  -> t                             -- ^ query row
  -> Set.Set a                     -- ^ needle collection
  -> E.SqlExpr (E.Value Bool)
mkExactFilterWith cast lenslike row criterias
  | Set.null criterias = true
  | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)

-- | generic filter creation for dbTable
--   Given a lens-like function, make filter searching for needles in String-like elements
--   (Keep Set here to ensure that there are no duplicates)
mkContainsFilter :: E.SqlString a
                 => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
                 -> t                             -- ^ query row
                 -> Set.Set a                     -- ^ needle collection
                 -> E.SqlExpr (E.Value Bool)
mkContainsFilter = mkContainsFilterWith id

-- | like `mkContainsFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
mkContainsFilterWith :: E.SqlString b
                     => (a -> b)
                     -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
                     -> t                             -- ^ query row
                     -> Set.Set a                     -- ^ needle collection
                     -> E.SqlExpr (E.Value Bool)
mkContainsFilterWith cast lenslike row criterias
  | Set.null criterias = true
  | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)

mkExistsFilter :: PathPiece a
               => (t -> a -> E.SqlQuery ())
               -> t
               -> Set.Set a
               -> E.SqlExpr (E.Value Bool)
mkExistsFilter query row criterias
  | Set.null criterias = true
  | otherwise = any (E.exists . query row) $ Set.toList criterias

-- | Combine several filters, using logical or
anyFilter :: Foldable f
          => f (t -> cs -> E.SqlExpr (E.Value Bool))
          -> (t -> cs -> E.SqlExpr (E.Value Bool))
anyFilter fltrs needle criterias = F.foldr aux false fltrs
  where
    aux fltr acc = fltr needle criterias E.||. acc

-- | Combine several filters, using logical and
allFilter :: Foldable f
          => f (t -> cs -> E.SqlExpr (E.Value Bool))
          -> (t -> cs -> E.SqlExpr (E.Value Bool))
allFilter fltrs needle criterias = F.foldr aux true fltrs
  where
    aux fltr acc = fltr needle criterias E.&&. acc


orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByList vals
  = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
     in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)

orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByOrd = orderByList $ List.sort universeF

orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByEnum = orderByList $ List.sortOn fromEnum universeF


lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
lower = E.unsafeSqlFunction "LOWER"

strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
strip = E.unsafeSqlFunction "TRIM"

infix 4 `ciEq`

ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
ciEq a b = lower a E.==. lower b


selectExists, selectNotExists :: forall m a. MonadIO m => E.SqlQuery a -> E.SqlReadT m Bool
selectExists query = do
  res <- E.select . return . E.exists $ void query

  case res of
    [E.Value b] -> return b
    _other      -> error "SELECT EXISTS ... returned zero or more than one rows"
selectNotExists = fmap not . selectExists


class SqlHashable a
instance SqlHashable Text
instance SqlHashable ByteString
instance SqlHashable Lazy.Text
instance SqlHashable Lazy.ByteString


sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest SHA256))
sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))


maybe :: (PersistField a, PersistField b)
      => E.SqlExpr (E.Value b)
      -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
      -> E.SqlExpr (E.Value (Maybe a))
      -> E.SqlExpr (E.Value b)
maybe onNothing onJust val = E.case_
  [ E.when_
      (E.not_ $ E.isNothing val)
    E.then_
      (onJust $ E.veryUnsafeCoerceSqlExprValue val)
  ]
  (E.else_ onNothing)

maybe2 :: (PersistField a, PersistField b, PersistField c)
       => E.SqlExpr (E.Value c)
       -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -> E.SqlExpr (E.Value c))
       -> E.SqlExpr (E.Value (Maybe a))
       -> E.SqlExpr (E.Value (Maybe b))
       -> E.SqlExpr (E.Value c)
maybe2 onNothing onJust val1 val2 = E.case_
  [ E.when_
      (isJust val1 E.&&. isJust val2)
    E.then_
      (onJust (E.veryUnsafeCoerceSqlExprValue val1) (E.veryUnsafeCoerceSqlExprValue val2))
  ]
  (E.else_ onNothing)

infix 4 `maybeEq`

maybeEq :: PersistField a
        => E.SqlExpr (E.Value (Maybe a))
        -> E.SqlExpr (E.Value (Maybe a))
        -> E.SqlExpr (E.Value Bool)
-- ^ `E.==.` but treat `E.nothing` as identical
maybeEq a b = E.case_
  [ E.when_
      (E.isNothing a)
    E.then_
      (E.isNothing b)
  , E.when_
      (E.isNothing b)
    E.then_
      false -- (E.isNothing a)
  ]
  (E.else_ $ a E.==. b)

bool :: PersistField a
     => E.SqlExpr (E.Value a)
     -> E.SqlExpr (E.Value a)
     -> E.SqlExpr (E.Value Bool)
     -> E.SqlExpr (E.Value a)
bool onFalse onTrue val = E.case_
  [ E.when_
      val
    E.then_
      onTrue
  ]
  (E.else_ onFalse)

max, min :: PersistField a
         => E.SqlExpr (E.Value a)
         -> E.SqlExpr (E.Value a)
         -> E.SqlExpr (E.Value a)
max a b = bool a b $ b E.>. a
min a b = bool a b $ b E.<. a

abs :: (PersistField a, Num a)
    => E.SqlExpr (E.Value a)
    -> E.SqlExpr (E.Value a)
abs x = bool (E.val 0 E.-. x) x $ x E.>. E.val 0

unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a)
unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce


class (PersistEntity entity, PersistField value, PersistField value') => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
  sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
  unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
  unSqlProjectExpr :: forall p1 p2. p1 entity -> p2 entity' -> E.SqlExpr (E.Value value) -> E.SqlExpr (E.Value value')

instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
  sqlProject = (E.^.)
  unSqlProject _ _ = id
  unSqlProjectExpr _ _ = id

instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
  sqlProject = (E.?.)
  unSqlProject _ _ = Just
  unSqlProjectExpr _ _ = E.just

infixl 8 ->.

(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t

infixl 8 #>>.

(#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
(#>>.) expr t = E.unsafeSqlBinOp "#>>" expr $ E.val t


fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
fromSqlKey = E.veryUnsafeCoerceSqlExprValue
  
unKey :: ( Coercible (Key entity) a
         , PersistField (Key entity), PersistField a
         )
      => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
unKey = E.veryUnsafeCoerceSqlExprValue


selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
selectCountRows q = do
  res <- E.select $ E.countRows <$ q
  case res of
    [E.Value res']
      -> return res'
    _other
      -> error "E.countRows did not return exactly one result"

selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)


day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
day = E.unsafeSqlCastAs "date"

infixl 6 `diffDays`
  
diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
-- ^ PostgreSQL is weird.
diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b


class ExprLift e a | e -> a where
  exprLift :: a -> e

instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where
  exprLift = E.val

instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where
  exprLift f v = E.case_
    [ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v')
    | v' <- universeF
    ]
    (E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
  
instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where
  exprLift f v1 v2 = E.case_
    [ E.when_ (       v1 E.==. E.val v1'
                E.&&. v2 E.==. E.val v2'
              )
      E.then_ (E.val $ f v1' v2')
    | v1' <- universeF
    , v2' <- universeF
    ]
    (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
 
