packages feed

groundhog 0.4.1 → 0.4.2

raw patch · 8 files changed

+346/−210 lines, 8 files

Files

Database/Groundhog.hs view
@@ -26,6 +26,8 @@   , (&&.), (||.)   , (==.), (/=.), (<.), (<=.), (>.), (>=.)   , isFieldNothing+  , liftExpr+  , toArith   -- * Migration   , createMigration   , executeMigration
Database/Groundhog/Core.hs view
@@ -476,12 +476,13 @@ -- | 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 :: forall db r a . PersistField a => Expr db r a -> UntypedExpr db r+  ExprRaw :: 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  -- | Expr with phantom type helps to keep type safety in complex expressions-newtype Expr db r a = Expr (QueryRaw db r)+newtype Expr db r a = Expr (UntypedExpr db r) instance Show (Expr db r a) where show _ = "Expr" instance Eq (Expr db r a) where (==) = error "(==): this instance Eq (Expr db r a) is made only for Num superclass constraint"
Database/Groundhog/Expression.hs view
@@ -19,6 +19,8 @@   , (&&.), (||.)
   , (==.), (/=.), (<.), (<=.), (>.), (>=.)
   , isFieldNothing
+  , liftExpr
+  , toArith
   ) where
 
 import Database.Groundhog.Core
@@ -29,15 +31,15 @@   toExpr :: a -> UntypedExpr db r
 
 -- | This helper class can make type signatures more concise
-class (Expression db r a, Unifiable a a') => ExpressionOf db r a a'
+class (Expression db r a, PersistField a') => ExpressionOf db r a a'
 
-instance (Expression db r a, Unifiable a a') => ExpressionOf db r a a'
+instance (Expression db r a, Normalize HTrue a (flag, a'), PersistField a') => ExpressionOf db r a a'
 
 instance PurePersistField a => Expression db r a where
   toExpr = ExprPure
 
 instance (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where
-  toExpr = ExprRaw
+  toExpr (Expr e) = e
 
 instance (EntityConstr v c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
   toExpr = ExprField . fieldChain
@@ -52,6 +54,9 @@       => Expression db r' (u (UniqueMarker v)) where
   toExpr = ExprField . fieldChain
 
+instance (db' ~ db, r' ~ r) => Expression db' r' (Cond db r) where
+  toExpr = ExprCond
+
 -- Let's call "plain type" the types that uniquely define type of a Field it is compared to.
 -- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity)
 class Unifiable a b
@@ -70,6 +75,8 @@ instance r ~ (HFalse, Key v (Unique u))                 => Normalize HTrue  (u (UniqueMarker v)) r
 instance NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r)
 instance r ~ (HFalse, Key v BackendSpecific)                 => Normalize HTrue  (AutoKeyField v c) r
+instance r ~ (HTrue, Bool) => Normalize HFalse (Cond db r') r
+instance r ~ (HTrue, Bool) => Normalize HTrue  (Cond db r') r
 instance NormalizeValue t r => Normalize HFalse t r
 instance r ~ (HTrue, t)     => Normalize HTrue  t r
 
@@ -144,3 +151,12 @@ isFieldNothing a = a `eq` Nothing where
   eq :: (Expression db r f, Expression db r a, FieldLike f db r a, Unifiable f a) => f -> a -> Cond db r
   eq = (==.)
+
+-- | Converts value to 'Expr'. It can help to pass values of different types into functions which expect arguments of the same type, like (+).
+liftExpr :: ExpressionOf db r a a' => a -> Expr db r a'
+liftExpr a = Expr $ toExpr a
+
+{-# DEPRECATED toArith "Please use liftExpr instead" #-}
+-- | It is kept for compatibility with older Groundhog versions and can be replaced with "liftExpr".
+toArith :: ExpressionOf db r a a' => a -> Expr db r a'
+toArith = liftExpr
Database/Groundhog/Generic/PersistBackendHelpers.hs view
@@ -32,299 +32,292 @@  {-# INLINABLE get #-} get :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-    => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v)-get escape queryFunc (k :: Key v BackendSpecific) = do+    => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v)+get RenderConfig{..} queryFunc (k :: Key v BackendSpecific) = do   let e = entityDef (undefined :: v)   let proxy = undefined :: Proxy (PhantomDb m)   if isSimple (constructors e)     then do       let constr = head $ constructors e-      let fields = renderFields escape (constrParams constr)-      let query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> " WHERE " <> fromJust (constrId escape constr) <> "=?"-      let types = getConstructorTypes constr-      x <- queryFunc query types [toPrimitivePersistValue proxy k] id+      let fields = renderFields esc (constrParams constr)+      let query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> fromJust (constrId esc constr) <> "=?"+      x <- queryFunc query [toPrimitivePersistValue proxy k] id       case x of         Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs         Nothing -> return Nothing     else do-      let query = "SELECT discr FROM " <> mainTableName escape e <> " WHERE id=?"-      x <- queryFunc query [dbInt64] [toPrimitivePersistValue proxy k] id+      let query = "SELECT discr FROM " <> mainTableName esc e <> " WHERE id=?"+      x <- queryFunc query [toPrimitivePersistValue proxy k] id       case x of         Just [discr] -> do           let constructorNum = fromPrimitivePersistValue proxy discr               constr = constructors e !! constructorNum-              fields = renderFields escape (constrParams constr)-              cQuery = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> " WHERE " <> fromJust (constrId escape constr) <> "=?"-          x2 <- queryFunc cQuery (getConstructorTypes constr) [toPrimitivePersistValue proxy k] id+              fields = renderFields esc (constrParams constr)+              cQuery = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> fromJust (constrId esc constr) <> "=?"+          x2 <- queryFunc cQuery [toPrimitivePersistValue proxy k] id           case x2 of             Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ discr:xs             Nothing -> fail "Missing entry in constructor table"         Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'         Nothing -> return Nothing -select :: forall m db r v c opts . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r)-       => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> (Cond db r -> Maybe (RenderS db r)) -> opts -> m [v]-select escape queryFunc noLimit renderCond' options = doSelectQuery where+select :: forall m db r v c opts . (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r)+       => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> opts -> m [v]+select conf@RenderConfig{..} queryFunc noLimit options = doSelectQuery where   SelectOptions cond limit offset ords = getSelectOptions options    e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)-  orders = renderOrders escape ords+  orders = renderOrders conf ords   (lim, limps) = case (limit, offset) of         (Nothing, Nothing) -> ("", [])         (Nothing, o) -> (" " <> noLimit <> " OFFSET ?", [toPrimitivePersistValue proxy o])         (l, Nothing) -> (" LIMIT ?", [toPrimitivePersistValue proxy l])         (l, o) -> (" LIMIT ? OFFSET ?", [toPrimitivePersistValue proxy l, toPrimitivePersistValue proxy o])-  cond' = renderCond' cond-  fields = renderFields escape (constrParams constr)-  query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> whereClause <> orders <> lim+  cond' = renderCond conf cond+  fields = renderFields esc (constrParams constr)+  query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> whereClause <> orders <> lim   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'-  doSelectQuery = queryFunc query types binds $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)+  doSelectQuery = queryFunc query binds $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)   binds = maybe id getValues cond' $ limps   cNum = entityConstrNum (undefined :: Proxy v) (undefined :: c a)   constr = constructors e !! cNum-  types = getConstructorTypes constr  selectAll :: forall m v . (PersistBackend m, PersistEntity v)-          => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)]-selectAll escape queryFunc = start where+          => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)]+selectAll RenderConfig{..} queryFunc = start where   start = if isSimple (constructors e)     then let       constr = head $ constructors e-      fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId escape constr) $ renderFields escape (constrParams constr)-      query = "SELECT " <> fields <> " FROM " <> tableName escape e constr-      types = maybe id (const $ (dbInt64:)) (constrId escape constr) $ getConstructorTypes constr-      in queryFunc query types [] $ mapAllRows $ mkEntity proxy 0+      fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId esc constr) $ renderFields esc (constrParams constr)+      query = "SELECT " <> fields <> " FROM " <> tableName esc e constr+      in queryFunc query [] $ mapAllRows $ mkEntity proxy 0     else liftM concat $ forM (zip [0..] (constructors e)) $ \(cNum, constr) -> do-        let fields = fromJust (constrId escape constr) <> fromChar ',' <> renderFields escape (constrParams constr)-        let query = "SELECT " <> fields <> " FROM " <> tableName escape e constr-        let types = dbInt64:getConstructorTypes constr-        queryFunc query types [] $ mapAllRows $ mkEntity proxy cNum+        let fields = fromJust (constrId esc constr) <> fromChar ',' <> renderFields esc (constrParams constr)+        let query = "SELECT " <> fields <> " FROM " <> tableName esc e constr+        queryFunc query [] $ mapAllRows $ mkEntity proxy cNum   e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)  getBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))-      => (Utf8 -> Utf8) -- ^ escape-      -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query+      => RenderConfig+      -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query       -> Key v (Unique u)       -> m (Maybe v)-getBy escape queryFunc (k :: Key v (Unique u)) = do+getBy conf@RenderConfig{..} queryFunc (k :: Key v (Unique u)) = do   uniques <- toPersistValues k   let e = entityDef (undefined :: v)       u = (undefined :: Key v (Unique u) -> u (UniqueMarker v)) k-      uFields = renderChain escape (fieldChain u) []+      uFields = renderChain conf (fieldChain u) []       RenderS cond vals = intercalateS " AND " $ mkUniqueCond uFields uniques       constr = head $ constructors e-      fields = renderFields escape (constrParams constr)-      query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> " WHERE " <> cond-  x <- queryFunc query (getConstructorTypes constr) (vals []) id+      fields = renderFields esc (constrParams constr)+      query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> cond+  x <- queryFunc query (vals []) id   case x of     Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs     Nothing -> return Nothing  project :: forall m db r v c p opts a'. (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, Projection p db r a', HasSelectOptions opts db r)-        => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> (Cond db r -> Maybe (RenderS db r)) -> p -> opts -> m [a']-project escape queryFunc noLimit renderCond' p options = doSelectQuery where+        => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> p -> opts -> m [a']+project conf@RenderConfig{..} queryFunc noLimit p options = doSelectQuery where   SelectOptions cond limit offset ords = getSelectOptions options   e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)-  orders = renderOrders escape ords+  orders = renderOrders conf ords   (lim, limps) = case (limit, offset) of         (Nothing, Nothing) -> ("", [])         (Nothing, o) -> (" " <> noLimit <> " OFFSET ?", [toPrimitivePersistValue proxy o])         (l, Nothing) -> (" LIMIT ?", [toPrimitivePersistValue proxy l])         (l, o) -> (" LIMIT ? OFFSET ?", [toPrimitivePersistValue proxy l, toPrimitivePersistValue proxy o])-  cond' = renderCond' cond+  cond' = renderCond conf cond   chains = projectionExprs p []-  RenderS fields fieldVals  = intercalateS (fromChar ',') $ concatMap (renderExprExtended escape 0) chains-  query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> whereClause <> orders <> lim+  RenderS fields fieldVals = commasJoin $ concatMap (renderExprExtended conf 0) chains+  query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> whereClause <> orders <> lim   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'-  doSelectQuery = queryFunc query types binds $ mapAllRows $ liftM fst . projectionResult p+  doSelectQuery = queryFunc query binds $ mapAllRows $ liftM fst . projectionResult p   binds = fieldVals . maybe id getValues cond' $ limps   constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)-  types = map exprType chains where-    exprType (ExprRaw a) = dbType $ (undefined :: Expr db r a -> a) a-    exprType (ExprField ((_, t), _)) = t-    exprType (ExprPure a) = dbType a -count :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)-      => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Cond db r -> Maybe (RenderS db r)) -> Cond db r -> m Int-count escape queryFunc renderCond' cond = do+count :: forall m db r v c . (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)+      => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Cond db r -> m Int+count conf@RenderConfig{..} queryFunc cond = do   let e = entityDef (undefined :: v)       proxy = undefined :: Proxy (PhantomDb m)-      cond' = renderCond' cond+      cond' = renderCond conf cond       constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)-      query = "SELECT COUNT(*) FROM " <> tableName escape e constr <> whereClause where+      query = "SELECT COUNT(*) FROM " <> tableName esc e constr <> whereClause where       whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'-  x <- queryFunc query [dbInt64] (maybe [] (flip getValues []) cond') id+  x <- queryFunc query (maybe [] (flip getValues []) cond') id   case x of     Just [num] -> return $ fromPrimitivePersistValue proxy num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)     Nothing -> fail $ "COUNT returned no rows"  replace :: forall m db r v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-        => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Utf8 -> [PersistValue] -> m ()) -> (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r)+        => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Utf8 -> [PersistValue] -> m ()) -> (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r)         -> Key v BackendSpecific -> v -> m ()-replace escape queryFunc execFunc insertIntoConstructorTable k v = do+replace RenderConfig{..} queryFunc execFunc insertIntoConstructorTable k v = do   vals <- toEntityPersistValues' v   let e = entityDef v       proxy = undefined :: Proxy (PhantomDb m)       constructorNum = fromPrimitivePersistValue proxy (head vals)       constr = constructors e !! constructorNum--      upds = renderFields (\f -> escape f <> "=?") $ constrParams constr-      updateQuery = "UPDATE " <> tableName escape e constr <> " SET " <> upds <> " WHERE " <> fromString (fromJust $ constrAutoKeyName constr) <> "=?"+      k' = toPrimitivePersistValue proxy k+      RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals where+        fields = foldr (flatten esc) [] $ constrParams constr+        f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2+      updateQuery = "UPDATE " <> tableName esc e constr <> " SET " <> upds <> " WHERE " <> fromString (fromJust $ constrAutoKeyName constr) <> "=?"    if isSimple (constructors e)-    then execFunc updateQuery (tail vals ++ [toPrimitivePersistValue proxy k])+    then execFunc updateQuery (updsVals [k'])     else do-      let query = "SELECT discr FROM " <> mainTableName escape e <> " WHERE id=?"-      x <- queryFunc query [dbInt64] [toPrimitivePersistValue proxy k] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))+      let query = "SELECT discr FROM " <> mainTableName esc e <> " WHERE id=?"+      x <- queryFunc query [k'] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))       case x of         Just discr -> do-          let cName = tableName escape e constr+          let cName = tableName esc e constr            if discr == constructorNum-            then execFunc updateQuery (tail vals ++ [toPrimitivePersistValue proxy k])+            then execFunc updateQuery (updsVals [k'])             else do-              let RenderS insQuery vals' = insertIntoConstructorTable True cName constr (toPrimitivePersistValue proxy k:tail vals)+              let RenderS insQuery vals' = insertIntoConstructorTable True cName constr (k':tail vals)               execFunc insQuery (vals' [])                let oldConstr = constructors e !! discr-              let delQuery = "DELETE FROM " <> tableName escape e oldConstr <> " WHERE " <> fromJust (constrId escape oldConstr) <> "=?"-              execFunc delQuery [toPrimitivePersistValue proxy k]+              let delQuery = "DELETE FROM " <> tableName esc e oldConstr <> " WHERE " <> fromJust (constrId esc oldConstr) <> "=?"+              execFunc delQuery [k'] -              let updateDiscrQuery = "UPDATE " <> mainTableName escape e <> " SET discr=? WHERE id=?"-              execFunc updateDiscrQuery [head vals, toPrimitivePersistValue proxy k]+              let updateDiscrQuery = "UPDATE " <> mainTableName esc e <> " SET discr=? WHERE id=?"+              execFunc updateDiscrQuery [head vals, k']         Nothing -> return ()  replaceBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))-          => (Utf8 -> Utf8) -- ^ escape+          => RenderConfig           -> (Utf8 -> [PersistValue] -> m ()) -- ^ function to execute query           -> u (UniqueMarker v)           -> v           -> m ()-replaceBy escape execFunc u v = do+replaceBy conf@RenderConfig{..} execFunc u v = do   uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))-  vals <- toEntityPersistValues v+  vals <- toEntityPersistValues' v   let e = entityDef (undefined :: v)-      uFields = renderChain escape (fieldChain u) []+      uFields = renderChain conf (fieldChain u) []       RenderS cond condVals = intercalateS " AND " $ mkUniqueCond uFields uniques       constr = head $ constructors e-      upds = renderFields (\f -> escape f <> "=?") $ constrParams constr-      updateQuery = "UPDATE " <> tableName escape e constr <> " SET " <> upds <> " WHERE " <> cond-  execFunc updateQuery (tail . vals . condVals $ [])+      RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals where+        fields = foldr (flatten esc) [] $ constrParams constr+        f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2+      updateQuery = "UPDATE " <> tableName esc e constr <> " SET " <> upds <> " WHERE " <> cond+  execFunc updateQuery (updsVals . condVals $ [])  update :: forall m db r v c . (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)-       => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> (Cond db r -> Maybe (RenderS db r)) -> [Update db r] -> Cond db r -> m ()-update escape execFunc renderCond' upds cond = do+       => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> [Update db r] -> Cond db r -> m ()+update conf@RenderConfig{..} execFunc upds cond = do   let e = entityDef (undefined :: v)-  case renderUpdates escape upds of+  case renderUpdates conf upds of     Just upds' -> do-      let cond' = renderCond' cond+      let cond' = renderCond conf cond           constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)-          query = "UPDATE " <> tableName escape e constr <> " SET " <> whereClause where+          query = "UPDATE " <> tableName esc e constr <> " SET " <> whereClause where           whereClause = maybe (getQuery upds') (\c -> getQuery upds' <> " WHERE " <> getQuery c) cond'       execFunc query (getValues upds' <> maybe mempty getValues cond' $ [])     Nothing -> return () -delete :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)-       => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> (Cond db r -> Maybe (RenderS db r)) -> Cond db r -> m ()-delete escape execFunc renderCond' cond = execFunc query (maybe [] (($ []) . getValues) cond') where+delete :: forall m db r v c . (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)+       => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> Cond db r -> m ()+delete conf@RenderConfig{..} execFunc cond = execFunc query (maybe [] (($ []) . getValues) cond') where   e = entityDef (undefined :: v)   constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)-  cond' = renderCond' cond+  cond' = renderCond conf cond   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'   query = if isSimple (constructors e)-    then "DELETE FROM " <> tableName escape e constr <> whereClause+    then "DELETE FROM " <> tableName esc e constr <> whereClause     -- the entries in the constructor table are deleted because of the reference on delete cascade-    else "DELETE FROM " <> mainTableName escape e <> " WHERE id IN(SELECT " <> fromJust (constrId escape constr) <> " FROM " <> tableName escape e constr <> whereClause <> ")"+    else "DELETE FROM " <> mainTableName esc e <> " WHERE id IN(SELECT " <> fromJust (constrId esc constr) <> " FROM " <> tableName esc e constr <> whereClause <> ")"  insertByAll :: forall m v . (PersistBackend m, PersistEntity v)-            => (Utf8 -> Utf8) -- ^ escape-            -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query+            => RenderConfig+            -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query             -> Bool -- ^ allow multiple duplication of uniques with nulls             -> v -> m (Either (AutoKey v) (AutoKey v))-insertByAll escape queryFunc manyNulls v = do+insertByAll RenderConfig{..} queryFunc manyNulls v = do   let e = entityDef v       proxy = undefined :: Proxy (PhantomDb m)       (constructorNum, uniques) = getUniques proxy v       constr = constructors e !! constructorNum       uniqueDefs = constrUniques constr -      query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> tableName escape e constr <> " WHERE " <> cond+      query = "SELECT " <> maybe "1" id (constrId esc constr) <> " FROM " <> tableName esc e constr <> " WHERE " <> cond       conds = catMaybes $ zipWith (\u (_, uVals) -> checkNulls uVals $ intercalateS " AND " $ mkUniqueCond (f u) uVals) uniqueDefs uniques where-        f = foldr (flatten escape) [] . uniqueFields+        f = foldr (flatten esc) [] . uniqueFields       -- skip condition if any value is NULL. It allows to insert many values with duplicate unique key       checkNulls uVals x = if manyNulls && any (== PersistNull) (uVals []) then Nothing else Just x       RenderS cond vals = intercalateS " OR " conds   if null conds     then liftM Right $ Core.insert v     else do-      x <- queryFunc query [dbInt64] (vals []) id+      x <- queryFunc query (vals []) id       case x of         Nothing -> liftM Right $ Core.insert v         Just xs -> return $ Left $ fst $ fromPurePersistValues proxy xs  deleteBy :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-            => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m ()-deleteBy escape execFunc k = execFunc query [toPrimitivePersistValue proxy k] where+            => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m ()+deleteBy RenderConfig{..} execFunc k = execFunc query [toPrimitivePersistValue proxy k] where   e = entityDef ((undefined :: Key v u -> v) k)   proxy = undefined :: Proxy (PhantomDb m)   constr = head $ constructors e   idName = if isSimple (constructors e)-    then fromJust $ constrId escape constr+    then fromJust $ constrId esc constr     else "id"   -- the entries in the constructor table are deleted because of the reference on delete cascade-  query = "DELETE FROM " <> mainTableName escape e <> " WHERE " <> idName <> "=?"+  query = "DELETE FROM " <> mainTableName esc e <> " WHERE " <> idName <> "=?"  deleteAll :: forall m v . (PersistBackend m, PersistEntity v)-          => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> v -> m ()-deleteAll escape execFunc (_ :: v) = do+          => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> v -> m ()+deleteAll RenderConfig{..} execFunc (_ :: v) = do   let e = entityDef (undefined :: v)-      query = "DELETE FROM " <> mainTableName escape e+      query = "DELETE FROM " <> mainTableName esc e   execFunc query []  countAll :: forall m v . (PersistBackend m, PersistEntity v)-         => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int-countAll escape queryFunc (_ :: v) = do+         => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int+countAll RenderConfig{..} queryFunc (_ :: v) = do   let e = entityDef (undefined :: v)       proxy = undefined :: Proxy (PhantomDb m)-      query = "SELECT COUNT(*) FROM " <> mainTableName escape e-  x <- queryFunc query [dbInt64] [] id+      query = "SELECT COUNT(*) FROM " <> mainTableName esc e+  x <- queryFunc query [] id   case x of     Just [num] -> return $ fromPrimitivePersistValue proxy num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)     Nothing -> fail $ "COUNT returned no rows"  insertBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))-         => (Utf8 -> Utf8)-         -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)+         => RenderConfig+         -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a)          -> Bool          -> u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))-insertBy escape queryFunc manyNulls u v = do+insertBy conf@RenderConfig{..} queryFunc manyNulls u v = do   uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))   let e = entityDef v       proxy = undefined :: Proxy (PhantomDb m)-      uFields = renderChain escape (fieldChain u) []+      uFields = renderChain conf (fieldChain u) []       RenderS cond vals = intercalateS " AND " $ mkUniqueCond uFields uniques       -- skip condition if any value is NULL. It allows to insert many values with duplicate unique key       checkNulls uVals = manyNulls && any (== PersistNull) (uVals [])       -- this is safe because unique keys exist only for entities with one constructor       constr = head $ constructors e-      query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> tableName escape e constr <> " WHERE " <> cond+      query = "SELECT " <> maybe "1" id (constrId esc constr) <> " FROM " <> tableName esc e constr <> " WHERE " <> cond   if checkNulls uniques     then liftM Right $ Core.insert v     else do-      x <- queryFunc query [dbInt64] (vals []) id+      x <- queryFunc query (vals []) id       case x of         Nothing  -> liftM Right $ Core.insert v         Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]         Just xs  -> fail $ "unexpected query result: " ++ show xs -getConstructorTypes :: ConstructorDef -> [DbType]-getConstructorTypes = map snd . constrParams where- constrId :: (Utf8 -> Utf8) -> ConstructorDef -> Maybe Utf8 constrId escape = fmap (escape . fromString) . constrAutoKeyName @@ -335,9 +328,6 @@  toEntityPersistValues' :: (PersistBackend m, PersistEntity v) => v -> m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues--dbInt64 :: DbType-dbInt64 = DbTypePrimitive DbInt64 False Nothing Nothing  mkUniqueCond :: [Utf8] -> ([PersistValue] -> [PersistValue]) -> [RenderS db r] mkUniqueCond u vals = zipWith f u (vals []) where
Database/Groundhog/Generic/Sql.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, OverloadedStrings, FlexibleInstances, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, OverloadedStrings, FlexibleInstances, TypeFamilies, UndecidableInstances, RecordWildCards #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -16,11 +16,14 @@     , renderExprPriority     , renderExprExtended     , renderPersistValue+    , mkExprWithConf+    , prerenderExpr     , intercalateS     , commasJoin     , flatten     , RenderS(..)     , Utf8(..)+    , RenderConfig(..)     , fromUtf8     , StringLike(..)     , fromString@@ -28,9 +31,10 @@     , function     , operator     , parens+    , mkExpr     , Snippet(..)     , SqlDb(..)-    , liftExpr+    , FloatingSqlDb(..)     , tableName     , mainTableName     ) where@@ -39,8 +43,7 @@ import Database.Groundhog.Generic (isSimple) import Database.Groundhog.Instances () import qualified Blaze.ByteString.Builder.Char.Utf8 as B-import Data.Int (Int64)-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, maybeToList) import Data.Monoid import Data.String @@ -65,35 +68,70 @@   fromChar = Utf8 . B.fromChar  -- | Escape function, priority of the outer operator. The result is a list for the embedded data which may expand to several RenderS.-newtype Snippet db r = Snippet ((Utf8 -> Utf8) -> Int -> [RenderS db r])+newtype Snippet db r = Snippet (RenderConfig -> Int -> [RenderS db r]) --- Alas, GHC before 7.2 does not support superclass equality constraints (QueryRaw db ~ Snippet db).+newtype RenderConfig = RenderConfig {+    esc  :: Utf8 -> Utf8+}++-- Alas , GHC before 7.2 does not support superclass equality constraints (QueryRaw db ~ Snippet db). -- | This class distinguishes databases which support SQL-specific expressions. It contains ad hoc members for features whose syntax differs across the databases. class DbDescriptor 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) -renderExpr :: (DbDescriptor db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> UntypedExpr db r -> RenderS db r-renderExpr esc expr = renderExprPriority esc 0 expr+  equalsOperator :: RenderS db r -> RenderS db r -> RenderS db r+  notEqualsOperator :: RenderS db r -> RenderS db r -> RenderS db r -renderExprPriority :: (DbDescriptor db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> Int -> UntypedExpr db r -> RenderS db r-renderExprPriority esc p expr = (case expr of-  ExprRaw (Expr (Snippet f)) -> let vals = f esc p in ensureOne vals id-  ExprField f -> let fs = renderChain esc f []+-- | This class distinguishes databases which support trigonometry and other math functions. For example, PostgreSQL has them but Sqlite does not. It contains ad hoc members for features whose syntax differs across the databases.+class SqlDb db => FloatingSqlDb db where+  -- | Natural logarithm+  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++-- | If we reuse complex expression several times, prerendering it saves time. `RenderConfig` can be obtained with `mkExprWithConf`+prerenderExpr :: (SqlDb db, QueryRaw db ~ Snippet db) => RenderConfig -> Expr db r a -> Expr db r a+prerenderExpr conf (Expr e) = Expr $ ExprRaw $ Snippet $ \_ _ -> prerendered where+  -- Priority of outer operation is not known. Assuming that it is high ensures that parentheses won't be missing.+  prerendered = renderExprExtended conf maxBound e++-- | Helps creating an expression which depends on render configuration. It can be used in pair with `prerenderExpr`.+-- @+-- myExpr x = mkExprWithConf $ \conf _ -> let+--        x' = prerenderExpr conf x+--     in x' + x' * x'@+-- @+mkExprWithConf :: (SqlDb db, QueryRaw db ~ Snippet 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, QueryRaw db ~ Snippet db) => RenderConfig -> UntypedExpr db r -> RenderS db r+renderExpr conf expr = renderExprPriority conf 0 expr++renderExprPriority :: (SqlDb db, QueryRaw db ~ Snippet 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) where+                 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 :: (DbDescriptor db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> Int -> UntypedExpr db r -> [RenderS db r]-renderExprExtended esc p expr = (case expr of-  ExprRaw (Expr (Snippet f)) -> f esc p-  ExprField f -> map (flip RenderS id) $ renderChain esc f []+renderExprExtended :: (SqlDb db, QueryRaw db ~ Snippet 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) where+                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@@ -119,45 +157,52 @@ parens p1 p2 expr = if p1 < p2 then fromChar '(' <> expr <> fromChar ')' else expr  operator :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a, Expression db r b) => Int -> String -> a -> b -> Snippet db r-operator pr op = \a b -> Snippet $ \esc p ->-  [parens pr p $ renderExprPriority esc pr (toExpr a) <> fromString op <> renderExprPriority esc pr (toExpr b)]+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, QueryRaw db ~ Snippet db) => String -> [UntypedExpr db r] -> Snippet db r-function func args = Snippet $ \esc _ -> [fromString func <> fromChar '(' <> commasJoin (map (renderExpr esc) args) <> fromChar ')']+function func args = Snippet $ \conf _ -> [fromString func <> fromChar '(' <> commasJoin (map (renderExpr conf) args) <> fromChar ')'] +mkExpr :: (SqlDb db, QueryRaw db ~ Snippet db) => Snippet db r -> Expr db r a+mkExpr = Expr . ExprRaw+ #if !MIN_VERSION_base(4, 5, 0) {-# INLINABLE (<>) #-} (<>) :: Monoid m => m -> m -> m (<>) = mappend #endif -instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Num a) => Num (Expr db r a) where-  a + b = Expr $ operator 60 "+" a b-  a - b = Expr $ operator 60 "-" a b-  a * b = Expr $ operator 70 "*" a b-  signum = error "Num Expr: no signum"-  abs a = Expr $ Snippet $ \esc _ -> ["ABS(" <> renderExpr esc (toExpr a) <> fromChar ')']-  fromInteger a = liftExpr' (fromIntegral a :: Int64)- {-# INLINABLE renderCond #-} -- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns. renderCond :: forall r db . (SqlDb db, QueryRaw db ~ Snippet db)-  => (Utf8 -> Utf8) -- ^ escape-  -> (Utf8 -> Utf8 -> Utf8) -- ^ render equals-  -> (Utf8 -> Utf8 -> Utf8) -- ^ render not equals+  => RenderConfig   -> Cond db r -> Maybe (RenderS db r)-renderCond esc rendEq rendNotEq (cond :: Cond db r) = go cond 0 where+renderCond conf cond = renderCondPriority conf 0 cond where++{-# INLINABLE renderCondPriority #-}+-- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.+renderCondPriority :: forall r db . (SqlDb db, QueryRaw db ~ Snippet db)+  => RenderConfig+  -> Int -> Cond db r -> Maybe (RenderS db r)+renderCondPriority conf@RenderConfig{..} priority (cond :: Cond db r) = 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 a)         p = fmap (\a' -> parens notP p $ "NOT " <> a') $ go a notP-  go (Compare op f1 f2) p = case op of-    Eq -> renderComp andP p " AND " rendEq f1 f2-    Ne -> renderComp orP p " OR " rendNotEq f1 f2-    Gt -> renderComp orP p " OR " (\a b -> a <> fromChar '>' <> b) f1 f2-    Lt -> renderComp orP p " OR " (\a b -> a <> fromChar '<' <> b) f1 f2-    Ge -> renderComp orP p " OR " (\a b -> a <> ">=" <> b) f1 f2-    Le -> renderComp orP p " OR " (\a b -> a <> "<=" <> b) f1 f2-  go (CondRaw (Snippet f)) p = case f esc p of+  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  -- put lower priority to make parentheses appear when the same operator is nested+          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"@@ -166,18 +211,10 @@   andP = 30   orP = 20 -  renderComp p pOuter logicOp op expr1 expr2 = result where-    expr1' = renderExprExtended esc p' expr1-    expr2' = renderExprExtended esc p' expr2-    liftOp f (RenderS a1 b1) (RenderS a2 b2) = RenderS (f a1 a2) (b1 . b2)-    (result, p') = case zipWith (liftOp op) expr1' expr2' of-      [clause] -> (Just clause, pOuter)-      [] -> (Nothing, pOuter)-      clauses -> (Just $ parens p pOuter $ intercalateS logicOp clauses, p)   perhaps :: Int -> Int -> Utf8 -> Cond db r -> Cond db r -> Maybe (RenderS db r)   perhaps p pOuter op a b = result where     -- we don't know if the current operator is present until we render both operands. Rendering requires priority of the outer operator. We tie a knot to defer calculating the priority-    (priority, result) = case (go a priority, go b priority) of+    (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')@@ -192,8 +229,8 @@ [("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1" -} {-# INLINABLE renderChain #-}-renderChain :: (Utf8 -> Utf8) -> FieldChain -> [Utf8] -> [Utf8]-renderChain esc (f, prefix) acc = (case prefix of+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@@ -213,38 +250,38 @@ defaultShowPrim (PersistCustom _ _) = error "Unexpected PersistCustom"  {-# INLINABLE renderOrders #-}-renderOrders :: forall db r . (Utf8 -> Utf8) -> [Order db r] -> Utf8+renderOrders :: forall db r . RenderConfig -> [Order db r] -> Utf8 renderOrders _ [] = mempty-renderOrders esc xs = if null orders then mempty else " ORDER BY " <> commasJoin orders where+renderOrders conf xs = if null orders then mempty else " ORDER BY " <> commasJoin orders where   orders = foldr go [] xs-  go (Asc a) acc = renderChain esc (fieldChain a) acc-  go (Desc a) acc = renderChain (\f -> esc f <> " DESC") (fieldChain a) acc+  go (Asc a) acc = renderChain conf (fieldChain a) acc+  go (Desc a) acc = map (<> " DESC") $ renderChain conf (fieldChain a) acc  {-# INLINABLE renderFields #-} -- Returns string with comma separated escaped fields like "name,age" -- If there are other columns before renderFields result, do not put comma because the result might be an empty string. This happens when the fields have no columns like (). -- One of the solutions is to add one more field with datatype that is known to have columns, eg renderFields id (("id", namedType (0 :: Int64)) : constrParams constr) renderFields :: (Utf8 -> Utf8) -> [(String, DbType)] -> Utf8-renderFields esc = commasJoin . foldr (flatten esc) []+renderFields escape = commasJoin . foldr (flatten escape) []  -- TODO: merge code of flatten and flattenP flatten :: (Utf8 -> Utf8) -> (String, DbType) -> ([Utf8] -> [Utf8])-flatten esc (fname, typ) acc = go typ where+flatten escape (fname, typ) acc = go typ where   go typ' = case typ' of     DbEmbedded emb _ -> handleEmb emb-    _            -> esc fullName : acc+    _            -> escape fullName : acc   fullName = fromString fname-  handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts-  handleEmb (EmbeddedDef True  ts) = foldr (flatten esc) acc ts+  handleEmb (EmbeddedDef False ts) = foldr (flattenP escape fullName) acc ts+  handleEmb (EmbeddedDef True  ts) = foldr (flatten escape) acc ts  flattenP :: (Utf8 -> Utf8) -> Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8])-flattenP esc prefix (fname, typ) acc = go typ where+flattenP escape prefix (fname, typ) acc = go typ where   go typ' = case typ' of     DbEmbedded emb _ -> handleEmb emb-    _            -> esc fullName : acc+    _            -> escape fullName : acc   fullName = prefix <> fromChar delim <> fromString fname-  handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts-  handleEmb (EmbeddedDef True  ts) = foldr (flatten esc) acc ts+  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 ',')@@ -257,20 +294,14 @@   go (f:fs) = a <> f <> go fs  {-# INLINABLE renderUpdates #-}-renderUpdates :: (SqlDb db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> [Update db r] -> Maybe (RenderS db r)-renderUpdates esc upds = (case mapMaybe go upds of+renderUpdates :: (SqlDb db, QueryRaw db ~ Snippet 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 esc 0+    rend = renderExprExtended conf 0     fs = concatMap rend (projectionExprs field [])     guard a = if null fs then Nothing else Just a--liftExpr :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a b) => a -> Expr db r b-liftExpr a = liftExpr' a--liftExpr' :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a) => a -> Expr db r b-liftExpr' a = Expr $ Snippet $ \esc pr -> renderExprExtended esc pr (toExpr a)  -- | Returns escaped table name optionally qualified with schema {-# SPECIALIZE tableName :: (Utf8 -> Utf8) -> EntityDef -> ConstructorDef -> Utf8 #-}
Database/Groundhog/Generic/Sql/Functions.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | This module has common SQL functions and operators which are supported in the most SQL databases module Database.Groundhog.Generic.Sql.Functions@@ -8,10 +9,16 @@     , notIn_     , lower     , upper-    , toArith+    , case_     , SqlDb(..)+    , cot+    , atan2+    , radians+    , degrees     ) where +import Data.Int (Int64)+import Data.String import Database.Groundhog.Core import Database.Groundhog.Expression import Database.Groundhog.Generic.Sql@@ -19,25 +26,105 @@ in_ :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>     a -> [b] -> Cond db r in_ _ [] = CondEmpty-in_ a bs = CondRaw $ Snippet $ \esc p -> [parens 45 p $ renderExpr esc (toExpr a) <> " IN (" <> commasJoin (map (renderExpr esc . toExpr) bs) <> ")"]+in_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"]  notIn_ :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>        a -> [b] -> Cond db r notIn_ _ [] = CondEmpty-notIn_ a bs = CondRaw $ Snippet $ \esc p -> [parens 45 p $ renderExpr esc (toExpr a) <> " NOT IN (" <> commasJoin (map (renderExpr esc . toExpr) bs) <> ")"]+notIn_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " NOT IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"] -like :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> String -> Cond db r+like :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', IsString a') => a -> String -> Cond db r like a b = CondRaw $ operator 40 " LIKE " a b -notLike :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> String -> Cond db r+notLike :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', IsString a') => a -> String -> Cond db r notLike a b = CondRaw $ operator 40 " NOT LIKE " a b -lower :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> Expr db r String-lower a = Expr $ function "lower" [toExpr a]+lower :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', IsString a') => a -> Expr db r a'+lower a = mkExpr $ function "lower" [toExpr a] -upper :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> Expr db r String-upper a = Expr $ function "upper" [toExpr a]+upper :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', IsString a') => a -> Expr db r a'+upper a = mkExpr $ function "upper" [toExpr a] --- | Convert field to an arithmetic value. It is kept for compatibility with older Groundhog versions and can be replaced with liftExpr.-toArith :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r f a', FieldLike f db r a') => f -> Expr db r a'-toArith = liftExpr+cot :: (FloatingSqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', Floating a') => a -> Expr db r a'+cot a = mkExpr $ function "cot" [toExpr a]++radians, degrees :: (FloatingSqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', Floating a') => a -> Expr db r a'+radians x = mkExpr $ function "radians" [toExpr x]+degrees x = mkExpr $ function "degrees" [toExpr x]++instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Num a) => Num (Expr db r a) where+  a + b = mkExpr $ operator 60 "+" a b+  a - b = mkExpr $ operator 60 "-" a b+  a * b = mkExpr $ operator 70 "*" a b+  signum a = signum' a+  abs a = mkExpr $ function "abs" [toExpr a]+  fromInteger a = Expr $ toExpr (fromIntegral a :: Int64)++instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Fractional a) => Fractional (Expr db r a) where+  a / b = mkExpr $ operator 70 "/" a b+  fromRational a = Expr $ toExpr (fromRational a :: Double)++instance (FloatingSqlDb db, QueryRaw db ~ Snippet db, PersistField a, Floating a) => Floating (Expr db r a) where+  pi = mkExpr $ function "pi" []+  exp x = mkExpr $ function "exp" [toExpr x]+  sqrt x = mkExpr $ function "sqrt" [toExpr x]+  log x = log' x+  x ** y = mkExpr $ function "pow" [toExpr x, toExpr y]+  logBase b x = logBase' b x+  sin x = mkExpr $ function "sin" [toExpr x]+  tan x = mkExpr $ function "tan" [toExpr x]+  cos x = mkExpr $ function "cos" [toExpr x]+  asin x = mkExpr $ function "asin" [toExpr x]+  atan x = mkExpr $ function "atan" [toExpr x]+  acos x = mkExpr $ function "acos" [toExpr x]+  sinh x = (exp x - exp (-x)) / 2+  tanh x = (exp (2 * x) - 1) / (exp (2 * x) + 1)+  cosh x = (exp x + exp (-x)) / 2+  asinh x = log $ x + sqrt (x * x + 1)+  atanh x = log ((1 + x) / (1 - x)) / 2+  acosh x = log $ x + sqrt (x * x - 1)++instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Ord a) => Ord (Expr db r a) where+  compare = error "compare: instance Ord (Expr db r a) does not have implementation"+  (<=) = error "(<=): instance Ord (Expr db r a) does not have implementation"+  max a b = mkExpr $ function "max" [toExpr a, toExpr b]+  min a b = mkExpr $ function "min" [toExpr a, toExpr b]++instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Real a) => Real (Expr db r a) where+  toRational = error "toRational: instance Real (Expr db r a) is made only for Integral superclass constraint"++instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Enum a) => Enum (Expr db r a) where+  toEnum = error "toEnum: instance Enum (Expr db r a) is made only for Integral superclass constraint"+  fromEnum = error "fromEnum: instance Enum (Expr db r a) is made only for Integral superclass constraint"++instance (SqlDb db, QueryRaw db ~ Snippet db, PurePersistField a, Integral a) => Integral (Expr db r a) where+  quotRem x y = quotRem' x y+  divMod x y = (div', mod') where+    div' = mkExprWithConf $ \conf _ -> let+             x' = prerenderExpr conf x+             y' = prerenderExpr conf y+       in case_ [ (x' >. zero &&. y' <. zero, (x' - y' - 1) `quot` y')+                , (x' <. zero &&. y' >. zero, (x' - y' + 1) `quot` y')+                ] (x' `quot` y')+    mod' = mkExprWithConf $ \conf _ -> let+             x' = prerenderExpr conf x+             y' = prerenderExpr conf y+       in case_ [ (x' >. zero &&. y' <. zero ||. x' <. zero &&. y' >. zero,+                   case_ [((x' `rem` y') /=. zero, x' `rem` y' + y')] zero)+                ] (x' `rem` y')+    zero = 0 `asTypeOf` ((undefined :: Expr db r a -> a) x)+  toInteger = error "toInteger: instance Integral (Expr db r a) does not have implementation"++case_ :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a a', ExpressionOf db r b a')+      => [(Cond db r, a)] -- ^ Conditions+      -> b          -- ^ It is returned when none of conditions is true+      -> Expr db r a'+case_ [] else_ = Expr $ toExpr else_+case_ cases else_ = mkExpr $ Snippet $ \conf _ ->+     ["case "+  <> intercalateS (fromChar ' ') (map (rend conf) cases)+  <> " else " <> renderExpr conf (toExpr else_)+  <> " end"] where+  rend conf (cond, a) = case renderCond conf cond of+    Nothing -> error "case_: empty condition"+    Just cond' -> "when " <> cond' <> " then " <> renderExpr conf (toExpr a)
Database/Groundhog/Instances.hs view
@@ -120,46 +120,55 @@ instance PrimitivePersistField Int where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int8 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int16 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int32 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int64 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word8 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word16 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word32 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word64 where   toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)   fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue _ (PersistDouble a) = truncate a   fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Double where@@ -446,7 +455,7 @@   projectionResult _ = fromPersistValues  instance PersistField a => Projection (Expr db r a) db r a where-  projectionExprs e = (ExprRaw e:)+  projectionExprs (Expr e) = (e:)   projectionResult _ = fromPersistValues  instance (EntityConstr v c, a ~ AutoKey v) => Projection (AutoKeyField v c) db (RestrictionHolder v c) a where
groundhog.cabal view
@@ -1,5 +1,5 @@ name:            groundhog-version:         0.4.1+version:         0.4.2 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>