module Database.Esqueleto.Internal.Sql
(
SqlQuery
, SqlExpr
, SqlEntity
, select
, selectSource
, selectDistinct
, selectDistinctSource
, delete
, deleteCount
, update
, updateCount
, unsafeSqlBinOp
, unsafeSqlValue
, unsafeSqlFunction
, UnsafeSqlFunctionArgument
, rawSelectSource
, runSource
, rawEsqueleto
, 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 Data.Proxy (Proxy(..))
import Database.Esqueleto.Internal.PersistentImport
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 SqlType)
| 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)))) -> Proxy a
getVal = const Proxy
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 . connEscapeName 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
-> SqlPersistT m (C.Source (C.ResourceT (SqlPersistT m)) r)
rawSelectSource mode query = src
where
src = do
conn <- SqlPersistT R.ask
return $ run conn C.$= massage
run conn =
uncurry rawQuery $
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
-> SqlPersistT m (C.Source (C.ResourceT (SqlPersistT m)) r)
selectSource = rawSelectSource SELECT
select :: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a -> SqlPersistT m [r]
select = selectSource >=> runSource
selectDistinctSource
:: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a
-> SqlPersistT m (C.Source (C.ResourceT (SqlPersistT m)) r)
selectDistinctSource = rawSelectSource SELECT_DISTINCT
selectDistinct :: ( SqlSelect a r
, MonadLogger m
, MonadResourceBase m )
=> SqlQuery a -> SqlPersistT m [r]
selectDistinct = selectDistinctSource >=> runSource
runSource :: MonadResourceBase m =>
C.Source (C.ResourceT (SqlPersistT m)) r
-> SqlPersistT m [r]
runSource src = C.runResourceT $ src C.$$ CL.consume
rawEsqueleto :: ( MonadLogger m
, MonadResourceBase m )
=> Mode
-> SqlQuery ()
-> SqlPersistT m Int64
rawEsqueleto mode query = do
conn <- SqlPersistT R.ask
uncurry rawExecuteCount $
first builderToText $
toRawSql mode conn query
delete :: ( MonadLogger m
, MonadResourceBase m )
=> SqlQuery ()
-> SqlPersistT m ()
delete = void . deleteCount
deleteCount :: ( MonadLogger m
, MonadResourceBase m )
=> SqlQuery ()
-> SqlPersistT m Int64
deleteCount = rawEsqueleto DELETE
update :: ( MonadLogger m
, MonadResourceBase m
, SqlEntity val )
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersistT m ()
update = void . updateCount
updateCount :: ( MonadLogger m
, MonadResourceBase m
, SqlEntity val )
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersistT m Int64
updateCount = rawEsqueleto 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 (connNoLimit 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 :: Proxy 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 $ return 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 :: Proxy (SqlExpr (Entity a)) -> Proxy a
getEntityVal = const Proxy
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where
sqlSelectCols conn (EMaybe ent) = sqlSelectCols conn ent
sqlSelectColCount = sqlSelectColCount . fromEMaybe
where
fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)
fromEMaybe = const Proxy
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 = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTuple
where
fromTuple :: Proxy (a,b) -> (Proxy a, Proxy b)
fromTuple = const (Proxy, Proxy)
sqlSelectProcessRow =
let x = getType processRow
getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a
getType = const Proxy
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 . from3P
sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow
from3P :: Proxy (a,b,c) -> Proxy ((a,b),c)
from3P = const Proxy
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 . from4P
sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow
from4P :: Proxy (a,b,c,d) -> Proxy ((a,b),(c,d))
from4P = const Proxy
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 . from5P
sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow
from5P :: Proxy (a,b,c,d,e) -> Proxy ((a,b),(c,d),e)
from5P = const Proxy
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 . from6P
sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow
from6P :: Proxy (a,b,c,d,e,f) -> Proxy ((a,b),(c,d),(e,f))
from6P = const Proxy
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 . from7P
sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow
from7P :: Proxy (a,b,c,d,e,f,g) -> Proxy ((a,b),(c,d),(e,f),g)
from7P = const Proxy
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 . from8P
sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow
from8P :: Proxy (a,b,c,d,e,f,g,h) -> Proxy ((a,b),(c,d),(e,f),(g,h))
from8P = const Proxy
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)
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 i ri
) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i) =
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
, sqlSelectCols esc i
]
sqlSelectColCount = sqlSelectColCount . from9P
sqlSelectProcessRow = fmap to9 . sqlSelectProcessRow
from9P :: Proxy (a,b,c,d,e,f,g,h,i) -> Proxy ((a,b),(c,d),(e,f),(g,h),i)
from9P = const Proxy
to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i)
to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i)
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 i ri
, SqlSelect j rj
) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
]
sqlSelectColCount = sqlSelectColCount . from10P
sqlSelectProcessRow = fmap to10 . sqlSelectProcessRow
from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j))
from10P = const Proxy
to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j)
to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j)
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 i ri
, SqlSelect j rj
, SqlSelect k rk
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
]
sqlSelectColCount = sqlSelectColCount . from11P
sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow
from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k)
from11P = const Proxy
to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k)
to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k)
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 i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
]
sqlSelectColCount = sqlSelectColCount . from12P
sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow
from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l))
from12P = const Proxy
to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l)
to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l)
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 i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
]
sqlSelectColCount = sqlSelectColCount . from13P
sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow
from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m)
from13P = const Proxy
to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m)
to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m)
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 i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
, SqlSelect n rn
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
, sqlSelectCols esc n
]
sqlSelectColCount = sqlSelectColCount . from14P
sqlSelectProcessRow = fmap to14 . sqlSelectProcessRow
from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n))
from14P = const Proxy
to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
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 i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
, SqlSelect n rn
, SqlSelect o ro
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
, sqlSelectCols esc n
, sqlSelectCols esc o
]
sqlSelectColCount = sqlSelectColCount . from15P
sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow
from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o)
from15P = const Proxy
to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
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 i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
, SqlSelect n rn
, SqlSelect o ro
, SqlSelect p rp
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
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
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
, sqlSelectCols esc n
, sqlSelectCols esc o
, sqlSelectCols esc p
]
sqlSelectColCount = sqlSelectColCount . from16P
sqlSelectProcessRow = fmap to16 . sqlSelectProcessRow
from16P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p))
from16P = const Proxy
to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)
to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)