167 lines
6.4 KiB
Haskell
167 lines
6.4 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Database.Esqueleto.Utils
|
|
( true, false
|
|
, isJust
|
|
, isInfixOf, hasInfix
|
|
, any, all
|
|
, SqlIn(..)
|
|
, mkExactFilter, mkExactFilterWith
|
|
, mkContainsFilter, mkContainsFilterWith
|
|
, mkExistsFilter
|
|
, anyFilter, allFilter
|
|
, orderByOrd, orderByEnum
|
|
) where
|
|
|
|
|
|
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, isJust)
|
|
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 Database.Esqueleto.Utils.TH
|
|
|
|
|
|
--
|
|
-- 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
|
|
|
|
-- | Negation of `isNothing` which is missing
|
|
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
|
|
isJust = E.not_ . E.isNothing
|
|
|
|
-- | Check if the first string is contained in the text derived from the second argument
|
|
isInfixOf :: ( E.Esqueleto query expr backend
|
|
, E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool)
|
|
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
|
|
|
|
hasInfix :: ( E.Esqueleto query expr backend
|
|
, E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
|
|
hasInfix = flip isInfixOf
|
|
|
|
-- | 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 :: Foldable f =>
|
|
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
|
|
any test = F.foldr (\needle acc -> acc E.||. test needle) false
|
|
|
|
-- | 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 :: Foldable f =>
|
|
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
|
|
all test = F.foldr (\needle acc -> acc E.&&. test needle) true
|
|
|
|
|
|
-- 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) criterias
|
|
|
|
-- | Combine several filters, using logical or
|
|
anyFilter :: (Foldable f)
|
|
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
|
-> t
|
|
-> Set.Set Text
|
|
-> 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 -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
|
-> t
|
|
-> Set.Set Text
|
|
-> E.SqlExpr (E.Value Bool)
|
|
allFilter fltrs needle criterias = F.foldr aux true fltrs
|
|
where
|
|
aux fltr acc = fltr needle criterias E.&&. acc
|
|
|
|
|
|
orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
|
orderByOrd = let sortUni = zipWith (,) [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism
|
|
\x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1))
|
|
|
|
orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
|
orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1)) |