diff --git a/Database/Groundhog/Core.hs b/Database/Groundhog/Core.hs --- a/Database/Groundhog/Core.hs +++ b/Database/Groundhog/Core.hs @@ -272,7 +272,7 @@ runDbPersist = runReaderT class PrimitivePersistField (AutoKeyType db) => DbDescriptor db where - -- | Type of the database default autoincremented key. For example, Sqlite has Int64 + -- | Type of the database default auto-incremented key. For example, Sqlite has Int64 type AutoKeyType db -- | Value of this type can be used as a part of a query. For example, it can be RenderS for relational databases, or BSON for MongoDB. type QueryRaw db :: * -> * @@ -519,7 +519,7 @@ -- | Used to uniformly represent fields, constants and more complex things, e.g., arithmetic expressions. -- A value should be converted to 'UntypedExpr' for usage in expressions data UntypedExpr db r where - ExprRaw :: QueryRaw db r -> UntypedExpr db r + ExprRaw :: DbType -> QueryRaw db r -> UntypedExpr db r ExprField :: FieldChain -> UntypedExpr db r ExprPure :: forall db r a . PurePersistField a => a -> UntypedExpr db r ExprCond :: Cond db r -> UntypedExpr db r diff --git a/Database/Groundhog/Generic.hs b/Database/Groundhog/Generic.hs --- a/Database/Groundhog/Generic.hs +++ b/Database/Groundhog/Generic.hs @@ -2,7 +2,7 @@ -- | This helper module is intended for use by the backend creators module Database.Groundhog.Generic - ( + ( -- * Migration createMigration , executeMigration diff --git a/Database/Groundhog/Generic/Sql.hs b/Database/Groundhog/Generic/Sql.hs --- a/Database/Groundhog/Generic/Sql.hs +++ b/Database/Groundhog/Generic/Sql.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, FlexibleInstances, TypeFamilies, RecordWildCards #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, FlexibleInstances, TypeFamilies, RecordWildCards, ScopedTypeVariables#-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module defines the functions which are used only for backends creation. module Database.Groundhog.Generic.Sql - ( + ( -- * SQL rendering utilities renderCond , defaultShowPrim @@ -100,8 +100,10 @@ logBase' :: (ExpressionOf db r b a, ExpressionOf db r x a, Floating a) => b -> x -> Expr db r a -- | If we reuse complex expression several times, prerendering it saves time. `RenderConfig` can be obtained with `mkExprWithConf` -prerenderExpr :: SqlDb db => RenderConfig -> Expr db r a -> Expr db r a -prerenderExpr conf (Expr e) = Expr $ ExprRaw $ Snippet $ \_ _ -> prerendered where +prerenderExpr :: forall db r a. (SqlDb db, PersistField a) => RenderConfig -> Expr db r a -> Expr db r a +prerenderExpr conf (Expr e) = Expr $ ExprRaw typ $ Snippet $ \_ _ -> prerendered where + proxy = undefined :: proxy db + typ = dbType proxy (undefined :: a) -- Priority of outer operation is not known. Assuming that it is high ensures that parentheses won't be missing. prerendered = renderExprExtended conf maxBound e @@ -120,22 +122,22 @@ 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 + ExprRaw _ (Snippet f) -> explicitHead (f conf p) ExprField f -> let fs = renderChain conf f [] - in ensureOne fs $ \f' -> RenderS f' id + in RenderS (explicitHead fs) id ExprPure a -> let vals = toPurePersistValues a - in ensureOne (vals []) renderPersistValue + in renderPersistValue $ explicitHead (vals []) ExprCond a -> case renderCondPriority conf p a of Nothing -> error "renderExprPriority: empty condition" Just x -> x) where - ensureOne :: [a] -> (a -> b) -> b - ensureOne xs f = case xs of - [x] -> f x + explicitHead :: [a] -> a + explicitHead xs = case xs of + [x] -> 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 + ExprRaw _ (Snippet f) -> f conf p ExprField f -> map (flip RenderS id) $ renderChain conf f [] ExprPure a -> let vals = toPurePersistValues a [] in map renderPersistValue vals @@ -175,8 +177,10 @@ 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 +mkExpr :: forall db r a . (SqlDb db, PersistField a) => Snippet db r -> Expr db r a +mkExpr snippet = Expr $ ExprRaw typ snippet where + proxy = undefined :: proxy db + typ = dbType proxy (undefined :: a) #if !MIN_VERSION_base(4, 5, 0) {-# INLINABLE (<>) #-} @@ -189,11 +193,19 @@ renderCond :: SqlDb db => RenderConfig -> Cond db r -> Maybe (RenderS db r) -renderCond conf cond = renderCondPriority conf 0 cond where +renderCond conf cond = renderCondPriority conf 0 cond +flattenNullables :: DbType -> [Bool] +flattenNullables typ = go typ [] where + go :: DbType -> [Bool] -> [Bool] + go typ acc = case typ of + DbEmbedded (EmbeddedDef _ ts) _ -> foldr go acc $ map snd ts + DbList _ _ -> False : acc + DbTypePrimitive _ nullable _ _ -> nullable : acc + {-# INLINABLE renderCondPriority #-} -- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns. -renderCondPriority :: SqlDb db +renderCondPriority :: forall db r . SqlDb db => RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r) renderCondPriority conf@RenderConfig{..} priority cond = go cond priority where @@ -202,25 +214,46 @@ go (Not CondEmpty) _ = Just "(1=0)" -- special case for False 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 + Eq -> renderCompOps andP " AND " 37 ops f1 f2 where + ops = map (\isNull -> if isNull then equalsOperator else (\a b -> a <> fromChar '=' <> b)) eitherNullable + Ne -> renderCompOps andP " OR " 50 ops f1 f2 where + ops = map (\isNull -> if isNull then notEqualsOperator else (\a b -> a <> "<>" <> b)) eitherNullable 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 + proxy = undefined :: proxy db + + eitherNullable = zipWith (||) (nullables f1) (nullables f2) + + nullables expr = case expr of + ExprRaw t _ -> flattenNullables t + ExprField ((_, t), _) -> flattenNullables t + ExprPure a -> flattenNullables $ dbType proxy a + ExprCond a -> [False] + + renderZip opP op expr1 expr2 = zipWith op expr1' expr2' 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 -- put lower priority to make parentheses appear when the same operator is nested - clauses -> Just $ parens interP p $ intercalateS interOp clauses + + renderZip3 opP ops expr1 expr2 = zipWith3 (\op e1 e2 -> op e1 e2) ops expr1' expr2' where + expr1' = renderExprExtended conf opP expr1 + expr2' = renderExprExtended conf opP expr2 + + groupComparisons interP interOp opP comparisons = case comparisons of + [] -> Nothing + [clause] -> Just $ parens (opP - 1) p clause -- put lower priority to make parentheses appear when the same operator is nested + clauses -> Just $ parens interP p $ intercalateS interOp clauses + + renderComp interP interOp opP op expr1 expr2 = groupComparisons interP interOp opP $ renderZip opP op expr1 expr2 + renderCompOps interP interOp opP ops expr1 expr2 = groupComparisons interP interOp opP $ renderZip3 opP ops expr1 expr2 + 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 @@ -235,16 +268,16 @@ {- examples of prefixes -[("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1" -[("val1", DbEmbedded True _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "" -[("val1", DbEmbedded False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef False _)] -> "val1" -[("val1", DbEmbedded False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef True _)] -> "val1" -[("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1" +[("val1", EmbeddedDef False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1" +[("val1", EmbeddedDef True _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "" +[("val1", EmbeddedDef False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef False _)] -> "val1" +[("val1", EmbeddedDef False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef True _)] -> "val1" +[("val1", EmbeddedDef False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1" -} {-# INLINABLE renderChain #-} 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 + ((name, EmbeddedDef False _):fs) -> flattenP esc (Just $ 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 @@ -281,26 +314,21 @@ renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s renderFields escape = commasJoin . foldr (flatten escape) [] --- TODO: merge code of flatten and flattenP {-# SPECIALIZE flatten :: (Utf8 -> Utf8) -> (String, DbType) -> ([Utf8] -> [Utf8]) #-} 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 +flatten escape (fname, typ) acc = flattenP escape Nothing (fname, typ) acc -{-# SPECIALIZE flattenP :: (Utf8 -> Utf8) -> Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) #-} -flattenP :: StringLike s => (s -> s) -> s -> (String, DbType) -> ([s] -> [s]) +{-# SPECIALIZE flattenP :: (Utf8 -> Utf8) -> Maybe Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) #-} +flattenP :: StringLike s => (s -> s) -> Maybe 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 + fullName = case prefix of + Nothing -> fromString fname + Just prefix -> prefix <> fromChar delim <> fromString fname + handleEmb (EmbeddedDef False ts) = foldr (flattenP escape (Just fullName)) acc ts + handleEmb (EmbeddedDef True ts) = foldr (flattenP escape Nothing) acc ts commasJoin :: StringLike s => [s] -> s commasJoin = intercalateS (fromChar ',') diff --git a/Database/Groundhog/Instances.hs b/Database/Groundhog/Instances.hs --- a/Database/Groundhog/Instances.hs +++ b/Database/Groundhog/Instances.hs @@ -229,6 +229,17 @@ fromPrimitivePersistValue (PersistUTCTime a) = utcToZonedTime utc a fromPrimitivePersistValue x = readHelper x ("Expected ZonedTime, received: " ++ show x) +instance PrimitivePersistField A.Value where + toPrimitivePersistValue a = PersistByteString $ Lazy.toStrict $ A.encode a + fromPrimitivePersistValue x = (case x of + PersistString str -> decode' $ T.encodeUtf8 $ T.pack str + PersistText str -> decode' $ T.encodeUtf8 str + PersistByteString str -> decode' str + _ -> error $ "Expected Aeson.Value, received: " ++ show x) where + decode' str = case A.eitherDecode $ Lazy.fromStrict str of + Right val -> val + Left err -> error $ "Error decoding Aeson.Value: " ++ err + instance (PrimitivePersistField a, NeverNull a) => PrimitivePersistField (Maybe a) where toPrimitivePersistValue a = maybe PersistNull toPrimitivePersistValue a fromPrimitivePersistValue PersistNull = Nothing @@ -266,6 +277,7 @@ instance NeverNull TimeOfDay instance NeverNull UTCTime instance NeverNull ZonedTime +instance NeverNull A.Value instance PrimitivePersistField (Key v u) => NeverNull (Key v u) instance NeverNull (KeyForBackend db v) @@ -288,6 +300,12 @@ instance PersistField Lazy.ByteString where persistName _ = "ByteString" + toPersistValues = primToPersistValue + fromPersistValues = primFromPersistValue + dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing + +instance PersistField A.Value where + persistName _ = "JsonValue" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +0.10 +* Pass type information along the UntypedExpr +* Fix #57 (table indexes are ignored) + 0.9.0 * Support for GHC 8.4 diff --git a/groundhog.cabal b/groundhog.cabal --- a/groundhog.cabal +++ b/groundhog.cabal @@ -1,5 +1,5 @@ name: groundhog -version: 0.9.0 +version: 0.10.0 license: BSD3 license-file: LICENSE author: Boris Lykah