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

module Database.Esqueleto.Utils
  ( true, false
  , justVal, justValList
  , isJust
  , isInfixOf, hasInfix
  , or, and
  , any, all
  , mkExactFilter, mkExactFilterWith
  , mkContainsFilter, mkContainsFilterWith
  , mkExistsFilter
  , anyFilter, allFilter
  , orderByList
  , orderByOrd, orderByEnum
  , strip, lower, ciEq
  , selectExists, selectNotExists
  , SqlHashable
  , sha256
  , maybe, maybeEq, unsafeCoalesce
  , bool
  , max, min
  , abs
  , SqlProject(..)
  , (->.)
  , fromSqlKey
  , selectCountRows
  , selectMaybe
  , day, diffDays
  , 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.Internal.Sql 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)

{-# 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

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

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


-- 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)

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) => 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'

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

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

infixl 8 ->.

(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
(->.) 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


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