module Database.Groundhog.Generic.Sql
(
renderCond
, defaultShowPrim
, renderOrders
, renderUpdates
, renderFields
, renderChain
, renderExpr
, renderExprPriority
, renderExprExtended
, renderPersistValue
, mkExprWithConf
, prerenderExpr
, intercalateS
, commasJoin
, flatten
, RenderS(..)
, Utf8(..)
, RenderConfig(..)
, fromUtf8
, StringLike(..)
, fromString
, (<>)
, function
, operator
, parens
, mkExpr
, Snippet(..)
, SqlDb(..)
, FloatingSqlDb(..)
, tableName
, mainTableName
) where
import Database.Groundhog.Core
import Database.Groundhog.Generic (isSimple)
import Database.Groundhog.Instances ()
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import Data.Maybe (mapMaybe, maybeToList)
import Data.Monoid
import Data.String
import Database.Groundhog.Expression
class (Monoid a, IsString a) => StringLike a where
fromChar :: Char -> a
data RenderS db r = RenderS {
getQuery :: Utf8
, getValues :: [PersistValue] -> [PersistValue]
}
instance Monoid Utf8 where
mempty = Utf8 mempty
mappend (Utf8 a) (Utf8 b) = Utf8 (mappend a b)
instance IsString Utf8 where
fromString = Utf8 . B.fromString
instance StringLike Utf8 where
fromChar = Utf8 . B.fromChar
newtype Snippet db r = Snippet (RenderConfig -> Int -> [RenderS db r])
newtype RenderConfig = RenderConfig {
esc :: Utf8 -> Utf8
}
class (DbDescriptor db, QueryRaw db ~ Snippet db) => SqlDb db where
append :: (ExpressionOf db r a String, ExpressionOf db r b String) => a -> b -> Expr db r String
signum' :: (ExpressionOf db r x a, Num a) => x -> Expr db r a
quotRem' :: (ExpressionOf db r x a, ExpressionOf db r y a, Integral a) => x -> y -> (Expr db r a, Expr db r a)
equalsOperator :: RenderS db r -> RenderS db r -> RenderS db r
notEqualsOperator :: RenderS db r -> RenderS db r -> RenderS db r
class SqlDb db => FloatingSqlDb db where
log' :: (ExpressionOf db r x a, Floating a) => x -> Expr db r a
logBase' :: (ExpressionOf db r b a, ExpressionOf db r x a, Floating a) => b -> x -> Expr db r a
prerenderExpr :: SqlDb db => RenderConfig -> Expr db r a -> Expr db r a
prerenderExpr conf (Expr e) = Expr $ ExprRaw $ Snippet $ \_ _ -> prerendered where
prerendered = renderExprExtended conf maxBound e
mkExprWithConf :: (SqlDb db, PersistField a) => (RenderConfig -> Int -> Expr db r a) -> Expr db r a
mkExprWithConf f = expr where
expr = mkExpr $ Snippet $ \conf p -> [renderExprPriority conf p $ toExpr $ (f conf p) `asTypeOf` expr]
renderExpr :: SqlDb db => RenderConfig -> UntypedExpr db r -> RenderS db r
renderExpr conf expr = renderExprPriority conf 0 expr
renderExprPriority :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority conf p expr = (case expr of
ExprRaw (Snippet f) -> let vals = f conf p in ensureOne vals id
ExprField f -> let fs = renderChain conf f []
in ensureOne fs $ \f' -> RenderS f' id
ExprPure a -> let vals = toPurePersistValues proxy a
in ensureOne (vals []) renderPersistValue
ExprCond a -> case renderCondPriority conf p a of
Nothing -> error "renderExprPriority: empty condition"
Just x -> x) where
proxy = (undefined :: f db r -> proxy db) expr
ensureOne :: [a] -> (a -> b) -> b
ensureOne xs f = case xs of
[x] -> f x
xs' -> error $ "renderExprPriority: expected one column field, found " ++ show (length xs')
renderExprExtended :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended conf p expr = (case expr of
ExprRaw (Snippet f) -> f conf p
ExprField f -> map (flip RenderS id) $ renderChain conf f []
ExprPure a -> let vals = toPurePersistValues proxy a []
in map renderPersistValue vals
ExprCond a -> maybeToList $ renderCondPriority conf p a) where
proxy = (undefined :: f db r -> proxy db) expr
renderPersistValue :: PersistValue -> RenderS db r
renderPersistValue (PersistCustom s as) = RenderS s (as++)
renderPersistValue a = RenderS (fromChar '?') (a:)
instance Monoid (RenderS db r) where
mempty = RenderS mempty id
(RenderS f1 g1) `mappend` (RenderS f2 g2) = RenderS (f1 `mappend` f2) (g1 . g2)
instance IsString (RenderS db r) where
fromString s = RenderS (fromString s) id
instance StringLike (RenderS db r) where
fromChar c = RenderS (fromChar c) id
instance StringLike String where
fromChar c = [c]
parens :: Int -> Int -> RenderS db r -> RenderS db r
parens p1 p2 expr = if p1 < p2 then fromChar '(' <> expr <> fromChar ')' else expr
operator :: (SqlDb db, Expression db r a, Expression db r b) => Int -> String -> a -> b -> Snippet db r
operator pr op = \a b -> Snippet $ \conf p ->
[parens pr p $ renderExprPriority conf pr (toExpr a) <> fromString op <> renderExprPriority conf pr (toExpr b)]
function :: SqlDb db => String -> [UntypedExpr db r] -> Snippet db r
function func args = Snippet $ \conf _ -> [fromString func <> fromChar '(' <> commasJoin (map (renderExpr conf) args) <> fromChar ')']
mkExpr :: SqlDb db => Snippet db r -> Expr db r a
mkExpr = Expr . ExprRaw
#if !MIN_VERSION_base(4, 5, 0)
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif
renderCond :: SqlDb db
=> RenderConfig
-> Cond db r -> Maybe (RenderS db r)
renderCond conf cond = renderCondPriority conf 0 cond where
renderCondPriority :: SqlDb db
=> RenderConfig
-> Int -> Cond db r -> Maybe (RenderS db r)
renderCondPriority conf@RenderConfig{..} priority cond = go cond priority where
go (And a b) p = perhaps andP p " AND " a b
go (Or a b) p = perhaps orP p " OR " a b
go (Not CondEmpty) _ = Just "(1=0)"
go (Not a) p = fmap (\a' -> parens notP p $ "NOT " <> a') $ go a notP
go (Compare compOp f1 f2) p = (case compOp of
Eq -> renderComp andP " AND " 37 equalsOperator f1 f2
Ne -> renderComp orP " OR " 50 notEqualsOperator f1 f2
Gt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '>' <> b) f1 f2
Lt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '<' <> b) f1 f2
Ge -> renderComp orP " OR " 38 (\a b -> a <> ">=" <> b) f1 f2
Le -> renderComp orP " OR " 38 (\a b -> a <> "<=" <> b) f1 f2) where
renderComp interP interOp opP op expr1 expr2 = result where
expr1' = renderExprExtended conf opP expr1
expr2' = renderExprExtended conf opP expr2
result = case zipWith op expr1' expr2' of
[] -> Nothing
[clause] -> Just $ parens (opP 1) p clause
clauses -> Just $ parens interP p $ intercalateS interOp clauses
go (CondRaw (Snippet f)) p = case f conf p of
[] -> Nothing
[a] -> Just a
_ -> error "renderCond: cannot render CondRaw with many elements"
go CondEmpty _ = Nothing
notP = 35
andP = 30
orP = 20
perhaps p pOuter op a b = result where
(p', result) = case (go a p', go b p') of
(Just a', Just b') -> (p, Just $ parens p pOuter $ a' <> RenderS op id <> b')
(Just a', Nothing) -> (pOuter, Just a')
(Nothing, Just b') -> (pOuter, Just b')
(Nothing, Nothing) -> (pOuter, Nothing)
renderChain :: RenderConfig -> FieldChain -> [Utf8] -> [Utf8]
renderChain RenderConfig{..} (f, prefix) acc = (case prefix of
((name, EmbeddedDef False _):fs) -> flattenP esc (goP (fromString name) fs) f acc
_ -> flatten esc f acc) where
goP p ((name, EmbeddedDef False _):fs) = goP (fromString name <> fromChar delim <> p) fs
goP p _ = p
defaultShowPrim :: PersistValue -> String
defaultShowPrim (PersistString x) = "'" ++ x ++ "'"
defaultShowPrim (PersistByteString x) = "'" ++ show x ++ "'"
defaultShowPrim (PersistInt64 x) = show x
defaultShowPrim (PersistDouble x) = show x
defaultShowPrim (PersistBool x) = if x then "1" else "0"
defaultShowPrim (PersistDay x) = show x
defaultShowPrim (PersistTimeOfDay x) = show x
defaultShowPrim (PersistUTCTime x) = show x
defaultShowPrim (PersistZonedTime x) = show x
defaultShowPrim (PersistNull) = "NULL"
defaultShowPrim (PersistCustom _ _) = error "Unexpected PersistCustom"
renderOrders :: SqlDb db => RenderConfig -> [Order db r] -> RenderS db r
renderOrders _ [] = mempty
renderOrders conf xs = if null orders then mempty else " ORDER BY " <> commasJoin orders where
orders = concatMap go xs
rend conf' a = map (commasJoin . renderExprExtended conf' 0) $ projectionExprs a []
go (Asc a) = rend conf a
go (Desc a) = rend conf' a where
conf' = conf { esc = \f -> esc conf f <> " DESC" }
renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s
renderFields escape = commasJoin . foldr (flatten escape) []
flatten :: StringLike s => (s -> s) -> (String, DbType) -> ([s] -> [s])
flatten escape (fname, typ) acc = go typ where
go typ' = case typ' of
DbEmbedded emb _ -> handleEmb emb
_ -> escape fullName : acc
fullName = fromString fname
handleEmb (EmbeddedDef False ts) = foldr (flattenP escape fullName) acc ts
handleEmb (EmbeddedDef True ts) = foldr (flatten escape) acc ts
flattenP :: StringLike s => (s -> s) -> s -> (String, DbType) -> ([s] -> [s])
flattenP escape prefix (fname, typ) acc = go typ where
go typ' = case typ' of
DbEmbedded emb _ -> handleEmb emb
_ -> escape fullName : acc
fullName = prefix <> fromChar delim <> fromString fname
handleEmb (EmbeddedDef False ts) = foldr (flattenP escape fullName) acc ts
handleEmb (EmbeddedDef True ts) = foldr (flatten escape) acc ts
commasJoin :: StringLike s => [s] -> s
commasJoin = intercalateS (fromChar ',')
intercalateS :: StringLike s => s -> [s] -> s
intercalateS _ [] = mempty
intercalateS a (x:xs) = x <> go xs where
go [] = mempty
go (f:fs) = a <> f <> go fs
renderUpdates :: SqlDb db => RenderConfig -> [Update db r] -> Maybe (RenderS db r)
renderUpdates conf upds = (case mapMaybe go upds of
[] -> Nothing
xs -> Just $ commasJoin xs) where
go (Update field expr) = guard $ commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs (rend expr) where
rend = renderExprExtended conf 0
fs = concatMap rend (projectionExprs field [])
guard a = if null fs then Nothing else Just a
tableName :: StringLike s => (s -> s) -> EntityDef -> ConstructorDef -> s
tableName esc e c = qualifySchema esc e tName where
tName = esc $ if isSimple (constructors e)
then fromString $ entityName e
else fromString (entityName e) <> fromChar delim <> fromString (constrName c)
mainTableName :: StringLike s => (s -> s) -> EntityDef -> s
mainTableName esc e = qualifySchema esc e tName where
tName = esc $ fromString $ entityName e
qualifySchema :: StringLike s => (s -> s) -> EntityDef -> s -> s
qualifySchema esc e name = maybe name (\sch -> esc (fromString sch) <> fromChar '.' <> name) $ entitySchema e