{-# 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
  , SqlProject(..)
  , (->.)
  , fromSqlKey
  , selectCountRows
  , selectMaybe
  , module Database.Esqueleto.Utils.TH
  ) where


import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min)
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

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)