module Database.Esqueleto.Internal.Sql
(
SqlQuery
, SqlExpr
, SqlEntity
, select
, selectSource
, selectDistinct
, selectDistinctSource
, delete
, deleteCount
, update
, updateCount
, unsafeSqlBinOp
, unsafeSqlValue
, unsafeSqlFunction
, UnsafeSqlFunctionArgument
, rawSelectSource
, runSource
, rawExecute
, toRawSql
, Mode(..)
, SqlSelect
, veryUnsafeCoerceSqlExprValue
) where
import Control.Applicative (Applicative(..), (<$>), (<$))
import Control.Arrow ((***), first)
import Control.Exception (throw, throwIO)
import Control.Monad ((>=>), ap, void, MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Resource (MonadResourceBase)
import Data.Int (Int64)
import Data.List (intersperse)
import Data.Monoid (Monoid(..), (<>))
import Database.Persist.EntityDef
import Database.Persist.GenericSql
import Database.Persist.GenericSql.Internal (Connection(escapeName, noLimit))
import Database.Persist.GenericSql.Raw (executeCount, SqlBackend, withStmt)
import Database.Persist.Store hiding (delete)
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State as S
import qualified Control.Monad.Trans.Writer as W
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Data.HashSet as HS
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLBI
import Database.Esqueleto.Internal.Language
newtype SqlQuery a =
Q { unQ :: W.WriterT SideData (S.State IdentState) a }
instance Functor SqlQuery where
fmap f = Q . fmap f . unQ
instance Monad SqlQuery where
return = Q . return
m >>= f = Q (unQ m >>= unQ . f)
instance Applicative SqlQuery where
pure = return
(<*>) = ap
type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend)
data SideData = SideData { sdFromClause :: ![FromClause]
, sdSetClause :: ![SetClause]
, sdWhereClause :: !WhereClause
, sdGroupByClause :: !GroupByClause
, sdOrderByClause :: ![OrderByClause]
, sdLimitClause :: !LimitClause
}
instance Monoid SideData where
mempty = SideData mempty mempty mempty mempty mempty mempty
SideData f s w o l g `mappend` SideData f' s' w' o' l' g' =
SideData (f <> f') (s <> s') (w <> w') (o <> o') (l <> l') (g <> g')
data FromClause =
FromStart Ident EntityDef
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
| OnClause (SqlExpr (Value Bool))
newtype SetClause = SetClause (SqlExpr (Value ()))
collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause]
collectOnClauses = go []
where
go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs)
go acc (OnClause expr :fs) = findMatching acc expr >>= flip go fs
go acc (f:fs) = go (f:acc) fs
go acc [] = return $ reverse acc
findMatching (f : acc) expr =
case tryMatch expr f of
Just f' -> return (f' : acc)
Nothing -> (f:) <$> findMatching acc expr
findMatching [] expr = Left expr
tryMatch expr (FromJoin l k r onClause) =
matchR `mplus` matchC `mplus` matchL
where
matchR = (\r' -> FromJoin l k r' onClause) <$> tryMatch expr r
matchL = (\l' -> FromJoin l' k r onClause) <$> tryMatch expr l
matchC = case onClause of
Nothing -> return (FromJoin l k r (Just expr))
Just _ -> mzero
tryMatch _ _ = mzero
data WhereClause = Where (SqlExpr (Value Bool))
| NoWhere
instance Monoid WhereClause where
mempty = NoWhere
NoWhere `mappend` w = w
w `mappend` NoWhere = w
Where e1 `mappend` Where e2 = Where (e1 &&. e2)
newtype GroupByClause = GroupBy [SomeValue SqlExpr]
instance Monoid GroupByClause where
mempty = GroupBy []
GroupBy fs `mappend` GroupBy fs' = GroupBy (fs <> fs')
type OrderByClause = SqlExpr OrderBy
data LimitClause = Limit (Maybe Int64) (Maybe Int64)
instance Monoid LimitClause where
mempty = Limit mzero mzero
Limit l1 o1 `mappend` Limit l2 o2 =
Limit (l2 `mplus` l1) (o2 `mplus` o1)
newtype Ident = I T.Text
newtype IdentState = IdentState { inUse :: HS.HashSet T.Text }
initialIdentState :: IdentState
initialIdentState = IdentState mempty
newIdentFor :: DBName -> SqlQuery Ident
newIdentFor = Q . lift . try . unDBName
where
try orig = do
s <- S.get
let go (t:ts) | t `HS.member` inUse s = go ts
| otherwise = use t
go [] = error "Esqueleto/Sql/newIdentFor: never here"
go (possibilities orig)
possibilities t = t : map addNum [2..]
where
addNum :: Int -> T.Text
addNum = T.append t . T.pack . show
use t = do
S.modify (\s -> s { inUse = HS.insert t (inUse s) })
return (I t)
useIdent :: Connection -> Ident -> TLB.Builder
useIdent conn (I ident) = fromDBName conn $ DBName ident
data SqlExpr a where
EEntity :: Ident -> SqlExpr (Entity val)
EMaybe :: SqlExpr a -> SqlExpr (Maybe a)
ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
EList :: SqlExpr (Value a) -> SqlExpr (ValueList a)
EEmptyList :: SqlExpr (ValueList a)
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)
data NeedParens = Parens | Never
parensM :: NeedParens -> TLB.Builder -> TLB.Builder
parensM Never = id
parensM Parens = parens
data OrderByType = ASC | DESC
instance Esqueleto SqlQuery SqlExpr SqlBackend where
fromStart = x
where
x = do
let ed = entityDef (getVal x)
ident <- newIdentFor (entityDB ed)
let ret = EEntity ident
from_ = FromStart ident ed
return (EPreprocessedFrom ret from_)
getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> a
getVal = error "Esqueleto/Sql/fromStart/getVal: never here"
fromStartMaybe = maybelize <$> fromStart
where
maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))
-> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))
maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_
fromJoin (EPreprocessedFrom lhsRet lhsFrom)
(EPreprocessedFrom rhsRet rhsFrom) = Q $ do
let ret = smartJoin lhsRet rhsRet
from_ = FromJoin lhsFrom
(reifyJoinKind ret)
rhsFrom
Nothing
return (EPreprocessedFrom ret from_)
fromFinish (EPreprocessedFrom ret from_) = Q $ do
W.tell mempty { sdFromClause = [from_] }
return ret
where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }
groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr }
orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }
asc = EOrderBy ASC
desc = EOrderBy DESC
limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }
offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) }
sub_select = sub SELECT
sub_selectDistinct = sub SELECT_DISTINCT
EEntity ident ^. field =
ERaw Never $ \conn -> (useIdent conn ident <> ("." <> fieldName conn field), [])
EMaybe r ?. field = maybelize (r ^. field)
where
maybelize :: SqlExpr (Value a) -> SqlExpr (Value (Maybe a))
maybelize (ERaw p f) = ERaw p f
val = ERaw Never . const . (,) "?" . return . toPersistValue
isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f
just (ERaw p f) = ERaw p f
nothing = unsafeSqlValue "NULL"
countRows = unsafeSqlValue "COUNT(*)"
count (ERaw _ f) = ERaw Never $ \conn -> let (b, vals) = f conn
in ("COUNT" <> parens b, vals)
not_ (ERaw p f) = ERaw Never $ \conn -> let (b, vals) = f conn
in ("NOT " <> parensM p b, vals)
(==.) = unsafeSqlBinOp " = "
(>=.) = unsafeSqlBinOp " >= "
(>.) = unsafeSqlBinOp " > "
(<=.) = unsafeSqlBinOp " <= "
(<.) = unsafeSqlBinOp " < "
(!=.) = unsafeSqlBinOp " != "
(&&.) = unsafeSqlBinOp " AND "
(||.) = unsafeSqlBinOp " OR "
(+.) = unsafeSqlBinOp " + "
(-.) = unsafeSqlBinOp " - "
(/.) = unsafeSqlBinOp " / "
(*.) = unsafeSqlBinOp " * "
like = unsafeSqlBinOp " LIKE "
(%) = unsafeSqlValue "'%'"
concat_ = unsafeSqlFunction "CONCAT"
(++.) = unsafeSqlBinOp " || "
subList_select = EList . sub_select
subList_selectDistinct = EList . sub_selectDistinct
valList [] = EEmptyList
valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals)
, map toPersistValue vals )
v `in_` e = ifNotEmptyList e False $ unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e)
v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e)
exists = unsafeSqlFunction "EXISTS " . existsHelper
notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper
set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds }
where
apply (ESet f) = SetClause (f ent)
field =. expr = setAux field (const expr)
field +=. expr = setAux field (\ent -> ent ^. field +. expr)
field -=. expr = setAux field (\ent -> ent ^. field -. expr)
field *=. expr = setAux field (\ent -> ent ^. field *. expr)
field /=. expr = setAux field (\ent -> ent ^. field /. expr)
instance ToSomeValues SqlExpr (SqlExpr (Value a)) where
toSomeValues a = [SomeValue a]
fieldName :: (PersistEntity val, PersistField typ)
=> Connection -> EntityField val typ -> TLB.Builder
fieldName conn = fromDBName conn . fieldDB . persistFieldDef
setAux :: (PersistEntity val, PersistField typ)
=> EntityField val typ
-> (SqlExpr (Entity val) -> SqlExpr (Value typ))
-> SqlExpr (Update val)
setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent)
where name = ERaw Never $ \conn -> (fieldName conn field, mempty)
sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
sub mode query = ERaw Parens $ \conn -> toRawSql mode conn query
fromDBName :: Connection -> DBName -> TLB.Builder
fromDBName conn = TLB.fromText . escapeName conn
existsHelper :: SqlQuery () -> SqlExpr (Value a)
existsHelper =
ERaw Parens .
flip (toRawSql SELECT) .
(>> return (val True :: SqlExpr (Value Bool)))
ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)
ifNotEmptyList EEmptyList b _ = val b
ifNotEmptyList (EList _) _ x = x
unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f
where
f conn = let (b1, vals1) = f1 conn
(b2, vals2) = f2 conn
in ( parensM p1 b1 <> op <> parensM p2 b2
, vals1 <> vals2 )
unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a)
unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty)
unsafeSqlFunction :: UnsafeSqlFunctionArgument a =>
TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction name arg =
ERaw Never $ \conn ->
let (argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f conn) $ toArgList arg
in (name <> parens argsTLB, argsVals)
class UnsafeSqlFunctionArgument a where
toArgList :: a -> [SqlExpr (Value ())]
instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where
toArgList = (:[]) . veryUnsafeCoerceSqlExprValue
instance UnsafeSqlFunctionArgument a =>
UnsafeSqlFunctionArgument [a] where
toArgList = concatMap toArgList
instance ( UnsafeSqlFunctionArgument a
, UnsafeSqlFunctionArgument b
) => UnsafeSqlFunctionArgument (a, b) where
toArgList (a, b) = toArgList a ++ toArgList b
instance ( UnsafeSqlFunctionArgument a
, UnsafeSqlFunctionArgument b
, UnsafeSqlFunctionArgument c
) => UnsafeSqlFunctionArgument (a, b, c) where
toArgList = toArgList . from3
instance ( UnsafeSqlFunctionArgument a
, UnsafeSqlFunctionArgument b
, UnsafeSqlFunctionArgument c
, UnsafeSqlFunctionArgument d
) => UnsafeSqlFunctionArgument (a, b, c, d) where
toArgList = toArgList . from4
veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b)
veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f
veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a)
veryUnsafeCoerceSqlExprValueList (EList v) = v
veryUnsafeCoerceSqlExprValueList EEmptyList =
error "veryUnsafeCoerceSqlExprValueList: empty list."
rawSelectSource :: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> Mode
-> SqlQuery a
-> SqlPersist m (C.Source (C.ResourceT (SqlPersist m)) r)
rawSelectSource mode query = src
where
src = do
conn <- SqlPersist R.ask
return $ run conn C.$= massage
run conn =
uncurry withStmt $
first builderToText $
toRawSql mode conn query
massage = do
mrow <- C.await
case process <$> mrow of
Just (Right r) -> C.yield r >> massage
Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err
Nothing -> return ()
process = sqlSelectProcessRow
selectSource :: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a
-> SqlPersist m (C.Source (C.ResourceT (SqlPersist m)) r)
selectSource = rawSelectSource SELECT
select :: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a -> SqlPersist m [r]
select = selectSource >=> runSource
selectDistinctSource
:: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a
-> SqlPersist m (C.Source (C.ResourceT (SqlPersist m)) r)
selectDistinctSource = rawSelectSource SELECT_DISTINCT
selectDistinct :: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a -> SqlPersist m [r]
selectDistinct = selectDistinctSource >=> runSource
runSource :: MonadResourceBase m =>
C.Source (C.ResourceT (SqlPersist m)) r
-> SqlPersist m [r]
runSource src = C.runResourceT $ src C.$$ CL.consume
rawExecute :: ( MonadLogger m
, MonadResourceBase m )
=> Mode
-> SqlQuery ()
-> SqlPersist m Int64
rawExecute mode query = do
conn <- SqlPersist R.ask
uncurry executeCount $
first builderToText $
toRawSql mode conn query
delete :: ( MonadLogger m
, MonadResourceBase m )
=> SqlQuery ()
-> SqlPersist m ()
delete = void . deleteCount
deleteCount :: ( MonadLogger m
, MonadResourceBase m )
=> SqlQuery ()
-> SqlPersist m Int64
deleteCount = rawExecute DELETE
update :: ( MonadLogger m
, MonadResourceBase m
, SqlEntity val )
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersist m ()
update = void . updateCount
updateCount :: ( MonadLogger m
, MonadResourceBase m
, SqlEntity val )
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersist m Int64
updateCount = rawExecute UPDATE . from
builderToText :: TLB.Builder -> T.Text
builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize
where
defaultChunkSize = 1024 32
toRawSql :: SqlSelect a r => Mode -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue])
toRawSql mode conn query =
let (ret, SideData fromClauses setClauses whereClauses groupByClause orderByClauses limitClause) =
flip S.evalState initialIdentState $
W.runWriterT $
unQ query
in mconcat
[ makeSelect conn mode ret
, makeFrom conn mode fromClauses
, makeSet conn setClauses
, makeWhere conn whereClauses
, makeGroupBy conn groupByClause
, makeOrderBy conn orderByClauses
, makeLimit conn limitClause
]
data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE
uncommas :: [TLB.Builder] -> TLB.Builder
uncommas = mconcat . intersperse ", "
uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
uncommas' = (uncommas *** mconcat) . unzip
makeSelect :: SqlSelect a r => Connection -> Mode -> a -> (TLB.Builder, [PersistValue])
makeSelect conn mode ret = first (s <>) (sqlSelectCols conn ret)
where
s = case mode of
SELECT -> "SELECT "
SELECT_DISTINCT -> "SELECT DISTINCT "
DELETE -> "DELETE"
UPDATE -> "UPDATE "
makeFrom :: Connection -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])
makeFrom _ _ [] = mempty
makeFrom conn mode fs = ret
where
ret = case collectOnClauses fs of
Left expr -> throw $ mkExc expr
Right fs' -> keyword $ uncommas' (map (mk Never mempty) fs')
keyword = case mode of
UPDATE -> id
_ -> first ("\nFROM " <>)
mk _ onClause (FromStart i def) = base i def <> onClause
mk paren onClause (FromJoin lhs kind rhs monClause) =
first (parensM paren) $
mconcat [ mk Parens onClause lhs
, (fromKind kind, mempty)
, mk Never (maybe mempty makeOnClause monClause) rhs
]
mk _ _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)"
base ident@(I identText) def =
let db@(DBName dbText) = entityDB def
in ( if dbText == identText
then fromDBName conn db
else fromDBName conn db <> (" AS " <> useIdent conn ident)
, mempty )
fromKind InnerJoinKind = " INNER JOIN "
fromKind CrossJoinKind = " CROSS JOIN "
fromKind LeftOuterJoinKind = " LEFT OUTER JOIN "
fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
fromKind FullOuterJoinKind = " FULL OUTER JOIN "
makeOnClause (ERaw _ f) = first (" ON " <>) (f conn)
mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
mkExc (ERaw _ f) =
OnClauseWithoutMatchingJoinException $
TL.unpack $ TLB.toLazyText $ fst (f conn)
makeSet :: Connection -> [SetClause] -> (TLB.Builder, [PersistValue])
makeSet _ [] = mempty
makeSet conn os = first ("\nSET " <>) $ uncommas' (map mk os)
where
mk (SetClause (ERaw _ f)) = f conn
makeWhere :: Connection -> WhereClause -> (TLB.Builder, [PersistValue])
makeWhere _ NoWhere = mempty
makeWhere conn (Where (ERaw _ f)) = first ("\nWHERE " <>) (f conn)
makeGroupBy :: Connection -> GroupByClause -> (TLB.Builder, [PersistValue])
makeGroupBy _ (GroupBy []) = (mempty, [])
makeGroupBy conn (GroupBy fields) = first ("\nGROUP BY " <>) build
where
build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f conn) fields
makeOrderBy :: Connection -> [OrderByClause] -> (TLB.Builder, [PersistValue])
makeOrderBy _ [] = mempty
makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
where
mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f conn)
orderByType ASC = " ASC"
orderByType DESC = " DESC"
makeLimit :: Connection -> LimitClause -> (TLB.Builder, [PersistValue])
makeLimit _ (Limit Nothing Nothing) = mempty
makeLimit _ (Limit Nothing (Just 0)) = mempty
makeLimit conn (Limit ml mo) = (ret, mempty)
where
ret = TLB.singleton '\n' <> (limitTLB <> offsetTLB)
limitTLB =
case ml of
Just l -> "LIMIT " <> TLBI.decimal l
Nothing -> TLB.fromText (noLimit conn)
offsetTLB =
case mo of
Just o -> " OFFSET " <> TLBI.decimal o
Nothing -> mempty
parens :: TLB.Builder -> TLB.Builder
parens b = "(" <> (b <> ")")
class SqlSelect a r | a -> r, r -> a where
sqlSelectCols :: Connection -> a -> (TLB.Builder, [PersistValue])
sqlSelectColCount :: a -> Int
sqlSelectProcessRow :: [PersistValue] -> Either T.Text r
instance SqlSelect () () where
sqlSelectCols _ _ = mempty
sqlSelectColCount _ = 0
sqlSelectProcessRow _ = Right ()
instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
sqlSelectCols conn expr@(EEntity ident) = ret
where
process ed = uncommas $
map ((name <>) . fromDBName conn) $
(entityID ed:) $
map fieldDB $
entityFields ed
name = useIdent conn ident <> "."
ret = let ed = entityDef $ getEntityVal expr
in (process ed, mempty)
sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal
sqlSelectProcessRow (idCol:ent) =
Entity <$> fromPersistValue idCol
<*> fromPersistValues ent
sqlSelectProcessRow _ = Left "SqlSelect (Entity a): wrong number of columns."
getEntityVal :: SqlExpr (Entity a) -> a
getEntityVal = error "Esqueleto/Sql/getEntityVal"
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where
sqlSelectCols conn (EMaybe ent) = sqlSelectCols conn ent
sqlSelectColCount = sqlSelectColCount . fromEMaybe
where
fromEMaybe :: SqlExpr (Maybe e) -> SqlExpr e
fromEMaybe = error "Esqueleto/Sql/sqlSelectColCount[Maybe Entity]/fromEMaybe"
sqlSelectProcessRow cols
| all (== PersistNull) cols = return Nothing
| otherwise = Just <$> sqlSelectProcessRow cols
instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc
in (parensM p b, vals)
sqlSelectColCount = const 1
sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns."
instance ( SqlSelect a ra
, SqlSelect b rb
) => SqlSelect (a, b) (ra, rb) where
sqlSelectCols esc (a, b) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
]
sqlSelectColCount ~(a,b) = sqlSelectColCount a + sqlSelectColCount b
sqlSelectProcessRow =
let x = getType processRow
getType :: SqlSelect a r => (z -> Either y (r,x)) -> a
getType = error "Esqueleto/SqlSelect[(a,b)]/sqlSelectProcessRow/getType"
colCountFst = sqlSelectColCount x
processRow row =
let (rowFst, rowSnd) = splitAt colCountFst row
in (,) <$> sqlSelectProcessRow rowFst
<*> sqlSelectProcessRow rowSnd
in colCountFst `seq` processRow
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
) => SqlSelect (a, b, c) (ra, rb, rc) where
sqlSelectCols esc (a, b, c) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
]
sqlSelectColCount = sqlSelectColCount . from3
sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow
from3 :: (a,b,c) -> ((a,b),c)
from3 (a,b,c) = ((a,b),c)
to3 :: ((a,b),c) -> (a,b,c)
to3 ((a,b),c) = (a,b,c)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where
sqlSelectCols esc (a, b, c, d) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
]
sqlSelectColCount = sqlSelectColCount . from4
sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow
from4 :: (a,b,c,d) -> ((a,b),(c,d))
from4 (a,b,c,d) = ((a,b),(c,d))
to4 :: ((a,b),(c,d)) -> (a,b,c,d)
to4 ((a,b),(c,d)) = (a,b,c,d)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where
sqlSelectCols esc (a, b, c, d, e) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
]
sqlSelectColCount = sqlSelectColCount . from5
sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow
from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e)
from5 (a,b,c,d,e) = ((a,b),(c,d),e)
to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)
to5 ((a,b),(c,d),e) = (a,b,c,d,e)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where
sqlSelectCols esc (a, b, c, d, e, f) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
]
sqlSelectColCount = sqlSelectColCount . from6
sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow
from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f))
from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f))
to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)
to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where
sqlSelectCols esc (a, b, c, d, e, f, g) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
]
sqlSelectColCount = sqlSelectColCount . from7
sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow
from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g)
from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g)
to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)
to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where
sqlSelectCols esc (a, b, c, d, e, f, g, h) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
]
sqlSelectColCount = sqlSelectColCount . from8
sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow
from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h))
from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h))
to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)
to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)