beam 0.3.1.0 → 0.3.2.0
raw patch · 6 files changed
+207/−198 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- beam.cabal +1/−1
- src/Database/Beam/Backend/Sqlite3.hs +1/−1
- src/Database/Beam/Query.hs +8/−8
- src/Database/Beam/Query/Combinators.hs +181/−174
- src/Database/Beam/Query/Internal.hs +11/−9
- src/Database/Beam/Query/Types.hs +5/−5
beam.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: beam-version: 0.3.1.0+version: 0.3.2.0 synopsis: A type-safe SQL mapper for Haskell that doesn't use Template Haskell description: See the documentation on [my blog](http://travis.athougies.net/tags/beam.html) and on [GitHub](https://github.com/tathougies/beam/tree/master/Doc). homepage: http://travis.athougies.net/projects/beam.html
src/Database/Beam/Backend/Sqlite3.hs view
@@ -35,5 +35,5 @@ [res] <- liftIO (quickQuery conn (concat ["SELECT * FROM ", unpack tblName, " WHERE ROWID=(SELECT last_insert_rowid()) limit 1"]) []) return res -(++.) :: QExpr Text -> QExpr Text -> QExpr Text+(++.) :: QExpr s Text -> QExpr s Text -> QExpr s Text QExpr a ++. QExpr b = QExpr (SQLBinOpE "||" a b)
src/Database/Beam/Query.hs view
@@ -95,8 +95,8 @@ insertInto (DatabaseTable _ name) data_ = BeamT (\beam -> toBeamResult <$> runInsert name data_ beam) -updateToSQL :: Table table => T.Text -> table QExpr -> QExpr Bool -> Maybe SQLUpdate-updateToSQL tblName (setTo :: table QExpr) where_ =+updateToSQL :: Table table => T.Text -> table (QExpr s) -> QExpr s Bool -> Maybe SQLUpdate+updateToSQL tblName (setTo :: table (QExpr s)) where_ = let setExprs = fieldAllValues (\(Columnar' x) -> optimizeExpr x) setTo setColumns = fieldAllValues (\(Columnar' fieldS) -> _fieldName fieldS) (tblFieldSettings :: TableSettings table) @@ -119,7 +119,7 @@ -- | Update every entry in the given table where the third argument yields true, using the second -- argument to give the new values.-updateWhere :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> (tbl QExpr -> tbl QExpr) -> (tbl QExpr -> QExpr Bool) -> BeamT e db m ()+updateWhere :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> (tbl (QExpr s) -> tbl (QExpr s)) -> (tbl (QExpr s) -> QExpr s Bool) -> BeamT e db m () updateWhere tbl@(DatabaseTable _ name :: DatabaseTable db tbl) mkAssignments mkWhere = do let assignments = mkAssignments tblExprs where_ = mkWhere tblExprs@@ -142,7 +142,7 @@ updateWhere tbl (\_ -> tableVal newValues) (val_ (primaryKey newValues) `references_`) -- | Delete all entries in the given table matched by the expression-deleteWhere :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> (tbl QExpr -> QExpr Bool) -> BeamT e db m ()+deleteWhere :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> (tbl (QExpr s) -> QExpr s Bool) -> BeamT e db m () deleteWhere (DatabaseTable _ name :: DatabaseTable db tbl) mkWhere = let tblExprs = changeRep (\(Columnar' fieldS) -> Columnar' (QExpr (SQLFieldE (QField name Nothing (_fieldName fieldS))))) (tblFieldSettings :: TableSettings tbl) @@ -180,7 +180,7 @@ , FromSqlValues (QExprToIdentity a) , Projectible a , IsQuery q ) =>- (forall s. q db s a) -> Beam db m -> m (Either String (Source m (QExprToIdentity a)))+ q db s a -> Beam db m -> m (Either String (Source m (QExprToIdentity a))) runQuery q beam = do let selectCmd = Select select (_, _, select) = queryToSQL' (toQ q) 0@@ -202,7 +202,7 @@ -- | Run the given query in the transaction and yield a 'Source' that can be used to read results -- incrementally. If your result set is small and you want to just get a list, use 'queryList'.-query :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => (forall s. q db s a) -> BeamT e db m (Source (BeamT e db m) (QExprToIdentity a))+query :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => q db () a -> BeamT e db m (Source (BeamT e db m) (QExprToIdentity a)) query q = BeamT $ \beam -> do res <- runQuery q beam case res of@@ -211,13 +211,13 @@ -- | Execute 'query' and use the 'Data.Conduit.List.consume' function to return a list of -- results. Best used for small result sets.-queryList :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => (forall s. q db s a) -> BeamT e db m [QExprToIdentity a]+queryList :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => q db () a -> BeamT e db m [QExprToIdentity a] queryList q = do src <- query q src $$ C.consume -- | Execute the query using 'query' and return exactly one result. The return value will be -- 'Nothing' if either zero or more than one values were returned.-getOne :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => (forall s. q db s a) -> BeamT e db m (Maybe (QExprToIdentity a))+getOne :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => q db () a -> BeamT e db m (Maybe (QExprToIdentity a)) getOne q = do let justOneSink = await >>= \x -> case x of
src/Database/Beam/Query/Combinators.hs view
@@ -45,10 +45,10 @@ import Data.Text (Text) import Data.Coerce -instance IsString (QExpr Text) where+instance IsString (QExpr s Text) where fromString = QExpr . SQLValE . SqlString-instance (Num a, Convertible a SqlValue) => Num (QExpr a) where- fromInteger x = let res :: QExpr a+instance (Num a, Convertible a SqlValue) => Num (QExpr s a) where+ fromInteger x = let res :: QExpr s a res = val_ (fromInteger x) in res QExpr a + QExpr b = QExpr (SQLBinOpE "+" a b)@@ -57,9 +57,9 @@ negate (QExpr a) = QExpr (SQLUnOpE "-" a) abs (QExpr x) = QExpr (SQLFuncE "ABS" [x]) signum x = error "signum: not defined for QExpr. Use CASE...WHEN"-instance IsString (Aggregation Text) where+instance IsString (Aggregation s Text) where fromString = ProjectAgg . SQLValE . SqlString-instance (Num a, Convertible a SqlValue) => Num (Aggregation a) where+instance (Num a, Convertible a SqlValue) => Num (Aggregation s a) where fromInteger x = ProjectAgg (SQLValE (convert (fromInteger x :: a))) ProjectAgg a + ProjectAgg b = ProjectAgg (SQLBinOpE "+" a b) ProjectAgg a - ProjectAgg b = ProjectAgg (SQLBinOpE "-" a b)@@ -69,19 +69,19 @@ signum x = error "signum: not defined for Aggregation. Use CASE...WHEN" -- | Introduce all entries of a table into the 'Q' monad-all_ :: Database db => DatabaseTable db table -> Q db s (table QExpr)+all_ :: Database db => DatabaseTable db table -> Q db s (table (QExpr s)) all_ tbl = join_ tbl (val_ True) -- | Introduce all entries of a table into the 'Q' monad based on the given SQLExpr-join_ :: Database db => DatabaseTable db table -> QExpr Bool -> Q db s (table QExpr)-join_ (DatabaseTable table name :: DatabaseTable db table) on =+join_ :: Database db => DatabaseTable db table -> QExpr s Bool -> Q db s (table (QExpr s))+join_ (DatabaseTable table name :: DatabaseTable db table) (QExpr on) = do curTbl <- gets qbNextTblRef modify $ \qb@QueryBuilder { qbNextTblRef = curTbl , qbFrom = from , qbWhere = where_ } -> let (from', where') = case from of- Nothing -> (Just newSource, where_ &&. on)- Just from -> ( Just (SQLJoin SQLInnerJoin from newSource (optimizeExpr on)),+ Nothing -> (Just newSource, SQLBinOpE "AND" where_ on)+ Just from -> ( Just (SQLJoin SQLInnerJoin from newSource (optimizeExpr' on)), where_ ) newSource = SQLFromSource (SQLAliased (SQLSourceTable name) (Just (fromString ("t" <> show curTbl)))) in qb { qbNextTblRef = curTbl + 1@@ -91,14 +91,14 @@ let tableSettings :: TableSettings table tableSettings = tblFieldSettings - mkScopedField :: Columnar' (TableField table) a -> Columnar' QExpr a+ mkScopedField :: Columnar' (TableField table) a -> Columnar' (QExpr s) a mkScopedField (Columnar' f) = Columnar' (QExpr (SQLFieldE (QField name (Just curTbl) (_fieldName f)))) pure (changeRep mkScopedField tableSettings) -- | Introduce a table using a left join. Because this is not an inner join, the resulting table is -- made nullable. This means that each field that would normally have type 'QExpr x' will now have -- type 'QExpr (Maybe x)'.-leftJoin_ :: Database db => DatabaseTable db table -> QExpr Bool -> Q db s (table (Nullable QExpr))+leftJoin_ :: Database db => DatabaseTable db table -> QExpr s Bool -> Q db s (table (Nullable (QExpr s))) leftJoin_ (DatabaseTable table name :: DatabaseTable db table) on = do curTbl <- gets qbNextTblRef modify $ \qb@QueryBuilder { qbNextTblRef = curTbl@@ -113,44 +113,44 @@ let tableSettings :: TableSettings table tableSettings = tblFieldSettings - mkScopedField :: Columnar' (TableField table) a -> Columnar' (Nullable QExpr) a+ mkScopedField :: Columnar' (TableField table) a -> Columnar' (Nullable (QExpr s)) a mkScopedField (Columnar' f) = Columnar' (QExpr (SQLFieldE (QField name (Just curTbl) (_fieldName f)))) pure (changeRep mkScopedField tableSettings) -- | Only allow results for which the 'QExpr' yields 'True'-guard_ :: QExpr Bool -> Q db s ()-guard_ guardE' = modify $ \qb@QueryBuilder { qbWhere = guardE } -> qb { qbWhere = guardE &&. guardE' }+guard_ :: QExpr s Bool -> Q db s ()+guard_ (QExpr guardE') = modify $ \qb@QueryBuilder { qbWhere = guardE } -> qb { qbWhere = SQLBinOpE "AND" guardE guardE' } -- | Introduce all entries of the given table which are referenced by the given 'PrimaryKey'-related_ :: (Database db, Table rel) => DatabaseTable db rel -> PrimaryKey rel QExpr -> Q db s (rel QExpr)+related_ :: (Database db, Table rel) => DatabaseTable db rel -> PrimaryKey rel (QExpr s) -> Q db s (rel (QExpr s)) related_ (relTbl :: DatabaseTable db rel) pk = mdo rel <- join_ relTbl (pk ==. primaryKey rel) pure rel -- | Introduce all entries of the given table which for which the expression (which can depend on the queried table returns true)-relatedBy_ :: (Database db, Table rel) => DatabaseTable db rel -> (rel QExpr -> QExpr Bool) -> Q db s (rel QExpr)+relatedBy_ :: (Database db, Table rel) => DatabaseTable db rel -> (rel (QExpr s) -> QExpr s Bool) -> Q db s (rel (QExpr s)) relatedBy_ (relTbl :: DatabaseTable db rel) mkOn = mdo rel <- join_ relTbl (mkOn rel) pure rel -- | Introduce related entries of the given table, or if no related entries exist, introduce the null table-perhapsAll_ :: (Database db, Table rel) => DatabaseTable db rel -> (rel (Nullable QExpr) -> QExpr Bool) -> Q db s (rel (Nullable QExpr))+perhapsAll_ :: (Database db, Table rel) => DatabaseTable db rel -> (rel (Nullable (QExpr s)) -> QExpr s Bool) -> Q db s (rel (Nullable (QExpr s))) perhapsAll_ relTbl expr = mdo rel <- leftJoin_ relTbl (expr rel) pure rel -- | Synonym for 'related_'-lookup_ :: (Database db, Table rel) => DatabaseTable db rel -> PrimaryKey rel QExpr -> Q db s (rel QExpr)+lookup_ :: (Database db, Table rel) => DatabaseTable db rel -> PrimaryKey rel (QExpr s) -> Q db s (rel (QExpr s)) lookup_ = related_ -class SqlReferences f where+class SqlReferences f s where -- | Check that the 'PrimaryKey' given matches the table. Polymorphic so it works over both -- regular tables and those that have been made nullable by 'leftJoin_'.- references_ :: Table tbl => PrimaryKey tbl f -> tbl f -> QExpr Bool-instance SqlReferences QExpr where- references_ pk (tbl :: tbl QExpr) = pk ==. primaryKey tbl-instance SqlReferences (Nullable QExpr) where- references_ pk (tbl :: tbl (Nullable QExpr)) = pk ==. primaryKey tbl+ references_ :: Table tbl => PrimaryKey tbl f -> tbl f -> QExpr s Bool+instance SqlReferences (QExpr s) s where+ references_ pk (tbl :: tbl (QExpr s)) = pk ==. primaryKey tbl+instance SqlReferences (Nullable (QExpr s)) s where+ references_ pk (tbl :: tbl (Nullable (QExpr s))) = pk ==. primaryKey tbl -- | Limit the number of results returned by a query. --@@ -181,45 +181,45 @@ pure res -- | Use the SQL exists operator to determine if the given query returns any results-exists_ :: (IsQuery q, Projectible a) => q db s a -> QExpr Bool+exists_ :: (IsQuery q, Projectible a) => q db s a -> QExpr s Bool exists_ q = let (_, _, selectCmd) = queryToSQL' (toQ q) 0 in QExpr (SQLExistsE selectCmd) -- ** Combinators for boolean expressions -class SqlOrd a where- (==.), (/=.) :: a -> a -> QExpr Bool+class SqlOrd a s where+ (==.), (/=.) :: a -> a -> QExpr s Bool a /=. b = not_ (a ==. b) -instance SqlOrd (QExpr a) where+instance SqlOrd (QExpr s a) s where (==.) = binOpE "==" (/=.) = binOpE "<>" -newtype QExprBool a = QExprBool (QExpr Bool)+newtype QExprBool s a = QExprBool (QExpr s Bool) -instance {-# OVERLAPPING #-} Table tbl => SqlOrd (PrimaryKey tbl QExpr) where- a ==. b = let pkCmp = runIdentity (zipPkM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: PrimaryKey tbl QExprBool+instance {-# OVERLAPPING #-} Table tbl => SqlOrd (PrimaryKey tbl (QExpr s)) s where+ a ==. b = let pkCmp = runIdentity (zipPkM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: PrimaryKey tbl (QExprBool s) in foldr (&&.) (val_ True) (pkAllValues (\(Columnar' (QExprBool x)) -> x) pkCmp)-instance {-# OVERLAPPING #-} Table tbl => SqlOrd (tbl QExpr) where- a ==. b = let tblCmp = runIdentity (zipTablesM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: tbl QExprBool+instance {-# OVERLAPPING #-} Table tbl => SqlOrd (tbl (QExpr s)) s where+ a ==. b = let tblCmp = runIdentity (zipTablesM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: tbl (QExprBool s) in foldr (&&.) (val_ True) (fieldAllValues (\(Columnar' (QExprBool x)) -> x) tblCmp) -instance {-# OVERLAPPING #-} Table tbl => SqlOrd (PrimaryKey tbl (Nullable QExpr)) where- a ==. b = let pkCmp = runIdentity (zipPkM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: PrimaryKey tbl QExprBool+instance {-# OVERLAPPING #-} Table tbl => SqlOrd (PrimaryKey tbl (Nullable (QExpr s))) s where+ a ==. b = let pkCmp = runIdentity (zipPkM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: PrimaryKey tbl (QExprBool s) in foldr (&&.) (val_ True) (pkAllValues (\(Columnar' (QExprBool x)) -> x) pkCmp)-instance {-# OVERLAPPING #-} Table tbl => SqlOrd (tbl (Nullable QExpr)) where- a ==. b = let tblCmp = runIdentity (zipTablesM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: tbl QExprBool+instance {-# OVERLAPPING #-} Table tbl => SqlOrd (tbl (Nullable (QExpr s))) s where+ a ==. b = let tblCmp = runIdentity (zipTablesM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: tbl (QExprBool s) in foldr (&&.) (val_ True) (fieldAllValues (\(Columnar' (QExprBool x)) -> x) tblCmp) binOpE op (QExpr a) (QExpr b) = QExpr (SQLBinOpE op a b) -(<.), (>.), (<=.), (>=.) :: QExpr a -> QExpr a -> QExpr Bool+(<.), (>.), (<=.), (>=.) :: QExpr s a -> QExpr s a -> QExpr s Bool (<.) = binOpE "<" (>.) = binOpE ">" (<=.) = binOpE "<=" (>=.) = binOpE ">=" -(&&.), (||.) :: QExpr Bool -> QExpr Bool -> QExpr Bool+(&&.), (||.) :: QExpr s Bool -> QExpr s Bool -> QExpr s Bool (&&.) = binOpE "AND" (||.) = binOpE "OR" @@ -227,81 +227,81 @@ infixr 2 ||. infix 4 ==., /=. -not_ :: QExpr Bool -> QExpr Bool+not_ :: QExpr s Bool -> QExpr s Bool not_ (QExpr a) = QExpr (SQLUnOpE "NOT" a) -mod_, div_ :: Integral a => QExpr a -> QExpr a -> QExpr a+mod_, div_ :: Integral a => QExpr s a -> QExpr s a -> QExpr s a div_ = binOpE "/" mod_ = binOpE "%" -- * Marshalling between Haskell literals and QExprs type family HaskellLiteralForQExpr x-type instance HaskellLiteralForQExpr (QExpr a) = a-type instance HaskellLiteralForQExpr (table QExpr) = table Identity+type instance HaskellLiteralForQExpr (QExpr s a) = a+type instance HaskellLiteralForQExpr (table (QExpr s)) = table Identity class SqlValable a where val_ :: HaskellLiteralForQExpr a -> a-instance Convertible a SqlValue => SqlValable (QExpr a) where+instance Convertible a SqlValue => SqlValable (QExpr s a) where val_ = QExpr . SQLValE . convert -- NOTE: This shouldn't cause problems because both overlapping instances are in the same module. -- GHC should prefer the PrimaryKey one for primary keys and the table one for everything else. -- AFAICT, PrimaryKey tbl QExpr ~ tbl QExpr is impossible-instance {-# OVERLAPPING #-} Table tbl => SqlValable (PrimaryKey tbl QExpr) where+instance {-# OVERLAPPING #-} Table tbl => SqlValable (PrimaryKey tbl (QExpr s)) where val_ = pkChangeRep valToQExpr . pkMakeSqlValues- where valToQExpr :: Columnar' SqlValue' a -> Columnar' QExpr a+ where valToQExpr :: Columnar' SqlValue' a -> Columnar' (QExpr s) a valToQExpr (Columnar' (SqlValue' v)) = Columnar' (QExpr (SQLValE v))-instance {-# OVERLAPPING #-} Table tbl => SqlValable (tbl QExpr) where+instance {-# OVERLAPPING #-} Table tbl => SqlValable (tbl (QExpr s)) where val_ = changeRep valToQExpr . makeSqlValues- where valToQExpr :: Columnar' SqlValue' a -> Columnar' QExpr a+ where valToQExpr :: Columnar' SqlValue' a -> Columnar' (QExpr s) a valToQExpr (Columnar' (SqlValue' v)) = Columnar' (QExpr (SQLValE v)) -- * Aggregators -class Aggregating agg where- type LiftAggregationsToQExpr agg+class Aggregating agg s | agg -> s where+ type LiftAggregationsToQExpr agg s - aggToSql :: agg -> SQLGrouping- liftAggToQExpr :: agg -> LiftAggregationsToQExpr agg-instance Table t => Aggregating (t Aggregation) where- type LiftAggregationsToQExpr (t Aggregation) = t QExpr- aggToSql table = mconcat (fieldAllValues (\(Columnar' x) -> aggToSql x) table)- liftAggToQExpr = changeRep (\(Columnar' x) -> Columnar' (liftAggToQExpr x))-instance Aggregating (Aggregation a) where- type LiftAggregationsToQExpr (Aggregation a) = QExpr a- aggToSql (GroupAgg e) = let eSql = optimizeExpr' e- in mempty { sqlGroupBy = [eSql] }- aggToSql (ProjectAgg _) = mempty+ aggToSql :: Proxy s -> agg -> SQLGrouping+ liftAggToQExpr :: Proxy s -> agg -> LiftAggregationsToQExpr agg s+instance Table t => Aggregating (t (Aggregation s)) s where+ type LiftAggregationsToQExpr (t (Aggregation s)) s = t (QExpr s)+ aggToSql s table = mconcat (fieldAllValues (\(Columnar' x) -> aggToSql s x) table)+ liftAggToQExpr s = changeRep (\(Columnar' x) -> Columnar' (liftAggToQExpr s x))+instance Aggregating (Aggregation s a) s where+ type LiftAggregationsToQExpr (Aggregation s a) s = QExpr s a+ aggToSql _ (GroupAgg e) = let eSql = optimizeExpr' e+ in mempty { sqlGroupBy = [eSql] }+ aggToSql _ (ProjectAgg _) = mempty - liftAggToQExpr (GroupAgg e) = QExpr e- liftAggToQExpr (ProjectAgg e) = QExpr e-instance (Aggregating a, Aggregating b) => Aggregating (a, b) where- type LiftAggregationsToQExpr (a, b) = ( LiftAggregationsToQExpr a- , LiftAggregationsToQExpr b )- aggToSql (a, b) = aggToSql a <> aggToSql b- liftAggToQExpr (a, b) = (liftAggToQExpr a, liftAggToQExpr b)-instance (Aggregating a, Aggregating b, Aggregating c) => Aggregating (a, b, c) where- type LiftAggregationsToQExpr (a, b, c) = ( LiftAggregationsToQExpr a- , LiftAggregationsToQExpr b- , LiftAggregationsToQExpr c )- aggToSql (a, b, c) = aggToSql a <> aggToSql b <> aggToSql c- liftAggToQExpr (a, b, c) = (liftAggToQExpr a, liftAggToQExpr b, liftAggToQExpr c)-instance (Aggregating a, Aggregating b, Aggregating c, Aggregating d) => Aggregating (a, b, c, d) where- type LiftAggregationsToQExpr (a, b, c, d) = ( LiftAggregationsToQExpr a- , LiftAggregationsToQExpr b- , LiftAggregationsToQExpr c- , LiftAggregationsToQExpr d )- aggToSql (a, b, c, d) = aggToSql a <> aggToSql b <> aggToSql c <> aggToSql d- liftAggToQExpr (a, b, c, d) = (liftAggToQExpr a, liftAggToQExpr b, liftAggToQExpr c, liftAggToQExpr d)-instance (Aggregating a, Aggregating b, Aggregating c, Aggregating d, Aggregating e) => Aggregating (a, b, c, d, e) where- type LiftAggregationsToQExpr (a, b, c, d, e) = ( LiftAggregationsToQExpr a- , LiftAggregationsToQExpr b- , LiftAggregationsToQExpr c- , LiftAggregationsToQExpr d- , LiftAggregationsToQExpr e )- aggToSql (a, b, c, d, e) = aggToSql a <> aggToSql b <> aggToSql c <> aggToSql d <> aggToSql e- liftAggToQExpr (a, b, c, d, e) = (liftAggToQExpr a, liftAggToQExpr b, liftAggToQExpr c, liftAggToQExpr d, liftAggToQExpr e)+ liftAggToQExpr _ (GroupAgg e) = QExpr e+ liftAggToQExpr _ (ProjectAgg e) = QExpr e+instance (Aggregating a s, Aggregating b s) => Aggregating (a, b) s where+ type LiftAggregationsToQExpr (a, b) s = ( LiftAggregationsToQExpr a s+ , LiftAggregationsToQExpr b s)+ aggToSql s (a, b) = aggToSql s a <> aggToSql s b+ liftAggToQExpr s (a, b) = (liftAggToQExpr s a, liftAggToQExpr s b)+instance (Aggregating a s, Aggregating b s, Aggregating c s) => Aggregating (a, b, c) s where+ type LiftAggregationsToQExpr (a, b, c) s = ( LiftAggregationsToQExpr a s+ , LiftAggregationsToQExpr b s+ , LiftAggregationsToQExpr c s )+ aggToSql s (a, b, c) = aggToSql s a <> aggToSql s b <> aggToSql s c+ liftAggToQExpr s (a, b, c) = (liftAggToQExpr s a, liftAggToQExpr s b, liftAggToQExpr s c)+instance (Aggregating a s, Aggregating b s, Aggregating c s, Aggregating d s) => Aggregating (a, b, c, d) s where+ type LiftAggregationsToQExpr (a, b, c, d) s = ( LiftAggregationsToQExpr a s+ , LiftAggregationsToQExpr b s+ , LiftAggregationsToQExpr c s+ , LiftAggregationsToQExpr d s)+ aggToSql s (a, b, c, d) = aggToSql s a <> aggToSql s b <> aggToSql s c <> aggToSql s d+ liftAggToQExpr s (a, b, c, d) = (liftAggToQExpr s a, liftAggToQExpr s b, liftAggToQExpr s c, liftAggToQExpr s d)+instance (Aggregating a s, Aggregating b s, Aggregating c s, Aggregating d s, Aggregating e s) => Aggregating (a, b, c, d, e) s where+ type LiftAggregationsToQExpr (a, b, c, d, e) s = ( LiftAggregationsToQExpr a s+ , LiftAggregationsToQExpr b s+ , LiftAggregationsToQExpr c s+ , LiftAggregationsToQExpr d s+ , LiftAggregationsToQExpr e s)+ aggToSql s (a, b, c, d, e) = aggToSql s a <> aggToSql s b <> aggToSql s c <> aggToSql s d <> aggToSql s e+ liftAggToQExpr s (a, b, c, d, e) = (liftAggToQExpr s a, liftAggToQExpr s b, liftAggToQExpr s c, liftAggToQExpr s d, liftAggToQExpr s e) -- | Type class for things that can be used as the basis of a grouping in a SQL GROUP BY -- clause. This includes 'QExpr a', 'Table's, and 'PrimaryKey's. Because the given object forms the@@ -312,20 +312,20 @@ -- | When included in an 'Aggregating' expression, causes the results to be grouped by the -- given column. group_ :: a -> GroupResult a-instance SqlGroupable (QExpr a) where- type GroupResult (QExpr a) = Aggregation a+instance SqlGroupable (QExpr s a) where+ type GroupResult (QExpr s a) = Aggregation s a group_ (QExpr a) = GroupAgg a-instance {-# OVERLAPPING #-} Table t => SqlGroupable (PrimaryKey t QExpr) where- type GroupResult (PrimaryKey t QExpr) = PrimaryKey t Aggregation+instance {-# OVERLAPPING #-} Table t => SqlGroupable (PrimaryKey t (QExpr s)) where+ type GroupResult (PrimaryKey t (QExpr s)) = PrimaryKey t (Aggregation s) group_ = pkChangeRep (\(Columnar' (QExpr e)) -> Columnar' (GroupAgg e))-instance {-# OVERLAPPING #-} Table t => SqlGroupable (t QExpr) where- type GroupResult (t QExpr) = t Aggregation+instance {-# OVERLAPPING #-} Table t => SqlGroupable (t (QExpr s)) where+ type GroupResult (t (QExpr s)) = t (Aggregation s) group_ = changeRep (\(Columnar' (QExpr e)) -> Columnar' (GroupAgg e)) -sum_ :: Num a => QExpr a -> Aggregation a+sum_ :: Num a => QExpr s a -> Aggregation s a sum_ (QExpr over) = ProjectAgg (SQLFuncE "SUM" [over]) -count_ :: QExpr a -> Aggregation Int+count_ :: QExpr s a -> Aggregation s Int count_ (QExpr over) = ProjectAgg (SQLFuncE "COUNT" [over]) -- | Return a 'TopLevelQ' that will aggregate over the results of the original query. The@@ -339,20 +339,20 @@ -- -- will group the result of the `all_ employeesTable` query using the `_employeeRegion` record -- field, and then count up the number of employees for each region.-aggregate :: (Projectible a, Aggregating agg) => (a -> agg) -> (forall s. Q db s a) -> TopLevelQ db s (LiftAggregationsToQExpr agg)-aggregate aggregator q =+aggregate :: (Projectible a, Aggregating agg s) => (a -> agg) -> Q db s a -> TopLevelQ db s (LiftAggregationsToQExpr agg s)+aggregate (aggregator :: a -> agg) (q :: Q db s a) = TopLevelQ $ do res <- q curTbl <- gets qbNextTblRef let aggregation = aggregator res- grouping' = aggToSql aggregation+ grouping' = aggToSql (Proxy :: Proxy s) aggregation modify $ \qb -> case sqlGroupBy grouping' of [] -> qb _ -> case qbGrouping qb of Nothing -> qb { qbGrouping = Just grouping' } Just grouping -> qb { qbGrouping = Just (grouping <> grouping') }- pure (liftAggToQExpr aggregation)+ pure (liftAggToQExpr (Proxy :: Proxy s) aggregation) -- * Order bys @@ -390,79 +390,86 @@ modify $ \qb -> qb { qbOrdering = qbOrdering qb <> ordering } pure res -desc_, asc_ :: QExpr a -> SQLOrdering+desc_, asc_ :: QExpr s a -> SQLOrdering asc_ e = Asc (optimizeExpr e) desc_ e = Desc (optimizeExpr e) -- * Subqueries -class Subqueryable a where- subqueryProjections :: a -> RWS (Text, Int) [SQLAliased SQLExpr] Int a-instance Subqueryable (QExpr a) where- subqueryProjections e =+class Subqueryable a s | a -> s where+ type Unnested a s+ subqueryProjections :: Proxy s -> a -> RWS (Text, Int) [SQLAliased SQLExpr] Int (Unnested a s)+instance Subqueryable (QExpr (QNested s) a) s where+ type Unnested (QExpr (QNested s) a) s = QExpr s a+ subqueryProjections s e = do i <- state (\i -> (i, i+1)) (tblName, tblOrd) <- ask let fieldName = fromString ("e" <> show i) tell [SQLAliased (optimizeExpr e) (Just fieldName)] pure (QExpr (SQLFieldE (QField tblName (Just tblOrd) fieldName)))-instance ( Subqueryable a- , Subqueryable b ) =>- Subqueryable (a, b) where- subqueryProjections (a, b) =- (,) <$> subqueryProjections a- <*> subqueryProjections b-instance ( Subqueryable a- , Subqueryable b- , Subqueryable c ) =>- Subqueryable (a, b, c) where- subqueryProjections (a, b, c) =- (,,) <$> subqueryProjections a- <*> subqueryProjections b- <*> subqueryProjections c-instance ( Subqueryable a- , Subqueryable b- , Subqueryable c- , Subqueryable d ) =>- Subqueryable (a, b, c, d) where- subqueryProjections (a, b, c, d) =- (,,,) <$> subqueryProjections a- <*> subqueryProjections b- <*> subqueryProjections c- <*> subqueryProjections d-instance ( Subqueryable a- , Subqueryable b- , Subqueryable c- , Subqueryable d- , Subqueryable e ) =>- Subqueryable (a, b, c, d, e) where- subqueryProjections (a, b, c, d, e) =- (,,,,) <$> subqueryProjections a- <*> subqueryProjections b- <*> subqueryProjections c- <*> subqueryProjections d- <*> subqueryProjections e+instance ( Subqueryable a s+ , Subqueryable b s ) =>+ Subqueryable (a, b) s where+ type Unnested (a, b) s = (Unnested a s, Unnested b s)+ subqueryProjections s (a, b) =+ (,) <$> subqueryProjections s a+ <*> subqueryProjections s b+instance ( Subqueryable a s+ , Subqueryable b s+ , Subqueryable c s ) =>+ Subqueryable (a, b, c) s where+ type Unnested (a, b, c) s = (Unnested a s, Unnested b s, Unnested c s)+ subqueryProjections s (a, b, c) =+ (,,) <$> subqueryProjections s a+ <*> subqueryProjections s b+ <*> subqueryProjections s c+instance ( Subqueryable a s+ , Subqueryable b s+ , Subqueryable c s+ , Subqueryable d s ) =>+ Subqueryable (a, b, c, d) s where+ type Unnested (a, b, c, d) s = (Unnested a s, Unnested b s, Unnested c s, Unnested d s)+ subqueryProjections s (a, b, c, d) =+ (,,,) <$> subqueryProjections s a+ <*> subqueryProjections s b+ <*> subqueryProjections s c+ <*> subqueryProjections s d+instance ( Subqueryable a s+ , Subqueryable b s+ , Subqueryable c s+ , Subqueryable d s+ , Subqueryable e s ) =>+ Subqueryable (a, b, c, d, e) s where+ type Unnested (a, b, c, d, e) s = (Unnested a s, Unnested b s, Unnested c s, Unnested d s, Unnested e s)+ subqueryProjections s (a, b, c, d, e) =+ (,,,,) <$> subqueryProjections s a+ <*> subqueryProjections s b+ <*> subqueryProjections s c+ <*> subqueryProjections s d+ <*> subqueryProjections s e -- | Run the given 'Q'-like object as a subquery, joining the results with the current result -- set. This allows embedding of 'TopLevelQ's inside 'Q's or other 'TopLevelQ's.-subquery_ :: (IsQuery q, Projectible a, Subqueryable a) => (forall s. q db s a) -> Q db s a-subquery_ q = do curTbl <- gets qbNextTblRef+subquery_ :: (IsQuery q, Projectible a, Subqueryable a s) => q db (QNested s) a -> Q db s (Unnested a s)+subquery_ (q :: q db (QNested s) a) =+ do curTbl <- gets qbNextTblRef - let (res, curTbl', select') = queryToSQL' (toQ q) curTbl+ let (res, curTbl', select') = queryToSQL' (toQ q) curTbl - subTblName = fromString ("t" <> show curTbl)- (res', projection') = evalRWS (subqueryProjections res) (subTblName, curTbl') 0+ subTblName = fromString ("t" <> show curTbl)+ (res', projection') = evalRWS (subqueryProjections (Proxy :: Proxy s) res) (subTblName, curTbl') 0 - select'' = select' { selProjection = SQLProj projection' }+ select'' = select' { selProjection = SQLProj projection' } - modify $ \qb@QueryBuilder { qbFrom = from } ->- let from' = case from of- Nothing -> Just newSource- Just from -> Just (SQLJoin SQLInnerJoin from newSource (SQLValE (SqlBool True)))- newSource = SQLFromSource (SQLAliased (SQLSourceSelect select'') (Just (fromString ("t" <> show curTbl'))))- in qb { qbNextTblRef = curTbl' + 1- , qbFrom = from' }+ modify $ \qb@QueryBuilder { qbFrom = from } ->+ let from' = case from of+ Nothing -> Just newSource+ Just from -> Just (SQLJoin SQLInnerJoin from newSource (SQLValE (SqlBool True)))+ newSource = SQLFromSource (SQLAliased (SQLSourceSelect select'') (Just (fromString ("t" <> show curTbl'))))+ in qb { qbNextTblRef = curTbl' + 1+ , qbFrom = from' } - pure res'+ pure res' -- * Nullable conversions @@ -479,15 +486,15 @@ -- 'PrimaryKey' filled with 'Nothing'. nothing_ :: b -instance SqlJustable (QExpr a) (QExpr (Maybe a)) where+instance SqlJustable (QExpr s a) (QExpr s (Maybe a)) where just_ (QExpr e) = QExpr e nothing_ = QExpr (SQLValE SqlNull) -instance {-# OVERLAPPING #-} Table t => SqlJustable (PrimaryKey t QExpr) (PrimaryKey t (Nullable QExpr)) where+instance {-# OVERLAPPING #-} Table t => SqlJustable (PrimaryKey t (QExpr s)) (PrimaryKey t (Nullable (QExpr s))) where just_ = pkChangeRep (\(Columnar' q) -> Columnar' (just_ q)) nothing_ = pkChangeRep (\(Columnar' q) -> Columnar' nothing_) (primaryKey (tblFieldSettings :: TableSettings t)) -instance {-# OVERLAPPING #-} Table t => SqlJustable (t QExpr) (t (Nullable QExpr)) where+instance {-# OVERLAPPING #-} Table t => SqlJustable (t (QExpr s)) (t (Nullable (QExpr s))) where just_ = changeRep (\(Columnar' q) -> Columnar' (just_ q)) nothing_ = changeRep (\(Columnar' q) -> Columnar' nothing_) (tblFieldSettings :: TableSettings t) @@ -503,42 +510,42 @@ -- | Type class for anything which can be checked for null-ness. This includes 'QExpr (Maybe a)' as -- well as 'Table's or 'PrimaryKey's over 'Nullable QExpr'.-class SqlDeconstructMaybe a nonNullA | a -> nonNullA where+class SqlDeconstructMaybe a nonNullA s | a -> nonNullA, a -> s, nonNullA -> s where -- | Returns a 'QExpr' that evaluates to true when the first argument is not null- isJust_ :: a -> QExpr Bool+ isJust_ :: a -> QExpr s Bool -- | Returns a 'QExpr' that evaluates to true when the first argument is null- isNothing_ :: a -> QExpr Bool+ isNothing_ :: a -> QExpr s Bool -- | Given an object (third argument) which may or may not be null, return the default value if -- null (first argument), or transform the value that could be null to yield the result of the -- expression (second argument)- maybe_ :: QExpr y -> (nonNullA -> QExpr y) -> a -> QExpr y+ maybe_ :: QExpr s y -> (nonNullA -> QExpr s y) -> a -> QExpr s y -instance SqlDeconstructMaybe (QExpr (Maybe x)) (QExpr x) where+instance SqlDeconstructMaybe (QExpr s (Maybe x)) (QExpr s x) s where isJust_ (QExpr x) = QExpr (SQLIsJustE x) isNothing_ (QExpr x) = QExpr (SQLIsNothingE x) maybe_ (QExpr onNothing) onJust (QExpr e) = let QExpr onJust' = onJust (QExpr e) in QExpr (SQLCaseE [(SQLIsJustE e, onJust')] onNothing) -instance {-# OVERLAPPING #-} Table t => SqlDeconstructMaybe (PrimaryKey t (Nullable QExpr)) (PrimaryKey t QExpr) where- isJust_ pk = let fieldsAreJust = pkChangeRep (\(Columnar' x) -> Columnar' (QExprBool (isJust_ x))) pk :: PrimaryKey t QExprBool+instance {-# OVERLAPPING #-} Table t => SqlDeconstructMaybe (PrimaryKey t (Nullable (QExpr s))) (PrimaryKey t (QExpr s)) s where+ isJust_ pk = let fieldsAreJust = pkChangeRep (\(Columnar' x) -> Columnar' (QExprBool (isJust_ x))) pk :: PrimaryKey t (QExprBool s) in foldr (&&.) (val_ True) (pkAllValues (\(Columnar' (QExprBool e)) -> e) fieldsAreJust)- isNothing_ pk = let fieldsAreNothing = pkChangeRep (\(Columnar' x) -> Columnar' (QExprBool (isNothing_ x))) pk :: PrimaryKey t QExprBool+ isNothing_ pk = let fieldsAreNothing = pkChangeRep (\(Columnar' x) -> Columnar' (QExprBool (isNothing_ x))) pk :: PrimaryKey t (QExprBool s) in foldr (&&.) (val_ True) (pkAllValues (\(Columnar' (QExprBool e)) -> e) fieldsAreNothing) maybe_ = undefined -instance {-# OVERLAPPING #-} Table t => SqlDeconstructMaybe (t (Nullable QExpr)) (t QExpr) where- isJust_ t = let fieldsAreJust = changeRep (\(Columnar' x) -> Columnar' (QExprBool (isJust_ x))) t :: t QExprBool+instance {-# OVERLAPPING #-} Table t => SqlDeconstructMaybe (t (Nullable (QExpr s))) (t (QExpr s)) s where+ isJust_ t = let fieldsAreJust = changeRep (\(Columnar' x) -> Columnar' (QExprBool (isJust_ x))) t :: t (QExprBool s) in foldr (&&.) (val_ True) (fieldAllValues (\(Columnar' (QExprBool e)) -> e) fieldsAreJust)- isNothing_ t = let fieldsAreNothing = changeRep (\(Columnar' x) -> Columnar' (QExprBool (isNothing_ x))) t :: t QExprBool+ isNothing_ t = let fieldsAreNothing = changeRep (\(Columnar' x) -> Columnar' (QExprBool (isNothing_ x))) t :: t (QExprBool s) in foldr (&&.) (val_ True) (fieldAllValues (\(Columnar' (QExprBool e)) -> e) fieldsAreNothing) maybe_ = undefined class BeamUnwrapMaybe c where beamUnwrapMaybe :: Columnar' (Nullable c) x -> Columnar' c x-instance BeamUnwrapMaybe QExpr where+instance BeamUnwrapMaybe (QExpr s) where beamUnwrapMaybe (Columnar' (QExpr e)) = Columnar' (QExpr e) instance BeamUnwrapMaybe c => BeamUnwrapMaybe (Nullable c) where beamUnwrapMaybe (Columnar' x :: Columnar' (Nullable (Nullable c)) x) =@@ -548,12 +555,12 @@ xCol = Columnar' x' in xCol -instance {-# OVERLAPPING #-} ( SqlDeconstructMaybe (PrimaryKey t (Nullable c)) res, Table t, BeamUnwrapMaybe (Nullable c)) => SqlDeconstructMaybe (PrimaryKey t (Nullable (Nullable c))) res where+instance {-# OVERLAPPING #-} ( SqlDeconstructMaybe (PrimaryKey t (Nullable c)) res s, Table t, BeamUnwrapMaybe (Nullable c)) => SqlDeconstructMaybe (PrimaryKey t (Nullable (Nullable c))) res s where isJust_ t = isJust_ (pkChangeRep (\(f :: Columnar' (Nullable (Nullable c)) x) -> beamUnwrapMaybe f :: Columnar' (Nullable c) x) t) isNothing_ t = isNothing_ (pkChangeRep (\(f :: Columnar' (Nullable (Nullable c)) x) -> beamUnwrapMaybe f :: Columnar' (Nullable c) x) t) maybe_ = undefined -instance {-# OVERLAPPING #-} ( SqlDeconstructMaybe (t (Nullable c)) res, Table t, BeamUnwrapMaybe (Nullable c)) => SqlDeconstructMaybe (t (Nullable (Nullable c))) res where+instance {-# OVERLAPPING #-} ( SqlDeconstructMaybe (t (Nullable c)) res s, Table t, BeamUnwrapMaybe (Nullable c)) => SqlDeconstructMaybe (t (Nullable (Nullable c))) res s where isJust_ t = isJust_ (changeRep (\(f :: Columnar' (Nullable (Nullable c)) x) -> beamUnwrapMaybe f :: Columnar' (Nullable c) x) t) isNothing_ t = isNothing_ (changeRep (\(f :: Columnar' (Nullable (Nullable c)) x) -> beamUnwrapMaybe f :: Columnar' (Nullable c) x) t) maybe_ = undefined
src/Database/Beam/Query/Internal.hs view
@@ -29,10 +29,12 @@ -- directly to 'query' or 'queryList' newtype TopLevelQ db s a = TopLevelQ (Q db s a) +data QNested s+ data QueryBuilder = QueryBuilder { qbNextTblRef :: Int , qbFrom :: Maybe SQLFrom- , qbWhere :: QExpr Bool+ , qbWhere :: SQLExpr' QField , qbLimit :: Maybe Integer , qbOffset :: Maybe Integer@@ -50,13 +52,13 @@ -- | The type of lifted beam expressions that will yield the haskell type `t` when run with -- `queryList` or `query`. In the future, this will include a thread argument meant to prevent -- cross-usage of expressions, but this is unimplemented for technical reasons.-newtype QExpr t = QExpr (SQLExpr' QField)+newtype QExpr s t = QExpr (SQLExpr' QField) deriving (Show, Eq) -- * Aggregations -data Aggregation a = GroupAgg (SQLExpr' QField)- | ProjectAgg (SQLExpr' QField)+data Aggregation s a = GroupAgg (SQLExpr' QField)+ | ProjectAgg (SQLExpr' QField) -- * Sql Projections --@@ -67,7 +69,7 @@ class Projectible a where project :: a -> [SQLExpr' QField]-instance Typeable a => Projectible (QExpr a) where+instance Typeable a => Projectible (QExpr s a) where project (QExpr x) = [x] instance Projectible () where project () = [SQLValE (SqlInteger 1)]@@ -89,12 +91,12 @@ , Projectible e ) => Projectible (a, b, c, d, e) where project (a, b, c, d, e) = project a ++ project b ++ project c ++ project d ++ project e -instance Table t => Projectible (t QExpr) where+instance Table t => Projectible (t (QExpr s)) where project t = fieldAllValues (\(Columnar' (QExpr e)) -> e) t-instance Table t => Projectible (t (Nullable QExpr)) where+instance Table t => Projectible (t (Nullable (QExpr s))) where project t = fieldAllValues (\(Columnar' (QExpr e)) -> e) t -tableVal :: Table tbl => tbl Identity -> tbl QExpr+tableVal :: Table tbl => tbl Identity -> tbl (QExpr s) tableVal = changeRep valToQExpr . makeSqlValues- where valToQExpr :: Columnar' SqlValue' a -> Columnar' QExpr a+ where valToQExpr :: Columnar' SqlValue' a -> Columnar' (QExpr s) a valToQExpr (Columnar' (SqlValue' v)) = Columnar' (QExpr (SQLValE v))
src/Database/Beam/Query/Types.hs view
@@ -36,9 +36,9 @@ -- * Beam queries type family QExprToIdentity x-type instance QExprToIdentity (table QExpr) = table Identity+type instance QExprToIdentity (table (QExpr s)) = table Identity type instance QExprToIdentity (table (Nullable c)) = Maybe (QExprToIdentity (table c))-type instance QExprToIdentity (QExpr a) = a+type instance QExprToIdentity (QExpr s a) = a type instance QExprToIdentity (a, b) = (QExprToIdentity a, QExprToIdentity b) type instance QExprToIdentity (a, b, c) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c) type instance QExprToIdentity (a, b, c, d) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d)@@ -73,7 +73,7 @@ optimizeExpr' = runIdentity . rewriteM allExprOpts . fmap mkSqlField -- | Optimize a `QExpr` and turn it in into a `SQLExpr`.-optimizeExpr :: QExpr a -> SQLExpr+optimizeExpr :: QExpr s a -> SQLExpr optimizeExpr (QExpr e) = optimizeExpr' e mkSqlField :: QField -> SQLFieldName@@ -83,13 +83,13 @@ -- | Turn a `Q` into a `SQLSelect` starting the table references at the given number queryToSQL' :: Projectible a => Q db s a -> Int -> (a, Int, SQLSelect) queryToSQL' q curTbl = let (res, qb) = runState (runQ q) emptyQb- emptyQb = QueryBuilder curTbl Nothing (QExpr (SQLValE (SqlBool True))) Nothing Nothing [] Nothing+ emptyQb = QueryBuilder curTbl Nothing (SQLValE (SqlBool True)) Nothing Nothing [] Nothing projection = map (\q -> SQLAliased (optimizeExpr' q) Nothing) (project res) sel = SQLSelect { selProjection = SQLProj projection , selFrom = qbFrom qb- , selWhere = optimizeExpr (qbWhere qb)+ , selWhere = optimizeExpr' (qbWhere qb) , selGrouping = qbGrouping qb , selOrderBy = qbOrdering qb , selLimit = qbLimit qb