beam 0.3.0.0 → 0.3.1.0
raw patch · 11 files changed
+571/−450 lines, 11 files
Files
- beam.cabal +9/−2
- src/Database/Beam.hs +2/−2
- src/Database/Beam/Backend.hs +13/−4
- src/Database/Beam/Query.hs +23/−22
- src/Database/Beam/Query/Combinators.hs +225/−35
- src/Database/Beam/Query/Internal.hs +21/−5
- src/Database/Beam/Query/Types.hs +25/−47
- src/Database/Beam/SQL.hs +10/−12
- src/Database/Beam/SQL/Types.hs +12/−8
- src/Database/Beam/Schema/Fields.hs +83/−63
- src/Database/Beam/Schema/Tables.hs +148/−250
beam.cabal view
@@ -2,10 +2,10 @@ -- see http://haskell.org/cabal/users-guide/ name: beam-version: 0.3.0.0+version: 0.3.1.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+homepage: http://travis.athougies.net/projects/beam.html license: MIT license-file: LICENSE author: Travis Athougies@@ -15,7 +15,9 @@ build-type: Simple -- extra-source-files: cabal-version: >=1.18+bug-reports: https://github.com/tathougies/beam/issues + library exposed-modules: Database.Beam Database.Beam.Backend Database.Beam.SQL Database.Beam.Query@@ -36,3 +38,8 @@ default-extensions: ScopedTypeVariables, OverloadedStrings, GADTs, RecursiveDo, FlexibleInstances, FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving, RankNTypes, TupleSections, ConstraintKinds, StandaloneDeriving, TypeOperators, DefaultSignatures, KindSignatures, MultiParamTypeClasses, DeriveGeneric, DeriveFunctor, DeriveDataTypeable++source-repository head+ type: git+ location: https://github.com/tathougies/beam.git+
src/Database/Beam.hs view
@@ -13,9 +13,9 @@ -- -- * [Beam tutorial (part 1)](http://travis.athougies.net/posts/2016-01-21-beam-tutorial-1.html) -- * [Beam tutorial (part 2)](http://travis.athougies.net/posts/2016-01-22-beam-tutorial-part-2.html)+-- * [Beam tutorial (part 3)](http://travis.athougies.net/posts/2016-01-25-beam-tutorial-part-3.html) module Database.Beam- ( module Database.Beam.SQL- , module Database.Beam.Query+ ( module Database.Beam.Query , module Database.Beam.Schema , module Database.Beam.Backend
src/Database/Beam/Backend.hs view
@@ -22,6 +22,13 @@ import Database.HDBC +-- | Passed to 'openDatabase' or 'openDatabaseDebug' to specify+-- whether you want beam to automatically attempt to make the database+-- schema match the haskell schema.+data MigrationStrategy = DontMigrate+ | AutoMigrate+ deriving Show+ instance Monoid DBSchemaComparison where mappend (Migration a) (Migration b) = Migration (a <> b) mappend _ Unknown = Unknown@@ -95,15 +102,17 @@ migrateDB db beam actions Unknown -> when (beamDebug beam) (liftIO $ putStrLn "Unknown comparison") -openDatabaseDebug, openDatabase :: (BeamBackend dbSettings, MonadIO m, Database db) => DatabaseSettings db -> dbSettings -> m (Beam db m)+openDatabaseDebug, openDatabase :: (BeamBackend dbSettings, MonadIO m, Database db) => DatabaseSettings db -> MigrationStrategy -> dbSettings -> m (Beam db m) openDatabase = openDatabase' False openDatabaseDebug = openDatabase' True -openDatabase' :: (BeamBackend dbSettings, MonadIO m, Database db) => Bool -> DatabaseSettings db -> dbSettings -> m (Beam db m)-openDatabase' isDebug db dbSettings =+openDatabase' :: (BeamBackend dbSettings, MonadIO m, Database db) => Bool -> DatabaseSettings db -> MigrationStrategy -> dbSettings -> m (Beam db m)+openDatabase' isDebug db strat dbSettings = do beam <- openBeam db dbSettings let beam' = beam { beamDebug = isDebug }- autoMigrateDB db beam'+ case strat of+ DontMigrate -> pure ()+ AutoMigrate -> autoMigrateDB db beam' return beam'
src/Database/Beam/Query.hs view
@@ -1,8 +1,12 @@ {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Database.Beam.Query- ( module Database.Beam.Query.Types+ ( -- * Query type+ module Database.Beam.Query.Types++ -- * General query combinators , module Database.Beam.Query.Combinators + -- * Run queries in MonadIO , beamTxn, insertInto, query, queryList, getOne , updateWhere, saveTo , deleteWhere, deleteFrom )@@ -85,6 +89,7 @@ else return sqlValues return (fromSqlValues insertedValues) +-- | Insert the given row value into the table specified by the first argument. insertInto :: (MonadIO m, Functor m, Table table, FromSqlValues (table Identity)) => DatabaseTable db table -> table Identity -> BeamT e db m (table Identity) insertInto (DatabaseTable _ name) data_ =@@ -112,6 +117,8 @@ , uAssignments = assignments , uWhere = where_' } +-- | 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 tbl@(DatabaseTable _ name :: DatabaseTable db tbl) mkAssignments mkWhere = do let assignments = mkAssignments tblExprs@@ -128,11 +135,13 @@ do liftIO (runSQL' (beamDebug beam) conn updateCmd) pure (Success ()) +-- | Use the 'PrimaryKey' of the given table entry to update the corresponding table row in the+-- database. saveTo :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> tbl Identity -> BeamT e db m () saveTo tbl (newValues :: tbl Identity) = 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 (DatabaseTable _ name :: DatabaseTable db tbl) mkWhere = let tblExprs = changeRep (\(Columnar' fieldS) -> Columnar' (QExpr (SQLFieldE (QField name Nothing (_fieldName fieldS))))) (tblFieldSettings :: TableSettings tbl)@@ -147,11 +156,15 @@ do liftIO (runSQL' (beamDebug beam) conn cmd) pure (Success ()) +-- | Delete the entry referenced by the given 'PrimaryKey' in the given table. deleteFrom :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> PrimaryKey tbl Identity -> BeamT e db m () deleteFrom tbl pkToDelete = deleteWhere tbl (\tbl -> primaryKey tbl ==. val_ pkToDelete) -- * BeamT actions +-- | Run the 'BeamT' action in a database transaction. On successful+-- completion, the transaction will be committed. Use 'throwError' to+-- stop the transaction and report an error. beamTxn :: MonadIO m => Beam db m -> (DatabaseSettings db -> BeamT e db m a) -> m (BeamResult e a) beamTxn beam action = do res <- runBeamT (action (beamDbSettings beam)) beam withHDBCConnection beam $@@ -169,7 +182,8 @@ , IsQuery q ) => (forall s. q db s a) -> Beam db m -> m (Either String (Source m (QExprToIdentity a))) runQuery q beam =- do let selectCmd = Select (snd (queryToSQL' (toQ q)))+ do let selectCmd = Select select+ (_, _, select) = queryToSQL' (toQ q) 0 res <- withHDBCConnection beam $ \conn -> liftIO $ runSQL' (beamDebug beam) conn selectCmd@@ -186,6 +200,8 @@ Nothing -> return () return (Right source) +-- | 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 q = BeamT $ \beam -> do res <- runQuery q beam@@ -193,10 +209,14 @@ Right x -> return (Success (transPipe (BeamT . const . fmap Success) x)) Left err -> return (Rollback (InternalError err)) +-- | 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 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 q = do let justOneSink = await >>= \x ->@@ -216,22 +236,3 @@ (Right a, []) -> Right a (Right _, _) -> Left "fromSqlValues: Not all values were consumed" (Left err, _) -> Left err---- * Generic combinators---- ref :: Table t => t c -> ForeignKey t c--- ref = ForeignKey . primaryKey--- justRef :: Table related =>--- related Identity -> ForeignKey related (Nullable Identity)--- justRef (e :: related Identity) = ForeignKey (pkChangeRep (Proxy :: Proxy related) just (primaryKey e))--- where just :: Columnar' Identity a -> Columnar' (Nullable Identity) a--- just (Columnar' x) = Columnar' (Just (unsafeCoerce x)) -- TODO : Why is unsafecoerce necessary here?---- nothingRef :: Table related =>--- Query db (related Identity) -> ForeignKey related (Nullable Identity)--- nothingRef (_ :: Query db (related Identity)) = ForeignKey (pkChangeRep (Proxy :: Proxy related) nothing (primaryKey fieldSettings))--- where nothing :: Columnar' (TableField related) a -> Columnar' (Nullable Identity) a--- nothing x = Columnar' Nothing---- fieldSettings :: TableSettings related--- fieldSettings = tblFieldSettings
src/Database/Beam/Query/Combinators.hs view
@@ -1,19 +1,28 @@-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances, FunctionalDependencies #-} module Database.Beam.Query.Combinators- ( all_, join_, guard_, related_, lookup_- , references_+ ( all_, join_, guard_, related_, relatedBy_, lookup_+ , leftJoin_, perhapsAll_+ , SqlReferences(..)+ , SqlJustable(..)+ , SqlDeconstructMaybe(..)+ , SqlOrderable , limit_, offset_ + , exists_+ , (<.), (>.), (<=.), (>=.), (==.), (&&.), (||.), not_, div_, mod_ , HaskellLiteralForQExpr(..), SqlValable(..)- , enum_ - , aggregate- , group_, sum_, count_+ -- * SQL GROUP BY and aggregation+ , aggregate, SqlGroupable(..)+ , sum_, count_ + -- * SQL ORDER BY , orderBy, asc_, desc_ ++ -- * SQL subqueries , subquery_ ) where import Database.Beam.Query.Internal@@ -31,6 +40,7 @@ import Data.Monoid import Data.String import Data.Maybe+import Data.Proxy import Data.Convertible import Data.Text (Text) import Data.Coerce@@ -47,6 +57,16 @@ 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+ fromString = ProjectAgg . SQLValE . SqlString+instance (Num a, Convertible a SqlValue) => Num (Aggregation 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)+ ProjectAgg a * ProjectAgg b = ProjectAgg (SQLBinOpE "*" a b)+ negate (ProjectAgg a) = ProjectAgg (SQLUnOpE "-" a)+ abs (ProjectAgg x) = ProjectAgg (SQLFuncE "ABS" [x])+ 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)@@ -75,21 +95,62 @@ 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_ (DatabaseTable table name :: DatabaseTable db table) on =+ do curTbl <- gets qbNextTblRef+ modify $ \qb@QueryBuilder { qbNextTblRef = curTbl+ , qbFrom = from } ->+ let from' = case from of+ Nothing -> error "leftJoin_: empty select source"+ Just from -> SQLJoin SQLLeftJoin from newSource (optimizeExpr on)+ newSource = SQLFromSource (SQLAliased (SQLSourceTable name) (Just (fromString ("t" <> show curTbl))))+ in qb { qbNextTblRef = curTbl + 1+ , qbFrom = Just from' }++ let tableSettings :: TableSettings table+ tableSettings = tblFieldSettings++ mkScopedField :: Columnar' (TableField table) a -> Columnar' (Nullable QExpr) 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' } --- | Introduce all entries of the given table which are referenced by the given 'ForeignKey'+-- | 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_ (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_ (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_ 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_ = related_ -references_ :: Table tbl => PrimaryKey tbl QExpr -> tbl QExpr -> QExpr Bool-references_ pk (tbl :: tbl QExpr) = pk ==. primaryKey tbl+class SqlReferences f 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 -- | Limit the number of results returned by a query. --@@ -119,29 +180,37 @@ in qb { qbOffset = qbOffset' } 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_ q = let (_, _, selectCmd) = queryToSQL' (toQ q) 0+ in QExpr (SQLExistsE selectCmd)+ -- ** Combinators for boolean expressions class SqlOrd a where- decomposeToGenQExprs :: a -> [SQLExpr' QField] (==.), (/=.) :: a -> a -> QExpr Bool- a ==. b = let aExprs = decomposeToGenQExprs a- bExprs = decomposeToGenQExprs b-- combine :: SQLExpr' QField -> SQLExpr' QField -> QExpr Bool- combine a b = QExpr a ==. QExpr b- in foldr (&&.) (val_ True) (zipWith combine aExprs bExprs) a /=. b = not_ (a ==. b) instance SqlOrd (QExpr a) where- decomposeToGenQExprs (QExpr e) = [e] (==.) = binOpE "==" (/=.) = binOpE "<>" +newtype QExprBool a = QExprBool (QExpr Bool)+ instance {-# OVERLAPPING #-} Table tbl => SqlOrd (PrimaryKey tbl QExpr) where- decomposeToGenQExprs = pkAllValues (\(Columnar' (QExpr e)) -> e)+ a ==. b = let pkCmp = runIdentity (zipPkM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: PrimaryKey tbl QExprBool+ in foldr (&&.) (val_ True) (pkAllValues (\(Columnar' (QExprBool x)) -> x) pkCmp) instance {-# OVERLAPPING #-} Table tbl => SqlOrd (tbl QExpr) where- decomposeToGenQExprs = fieldAllValues (\(Columnar' (QExpr e)) -> e)+ a ==. b = let tblCmp = runIdentity (zipTablesM (\(Columnar' x) (Columnar' y) -> return (Columnar' (QExprBool (x ==. y))) ) a b) :: tbl QExprBool+ 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+ 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+ 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@@ -165,9 +234,6 @@ div_ = binOpE "/" mod_ = binOpE "%" -enum_ :: Show a => a -> QExpr (BeamEnum a)-enum_ = QExpr . SQLValE . SqlString . show- -- * Marshalling between Haskell literals and QExprs type family HaskellLiteralForQExpr x@@ -206,10 +272,10 @@ type LiftAggregationsToQExpr (Aggregation a) = QExpr a aggToSql (GroupAgg e) = let eSql = optimizeExpr' e in mempty { sqlGroupBy = [eSql] }- aggToSql (GenericAgg f qExprs) = mempty+ aggToSql (ProjectAgg _) = mempty liftAggToQExpr (GroupAgg e) = QExpr e- liftAggToQExpr (GenericAgg f qExprs) = QExpr (SQLFuncE f qExprs)+ liftAggToQExpr (ProjectAgg e) = QExpr e instance (Aggregating a, Aggregating b) => Aggregating (a, b) where type LiftAggregationsToQExpr (a, b) = ( LiftAggregationsToQExpr a , LiftAggregationsToQExpr b )@@ -237,17 +303,45 @@ 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) -group_ :: QExpr a -> Aggregation a-group_ (QExpr a) = GroupAgg a+-- | 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+-- basis of the group, its value is available for use in the result set.+class SqlGroupable a where+ type GroupResult a + -- | 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+ group_ (QExpr a) = GroupAgg a+instance {-# OVERLAPPING #-} Table t => SqlGroupable (PrimaryKey t QExpr) where+ type GroupResult (PrimaryKey t QExpr) = PrimaryKey t Aggregation+ group_ = pkChangeRep (\(Columnar' (QExpr e)) -> Columnar' (GroupAgg e))+instance {-# OVERLAPPING #-} Table t => SqlGroupable (t QExpr) where+ type GroupResult (t QExpr) = t Aggregation+ group_ = changeRep (\(Columnar' (QExpr e)) -> Columnar' (GroupAgg e))+ sum_ :: Num a => QExpr a -> Aggregation a-sum_ (QExpr over) = GenericAgg "SUM" [over]+sum_ (QExpr over) = ProjectAgg (SQLFuncE "SUM" [over]) count_ :: QExpr a -> Aggregation Int-count_ (QExpr over) = GenericAgg "COUNT" [over]+count_ (QExpr over) = ProjectAgg (SQLFuncE "COUNT" [over]) -aggregate :: (Projectible a, Aggregating agg) => (a -> agg) -> (forall s. Q db s a) -> Q db s (LiftAggregationsToQExpr agg)+-- | Return a 'TopLevelQ' that will aggregate over the results of the original query. The+-- aggregation function (first argument) should accept the output of the query, and return a member+-- of the 'Aggregating' class which will become the result of the new query. See the 'group_'+-- combinator as well as the various aggregation combinators ('sum_', 'count_', etc.)+--+-- For example,+--+-- > aggregate (\employee -> (group_ (_employeeRegion employee), count_ (_employeeId employee))) (all_ employeesTable)+--+-- 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 =+ TopLevelQ $ do res <- q curTbl <- gets qbNextTblRef@@ -287,6 +381,7 @@ , SqlOrderable e ) => SqlOrderable (a, b, c, d, e) where makeSQLOrdering (a, b, c, d, e) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> makeSQLOrdering e +-- | Order by certain expressions, either ascending ('asc_') or descending ('desc_') orderBy :: (SqlOrderable ordering, IsQuery q) => (a -> ordering) -> q db s a -> TopLevelQ db s a orderBy orderer q = TopLevelQ $@@ -347,23 +442,118 @@ <*> subqueryProjections d <*> subqueryProjections 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 - let (res, select') = queryToSQL' (toQ q)+ let (res, curTbl', select') = queryToSQL' (toQ q) curTbl subTblName = fromString ("t" <> show curTbl)- (res', projection') = evalRWS (subqueryProjections res) (subTblName, curTbl) 0+ (res', projection') = evalRWS (subqueryProjections res) (subTblName, curTbl') 0 select'' = select' { selProjection = SQLProj projection' } - modify $ \qb@QueryBuilder { qbNextTblRef = curTbl- , 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+ newSource = SQLFromSource (SQLAliased (SQLSourceSelect select'') (Just (fromString ("t" <> show curTbl'))))+ in qb { qbNextTblRef = curTbl' + 1 , qbFrom = from' } pure res'++-- * Nullable conversions++-- | Type class for things that can be nullable. This includes 'QExpr (Maybe a)', 'tbl (Nullable+-- QExpr)', and 'PrimaryKey tbl (Nullable QExpr)'+class SqlJustable a b | b -> a where++ -- | Given something of type 'QExpr a', 'tbl QExpr', or 'PrimaryKey tbl QExpr', turn it into a+ -- 'QExpr (Maybe a)', 'tbl (Nullable QExpr)', or 'PrimaryKey t (Nullable QExpr)' respectively+ -- that contains the same values.+ just_ :: a -> b++ -- | Return either a 'QExpr (Maybe x)' representing 'Nothing' or a nullable 'Table' or+ -- 'PrimaryKey' filled with 'Nothing'.+ nothing_ :: b++instance SqlJustable (QExpr a) (QExpr (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+ 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+ just_ = changeRep (\(Columnar' q) -> Columnar' (just_ q))+ nothing_ = changeRep (\(Columnar' q) -> Columnar' nothing_) (tblFieldSettings :: TableSettings t)++instance {-# OVERLAPPING #-} Table t => SqlJustable (PrimaryKey t Identity) (PrimaryKey t (Nullable Identity)) where+ just_ = pkChangeRep (\(Columnar' q) -> Columnar' (Just q))+ nothing_ = pkChangeRep (\(Columnar' q) -> Columnar' Nothing) (primaryKey (tblFieldSettings :: TableSettings t))++instance {-# OVERLAPPING #-} Table t => SqlJustable (t Identity) (t (Nullable Identity)) where+ just_ = changeRep (\(Columnar' q) -> Columnar' (Just q))+ nothing_ = changeRep (\(Columnar' q) -> Columnar' Nothing) (tblFieldSettings :: TableSettings t)++-- * Nullable checking++-- | 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+ -- | Returns a 'QExpr' that evaluates to true when the first argument is not null+ isJust_ :: a -> QExpr Bool++ -- | Returns a 'QExpr' that evaluates to true when the first argument is null+ isNothing_ :: a -> QExpr 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++instance SqlDeconstructMaybe (QExpr (Maybe x)) (QExpr x) 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+ 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+ 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+ in foldr (&&.) (val_ True) (fieldAllValues (\(Columnar' (QExprBool e)) -> e) fieldsAreJust)+ isNothing_ t = let fieldsAreNothing = changeRep (\(Columnar' x) -> Columnar' (QExprBool (isNothing_ x))) t :: t QExprBool+ 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+ beamUnwrapMaybe (Columnar' (QExpr e)) = Columnar' (QExpr e)+instance BeamUnwrapMaybe c => BeamUnwrapMaybe (Nullable c) where+ beamUnwrapMaybe (Columnar' x :: Columnar' (Nullable (Nullable c)) x) =+ let Columnar' x' = beamUnwrapMaybe (Columnar' x :: Columnar' (Nullable c) (Maybe x)) :: Columnar' c (Maybe x)++ xCol :: Columnar' (Nullable c) x+ 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+ 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+ 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
@@ -14,14 +14,18 @@ import Database.HDBC +-- | Type class for any query like entity, currently `Q` and `TopLevelQ` class IsQuery q where toQ :: q db s a -> Q db s a +-- | The type of queries over the database `db` returning results of type `a`. The `s` argument is a+-- threading argument meant to restrict cross-usage of `QExpr`s although this is not yet+-- implemented. newtype Q (db :: (((* -> *) -> *) -> *) -> *) s a = Q { runQ :: State QueryBuilder a} deriving (Monad, Applicative, Functor, MonadFix, MonadState QueryBuilder) -- | Wrapper for 'Q's that have been modified in such a way that they can no longer be joined against--- without the use of 'subquery'. 'TopLevelQ' is also an instance of 'IsQuery', and so can be passed+-- without the use of 'subquery_'. 'TopLevelQ' is also an instance of 'IsQuery', and so can be passed -- directly to 'query' or 'queryList' newtype TopLevelQ db s a = TopLevelQ (Q db s a) @@ -43,20 +47,30 @@ , qFieldName :: T.Text } deriving (Show, Eq, Ord) +-- | 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) deriving (Show, Eq) +-- * Aggregations++data Aggregation a = GroupAgg (SQLExpr' QField)+ | ProjectAgg (SQLExpr' QField)+ -- * Sql Projections ----- Here we define a typeclass for all haskell data types that can be used--- to create a projection in a SQL select statement. This includes all tables--- as well as all tuple classes. Projections are only defined on tuples up to--- size 5. If you need more, follow the implementations here. +-- | Typeclass for all haskell data types that can be used to create a projection in a SQL select+-- statement. This includes all tables as well as all tuple classes. Projections are only defined on+-- tuples up to size 5. If you need more, follow the implementations here.+ class Projectible a where project :: a -> [SQLExpr' QField] instance Typeable a => Projectible (QExpr a) where project (QExpr x) = [x]+instance Projectible () where+ project () = [SQLValE (SqlInteger 1)] instance (Projectible a, Projectible b) => Projectible (a, b) where project (a, b) = project a ++ project b instance ( Projectible a@@ -76,6 +90,8 @@ project (a, b, c, d, e) = project a ++ project b ++ project c ++ project d ++ project e instance Table t => Projectible (t QExpr) where+ project t = fieldAllValues (\(Columnar' (QExpr e)) -> e) t+instance Table t => Projectible (t (Nullable QExpr)) where project t = fieldAllValues (\(Columnar' (QExpr e)) -> e) t tableVal :: Table tbl => tbl Identity -> tbl QExpr
src/Database/Beam/Query/Types.hs view
@@ -4,11 +4,11 @@ , Projectible(..) - , Aggregation(..)+ , Aggregation , queryToSQL' - , allExprOpts, mkSqlField, optimizeExpr, optimizeExpr' ) where+ , optimizeExpr, optimizeExpr' ) where import Database.Beam.Query.Internal @@ -37,49 +37,20 @@ type family QExprToIdentity x type instance QExprToIdentity (table QExpr) = table Identity+type instance QExprToIdentity (table (Nullable c)) = Maybe (QExprToIdentity (table c)) type instance QExprToIdentity (QExpr 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)+type instance QExprToIdentity (a, b, c, d, e) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c, QExprToIdentity d, QExprToIdentity e) instance IsQuery Q where toQ = id instance IsQuery TopLevelQ where toQ (TopLevelQ q) = q --- * Aggregations--data Aggregation a = GroupAgg (SQLExpr' QField)- | GenericAgg T.Text [SQLExpr' QField]- -- * Rewriting and optimization --- rwE :: Monad m => (forall a. QExpr a -> m (Maybe (QExpr a))) -> QExpr a -> m (QExpr a)--- rwE f x = do x' <- f x--- case x' of--- Nothing -> return x--- Just x'--- | x == x' -> return x--- | otherwise -> rewriteExprM f x'---- rewriteExprM :: Monad m => (forall a . QExpr a -> m (Maybe (QExpr a))) -> QExpr a -> m (QExpr a)--- rewriteExprM f (BinOpE op a b) =--- do a' <- rewriteExprM f a--- b' <- rewriteExprM f b--- rwE f (BinOpE op a' b')--- rewriteExprM f (UnOpE op a) =--- do a' <- rewriteExprM f a--- rwE f (UnOpE op a')--- -- rewriteExprM f (JustE a) = do a' <- rewriteExprM f a--- -- rwE f (JustE a')--- rewriteExprM f (IsNothingE a) = do a' <- rewriteExprM f a--- rwE f (IsNothingE a')--- rewriteExprM f (IsJustE a) = do a' <- rewriteExprM f a--- rwE f (IsJustE a')--- -- rewriteExprM f (InE a b) = rewriteBin f InE a b--- -- rewriteExprM f (ListE as) = do as' <- mapM (rewriteExprM f fq) as--- -- rwE f (ListE as')--- rewriteExprM f x = rwE f x- booleanOpts :: SQLExpr -> Maybe SQLExpr booleanOpts (SQLBinOpE "AND" (SQLValE (SqlBool False)) _) = Just (SQLValE (SqlBool False)) booleanOpts (SQLBinOpE "AND" _ (SQLValE (SqlBool False))) = Just (SQLValE (SqlBool False))@@ -92,10 +63,16 @@ booleanOpts x = Nothing +-- | Rewrite function to optimize an expression, will return `Nothing`+-- if the current expression cannot be rewritten any further. Suitable+-- to be passed to `rewriteM`. allExprOpts e = pure (booleanOpts e) +-- | Given a `SQLExpr' QField` optimize the expression and turn it into a `SQLExpr`. optimizeExpr' :: SQLExpr' QField -> SQLExpr optimizeExpr' = runIdentity . rewriteM allExprOpts . fmap mkSqlField++-- | Optimize a `QExpr` and turn it in into a `SQLExpr`. optimizeExpr :: QExpr a -> SQLExpr optimizeExpr (QExpr e) = optimizeExpr' e @@ -103,17 +80,18 @@ mkSqlField (QField tblName (Just tblOrd) fieldName) = SQLQualifiedFieldName fieldName ("t" <> fromString (show tblOrd)) mkSqlField (QField tblName Nothing fieldName) = SQLFieldName fieldName -queryToSQL' :: Projectible a => Q db s a -> (a, SQLSelect)-queryToSQL' q = let (res, qb) = runState (runQ q) emptyQb- emptyQb = QueryBuilder 0 Nothing (QExpr (SQLValE (SqlBool True))) Nothing Nothing [] Nothing- projection = map (\q -> SQLAliased (optimizeExpr' q) Nothing) (project res)+-- | 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+ projection = map (\q -> SQLAliased (optimizeExpr' q) Nothing) (project res) - sel = SQLSelect- { selProjection = SQLProj projection- , selFrom = qbFrom qb- , selWhere = optimizeExpr (qbWhere qb)- , selGrouping = qbGrouping qb- , selOrderBy = qbOrdering qb- , selLimit = qbLimit qb- , selOffset = qbOffset qb }- in (res, sel)+ sel = SQLSelect+ { selProjection = SQLProj projection+ , selFrom = qbFrom qb+ , selWhere = optimizeExpr (qbWhere qb)+ , selGrouping = qbGrouping qb+ , selOrderBy = qbOrdering qb+ , selLimit = qbLimit qb+ , selOffset = qbOffset qb }+ in (res, qbNextTblRef qb, sel)
src/Database/Beam/SQL.hs view
@@ -205,20 +205,18 @@ ppExpr (SQLUnOpE op a) = do aDoc <- ppExpr a return (parens (text (unpack op) <+> parens aDoc)) ppExpr (SQLIsNothingE q) = do qDoc <- ppExpr q- return (qDoc <+> text "IS NULL")+ return (parens (qDoc <+> text "IS NULL")) ppExpr (SQLIsJustE q) = do qDoc <- ppExpr q- return (qDoc <+> text "IS NOT NULL")+ return (parens (qDoc <+> text "IS NOT NULL")) ppExpr (SQLListE xs) = do xsDoc <- mapM ppExpr xs return (parens (hsep (punctuate comma xsDoc)))--- ppExpr (SQLCountE x) = do xDoc <- ppExpr x--- return (text "COUNT" <> parens xDoc)--- ppExpr (SQLMinE x) = do xDoc <- ppExpr x--- return (text "MIN" <> parens xDoc)--- ppExpr (SQLMaxE x) = do xDoc <- ppExpr x--- return (text "MAX" <> parens xDoc)--- ppExpr (SQLSumE x) = do xDoc <- ppExpr x--- return (text "SUM" <> parens xDoc)--- ppExpr (SQLAverageE x) = do xDoc <- ppExpr x--- return (text "AVERAGE" <> parens xDoc) ppExpr (SQLFuncE f args) = do argDocs <- mapM ppExpr args return (text (unpack f) <> parens (hsep (punctuate comma argDocs)) )+ppExpr (SQLExistsE q) = do selectDoc <- ppSel q+ pure (parens (text "EXISTS (" <> selectDoc <> text ")"))+ppExpr (SQLCaseE clauses else_) = do whenClauses <- forM clauses $ \(cond, then_) ->+ do condDoc <- ppExpr cond+ thenDoc <- ppExpr then_+ pure (text "WHEN" <+> condDoc <+> text "THEN" <+> thenDoc)+ elseDoc <- ppExpr else_+ pure (parens (text "CASE" <+> hsep whenClauses <+> text "ELSE" <+> elseDoc <+> text "END"))
src/Database/Beam/SQL/Types.hs view
@@ -67,37 +67,37 @@ , selOrderBy :: [SQLOrdering] , selLimit :: Maybe Integer , selOffset :: Maybe Integer }- deriving Show+ deriving (Show, Eq, Data) data SQLFieldName = SQLFieldName Text | SQLQualifiedFieldName Text Text deriving (Show, Eq, Data) data SQLAliased a = SQLAliased a (Maybe Text)- deriving Show+ deriving (Show, Eq, Data) data SQLProjection = SQLProjStar -- ^ The * from SELECT * | SQLProj [SQLAliased SQLExpr]- deriving Show+ deriving (Show, Eq, Data) data SQLSource = SQLSourceTable Text | SQLSourceSelect SQLSelect- deriving Show+ deriving (Show, Eq, Data) data SQLJoinType = SQLInnerJoin | SQLLeftJoin | SQLRightJoin | SQLOuterJoin- deriving Show+ deriving (Show, Eq, Data) data SQLFrom = SQLFromSource (SQLAliased SQLSource) | SQLJoin SQLJoinType SQLFrom SQLFrom SQLExpr- deriving Show+ deriving (Show, Eq, Data) data SQLGrouping = SQLGrouping { sqlGroupBy :: [SQLExpr] , sqlHaving :: SQLExpr }- deriving (Show)+ deriving (Show, Eq, Data) instance Monoid SQLGrouping where mappend (SQLGrouping group1 having1) (SQLGrouping group2 having2) =@@ -109,7 +109,7 @@ data SQLOrdering = Asc SQLExpr | Desc SQLExpr- deriving Show+ deriving (Show, Eq, Data) data SQLExpr' f = SQLValE SqlValue | SQLFieldE f@@ -123,6 +123,10 @@ | SQLListE [SQLExpr' f] | SQLFuncE Text [SQLExpr' f]++ | SQLExistsE SQLSelect++ | SQLCaseE [(SQLExpr' f, SQLExpr' f)] (SQLExpr' f) deriving (Show, Functor, Eq, Data) deriving instance Data SqlValue type SQLExpr = SQLExpr' SQLFieldName
src/Database/Beam/Schema/Fields.hs view
@@ -22,18 +22,35 @@ -- * Fields -instance (Enum a, Show a, Read a, Typeable a) => FieldSchema (BeamEnum a) where- data FieldSettings (BeamEnum a) = EnumSettings- { maxNameSize :: Maybe Int }- deriving Show-- defSettings = EnumSettings Nothing+enumSchema :: (Enum a, Show a, Read a, Typeable a) => FieldSchema a+enumSchema = let schema :: (Enum a, Typeable a) => FieldSchema a+ schema = FieldSchema+ { fsColDesc = fsColDesc intSchema+ , fsHumanReadable = "enumField"+ , fsMakeSqlValue = SqlInteger . fromIntegral . fromEnum+ , fsFromSqlValue = do val <- fromSql <$> popSqlValue+ pure (toEnum val) }+ in schema+instance HasDefaultFieldSchema a => HasDefaultFieldSchema (Maybe a) where+ defFieldSchema = maybeFieldSchema defFieldSchema - colDescFromSettings (EnumSettings nameSize) = colDescFromSettings (defSettings { charOrVarChar = Varchar nameSize })+-- ** Int Field - makeSqlValue (BeamEnum x) = SqlString (show x)- fromSqlValue = BeamEnum . read . fromSql <$> popSqlValue-instance (Enum a, Show a, Read a, Typeable a) => FromSqlValues (BeamEnum a)+intSchema :: FieldSchema Int+intSchema = FieldSchema+ { fsColDesc = notNull+ SqlColDesc+ { colType = SqlNumericT+ , colSize = Nothing+ , colOctetLength = Nothing+ , colDecDigits = Nothing+ , colNullable = Nothing }+ , fsHumanReadable = "intSchema"+ , fsMakeSqlValue = SqlInteger . fromIntegral+ , fsFromSqlValue = fromSql <$> popSqlValue }+instance HasDefaultFieldSchema Int where+ defFieldSchema = intSchema+instance FromSqlValues Int -- ** Text field @@ -41,47 +58,49 @@ | Varchar (Maybe Int) deriving Show -instance FieldSchema Text where- -- | Settings for a text field- data FieldSettings Text = TextFieldSettings- { charOrVarChar :: CharOrVarchar }- deriving Show-- defSettings = TextFieldSettings (Varchar Nothing)-- colDescFromSettings (TextFieldSettings (Char n)) = notNull $- SqlColDesc- { colType = SqlCharT- , colSize = n- , colOctetLength = Nothing- , colDecDigits = Nothing- , colNullable = Nothing }- colDescFromSettings (TextFieldSettings (Varchar n)) = notNull $- SqlColDesc- { colType = SqlVarCharT- , colSize = n- , colOctetLength = Nothing- , colDecDigits = Nothing- , colNullable = Nothing }+textSchema :: CharOrVarchar -> FieldSchema Text+textSchema charOrVarchar = FieldSchema+ { fsColDesc = colDesc+ , fsHumanReadable = "textSchema (" ++ show charOrVarchar ++ ")"+ , fsMakeSqlValue = SqlString . unpack+ , fsFromSqlValue = fromSql <$> popSqlValue }+ where colDesc = case charOrVarchar of+ Char n -> notNull $+ SqlColDesc+ { colType = SqlCharT+ , colSize = n+ , colOctetLength = Nothing+ , colDecDigits = Nothing+ , colNullable = Nothing }+ Varchar n -> notNull $+ SqlColDesc+ { colType = SqlVarCharT+ , colSize = n+ , colOctetLength = Nothing+ , colDecDigits = Nothing+ , colNullable = Nothing }+defaultTextSchema :: FieldSchema Text+defaultTextSchema = textSchema (Varchar Nothing) - makeSqlValue x = SqlString (unpack x)- fromSqlValue = fromSql <$> popSqlValue+instance HasDefaultFieldSchema Text where+ defFieldSchema = defaultTextSchema instance FromSqlValues Text -instance FieldSchema UTCTime where- data FieldSettings UTCTime = DateTimeDefault- deriving Show+dateTimeSchema :: FieldSchema UTCTime+dateTimeSchema = FieldSchema+ { fsColDesc = notNull $+ SqlColDesc+ { colType = SqlUTCDateTimeT+ , colSize = Nothing+ , colOctetLength = Nothing+ , colDecDigits = Nothing+ , colNullable = Nothing }+ , fsHumanReadable = "dateTimeField"+ , fsMakeSqlValue = SqlUTCTime+ , fsFromSqlValue = fromSql <$> popSqlValue } - defSettings = DateTimeDefault- colDescFromSettings _ = notNull $- SqlColDesc- { colType = SqlUTCDateTimeT- , colSize = Nothing- , colOctetLength = Nothing- , colDecDigits = Nothing- , colNullable = Nothing }- makeSqlValue = SqlUTCTime- fromSqlValue = fromSql <$> popSqlValue+instance HasDefaultFieldSchema UTCTime where+ defFieldSchema = dateTimeSchema instance FromSqlValues UTCTime -- ** Auto-increment fields@@ -90,20 +109,21 @@ | AssignedId !Int deriving (Show, Read, Eq, Ord, Generic) -instance FieldSchema AutoId where- data FieldSettings AutoId = AutoIdDefault- deriving Show- defSettings = AutoIdDefault- colDescFromSettings _ = SQLColumnSchema desc [SQLNotNull, SQLAutoIncrement]- where desc = SqlColDesc- { colType = SqlNumericT- , colSize = Nothing- , colOctetLength = Nothing- , colDecDigits = Nothing- , colNullable = Nothing }-- makeSqlValue UnassignedId = SqlNull- makeSqlValue (AssignedId i) = SqlInteger (fromIntegral i)- fromSqlValue = maybe UnassignedId AssignedId . fromSql <$> popSqlValue-+autoIdSchema :: FieldSchema AutoId+autoIdSchema = FieldSchema+ { fsColDesc = SQLColumnSchema desc [SQLNotNull, SQLAutoIncrement]+ , fsHumanReadable = "autoIdSchema"+ , fsMakeSqlValue = \x -> case x of+ UnassignedId -> SqlNull+ AssignedId i -> SqlInteger (fromIntegral i)+ , fsFromSqlValue = maybe UnassignedId AssignedId . fromSql <$> popSqlValue }+ where desc = SqlColDesc+ { colType = SqlNumericT+ , colSize = Nothing+ , colOctetLength = Nothing+ , colDecDigits = Nothing+ , colNullable = Nothing }+instance HasDefaultFieldSchema AutoId where+ defFieldSchema = autoIdSchema instance FromSqlValues AutoId+
src/Database/Beam/Schema/Tables.hs view
@@ -9,25 +9,25 @@ , autoDbSettings , allTableSettings - , BeamEnum(..)- , SqlValue'(..) , Lenses, LensFor(..) -- * Columnar and Column Tags , Columnar(..), Columnar'(..) , Nullable(..), TableField(..)- , fieldName, fieldConstraints, fieldSettings+ , fieldName, fieldConstraints, fieldSchema, maybeFieldSchema , TableSettings(..) -- * Tables- , Table(..), defTblFieldSettings, defFieldSettings+ , Table(..), defTblFieldSettings , reifyTableSchema, tableValuesNeeded , pk+ , pkAllValues, fieldAllValues, pkChangeRep, changeRep+ , pkMakeSqlValues, makeSqlValues -- * Fields- , FieldSchema(..), FromSqlValuesM(..), FromSqlValues(..)+ , HasDefaultFieldSchema(..), FieldSchema(..), FromSqlValuesM(..), FromSqlValues(..) , popSqlValue, peekSqlValue ) where @@ -36,6 +36,7 @@ import Control.Arrow import Control.Applicative import Control.Monad.State+import Control.Monad.Writer import Control.Monad.Error import Control.Monad.Identity @@ -110,9 +111,6 @@ newtype Exposed x = Exposed x newtype SqlValue' x = SqlValue' SqlValue -newtype BeamEnum a = BeamEnum { unBeamEnum :: a }- deriving (Show, Typeable)- -- | A type family that we use to "tag" columns in our table datatypes. -- -- This is what allows us to use the same table type to hold table data, describe table settings,@@ -121,13 +119,9 @@ -- The basic rules are -- -- > Columnar Identity x = x--- > Columnar Identity (BeamEnum x) = x -- -- Thus, any Beam table applied to 'Identity' will yield a simplified version of the data type, that contains--- just what you'd expect. Enum types tagged with 'BeamEnum', are automatically unwrapped in the simplified data--- structure.------ > Columnar (Nullable c) x = Columnar c (Maybe x)+-- just what you'd expect. -- -- The 'Nullable' type is used when referencing 'PrimaryKey's that we want to include optionally. -- For example, if we have a table with a 'PrimaryKey', like the following@@ -158,7 +152,6 @@ type family Columnar (f :: * -> *) x where Columnar Exposed x = Exposed x - Columnar Identity (BeamEnum x) = x Columnar Identity x = x Columnar (Lenses t Identity) x = LensFor (t Identity) (Columnar Identity x)@@ -210,16 +203,16 @@ data TableField (table :: (* -> *) -> *) ty = TableField { _fieldName :: Text -- ^ The field name , _fieldConstraints :: [SQLConstraint] -- ^ Constraints for the field (such as AutoIncrement, PrimaryKey, etc)- , _fieldSettings :: FieldSettings ty -- ^ Settings for the field+ , _fieldSchema :: FieldSchema ty -- ^ SQL storage informationa for the field }-deriving instance Show (FieldSettings ty) => Show (TableField t ty)+deriving instance Show (TableField t ty) fieldName :: Lens' (TableField table ty) Text fieldName f (TableField name cs s) = (\name' -> TableField name' cs s) <$> f name fieldConstraints :: Lens' (TableField table ty) [SQLConstraint] fieldConstraints f (TableField name cs s) = (\cs' -> TableField name cs' s) <$> f cs-fieldSettings :: Lens (TableField table a) (TableField table b) (FieldSettings a) (FieldSettings b)-fieldSettings f (TableField name cs s) = (\s' -> TableField name cs s') <$> f s+fieldSchema :: Lens (TableField table a) (TableField table b) (FieldSchema a) (FieldSchema b)+fieldSchema f (TableField name cs s) = (\s' -> TableField name cs s') <$> f s type TableSettings table = table (TableField table) @@ -274,57 +267,24 @@ -- we ensure that the primary key values come directly from the table (i.e., they can't be arbitrary constants) primaryKey :: table column -> PrimaryKey table column - pkChangeRep :: (forall a. Columnar' f a -> Columnar' g a) -> PrimaryKey table f -> PrimaryKey table g- default pkChangeRep :: ( Generic (PrimaryKey table f)- , Generic (PrimaryKey table g)- , Generic (PrimaryKey table Exposed)- , GChangeRep (Rep (PrimaryKey table Exposed) ())- (Rep (PrimaryKey table f) ()) (Rep (PrimaryKey table g) ())- f g ) =>- (forall a. Columnar' f a -> Columnar' g a) -> PrimaryKey table f -> PrimaryKey table g- pkChangeRep f x = to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey table Exposed) ()))- f (from' x))-- changeRep :: (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> table f -> table g- default changeRep :: ( ChangeRep table f g ) =>- (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> table f -> table g- changeRep (f :: forall a. FieldSchema a => Columnar' f a -> Columnar' g a) =- changeRep' (Proxy :: Proxy f) (Proxy :: Proxy g) (Proxy :: Proxy table) f-- pkAllValues :: (forall a. FieldSchema a => Columnar' f a -> b) -> PrimaryKey table f -> [b]- default pkAllValues :: AllValues f (PrimaryKey table f) (PrimaryKey table Exposed) =>- (forall a. FieldSchema a => Columnar' f a -> b) -> PrimaryKey table f -> [b]- pkAllValues = allValues' (Proxy :: Proxy (PrimaryKey table Exposed))-- fieldAllValues :: (forall a. FieldSchema a => Columnar' f a -> b) -> table f -> [b]- default fieldAllValues :: AllValues f (table f) (table Exposed) =>- (forall a. FieldSchema a => Columnar' f a -> b) -> table f -> [b]- fieldAllValues = allValues' (Proxy :: Proxy (table Exposed))- tblFieldSettings :: TableSettings table default tblFieldSettings :: ( Generic (TableSettings table) , GDefaultTableFieldSettings (Rep (TableSettings table) ())) => TableSettings table tblFieldSettings = defTblFieldSettings - pkMakeSqlValues :: PrimaryKey table Identity -> PrimaryKey table SqlValue'- default pkMakeSqlValues :: ( Generic (PrimaryKey table Identity)- , Generic (PrimaryKey table SqlValue')- , GMakeSqlValues (Rep (PrimaryKey table Exposed) ()) (Rep (PrimaryKey table Identity) ()) (Rep (PrimaryKey table SqlValue') ())) =>- PrimaryKey table Identity -> PrimaryKey table SqlValue'- pkMakeSqlValues table = to' (gMakeSqlValues (Proxy :: Proxy (Rep (PrimaryKey table Exposed) ())) (from' table))-- makeSqlValues :: table Identity -> table SqlValue'- default makeSqlValues :: ( Generic (table Identity)- , Generic (table SqlValue')- , GMakeSqlValues (Rep (table Exposed) ()) (Rep (table Identity) ()) (Rep (table SqlValue') ())) =>- table Identity -> table SqlValue'- makeSqlValues table = to' (gMakeSqlValues (Proxy :: Proxy (Rep (table Exposed) ())) (from' table))+ zipTablesM :: Monad m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h)+ default zipTablesM :: ( GZipTables f g h (Rep (table Exposed)) (Rep (table f)) (Rep (table g)) (Rep (table h))+ , Generic (table f), Generic (table g), Generic (table h) ) =>+ Monad m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h)+ zipTablesM combine f g = do hRep <- gZipTables (Proxy :: Proxy (Rep (table Exposed))) combine (from' f) (from' g)+ return (to' hRep) - tableFromSqlValues :: FromSqlValuesM (table Identity)- default tableFromSqlValues :: ( Generic (table Identity)- , GFromSqlValues (Rep (table Exposed)) (Rep (table Identity)) ) =>- FromSqlValuesM (table Identity)- tableFromSqlValues = to <$> gFromSqlValues (Proxy :: Proxy (Rep (table Exposed)))+ zipPkM :: Monad m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> PrimaryKey table f -> PrimaryKey table g -> m (PrimaryKey table h)+ default zipPkM :: ( GZipTables f g h (Rep (PrimaryKey table Exposed)) (Rep (PrimaryKey table f)) (Rep (PrimaryKey table g)) (Rep (PrimaryKey table h))+ , Generic (PrimaryKey table f), Generic (PrimaryKey table g), Generic (PrimaryKey table h)+ , Monad m) => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> PrimaryKey table f -> PrimaryKey table g -> m (PrimaryKey table h)+ zipPkM combine f g = do hRep <- gZipTables (Proxy :: Proxy (Rep (PrimaryKey table Exposed))) combine (from' f) (from' g)+ return (to' hRep) reifyTableSchema :: Table table => Proxy table -> ReifiedTableSchema reifyTableSchema (Proxy :: Proxy table) = fieldAllValues (\(Columnar' (TableField name constraints settings)) ->@@ -333,6 +293,30 @@ tableValuesNeeded :: Table table => Proxy table -> Int tableValuesNeeded (Proxy :: Proxy table) = length (fieldAllValues (const ()) (tblFieldSettings :: TableSettings table)) +pkAllValues :: Table t => (forall a. Columnar' f a -> b) -> PrimaryKey t f -> [b]+pkAllValues (f :: forall a. Columnar' f a -> b) (pk :: PrimaryKey table f) = execWriter (zipPkM combine pk pk)+ where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)+ combine x _ = do tell [f x]+ return x++fieldAllValues :: Table t => (forall a. Columnar' f a -> b) -> t f -> [b]+fieldAllValues (f :: forall a. Columnar' f a -> b) (tbl :: table f) = execWriter (zipTablesM combine tbl tbl)+ where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)+ combine x _ = do tell [f x]+ return x++pkChangeRep :: Table t => (forall a. Columnar' f a -> Columnar' g a) -> PrimaryKey t f -> PrimaryKey t g+pkChangeRep f pk = runIdentity (zipPkM (\x _ -> return (f x)) pk pk)++changeRep :: Table t => (forall a. Columnar' f a -> Columnar' g a) -> t f -> t g+changeRep f tbl = runIdentity (zipTablesM (\x _ -> return (f x)) tbl tbl)++pkMakeSqlValues :: Table t => PrimaryKey t Identity -> PrimaryKey t SqlValue'+pkMakeSqlValues pk = runIdentity (zipPkM (\(Columnar' x) (Columnar' tf) -> return (Columnar' (SqlValue' (fsMakeSqlValue (_fieldSchema tf) x)))) pk (primaryKey tblFieldSettings))++makeSqlValues :: Table t => t Identity -> t SqlValue'+makeSqlValues tbl = runIdentity (zipTablesM (\(Columnar' x) (Columnar' tf) -> return (Columnar' (SqlValue' (fsMakeSqlValue (_fieldSchema tf) x)))) tbl tblFieldSettings)+ -- | Synonym for 'primaryKey' pk :: Table t => t f -> PrimaryKey t f pk = primaryKey@@ -354,97 +338,51 @@ where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table withProxy f = f Proxy -defFieldSettings :: FieldSchema fs => Text -> TableField table fs-defFieldSettings name = TableField- { _fieldName = name- , _fieldConstraints = []- , _fieldSettings = settings}- where settings = defSettings--fieldColDesc :: FieldSchema fs => FieldSettings fs -> [SQLConstraint] -> SQLColumnSchema-fieldColDesc settings cs =let base = colDescFromSettings settings- in base { csConstraints = csConstraints base ++ cs }--class GChangeRep (ty :: *) x y f g where- gChangeRep :: Proxy ty -> (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> x -> y-instance GChangeRep (ty p) (a p) (b p) x y => GChangeRep (M1 s h ty p) (M1 s f a p) (M1 s g b p) x y where- gChangeRep _ f (M1 x) = M1 (gChangeRep (Proxy :: Proxy (ty p)) f x)-instance ( GChangeRep (t1 p) (a1 p) (a2 p) x y, GChangeRep (t2 p) (b1 p) (b2 p) x y) => GChangeRep ((t1 :*: t2) p) ((a1 :*: b1) p) ((a2 :*: b2) p) x y where- gChangeRep _ f (a :*: b) =- gChangeRep (Proxy :: Proxy (t1 p)) f a :*: gChangeRep (Proxy :: Proxy (t2 p)) f b-instance ( Generic (PrimaryKey rel x)- , Generic (PrimaryKey rel y)- , GChangeRep (Rep (PrimaryKey rel Exposed) ())- (Rep (PrimaryKey rel x) ())- (Rep (PrimaryKey rel y) ())- x y ) =>- GChangeRep (K1 Generic.R (PrimaryKey rel Exposed) p) (K1 Generic.R (PrimaryKey rel x) p) (K1 Generic.R (PrimaryKey rel y) p) x y where- gChangeRep _ f (K1 x) =- K1 (to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey rel Exposed) ())) f (from' x)))--instance ( xa ~ Columnar x a, ya ~ Columnar y a, FieldSchema a) =>- GChangeRep (K1 Generic.R (Exposed a) p) (K1 Generic.R xa p) (K1 Generic.R ya p) x y where-- gChangeRep (_ :: Proxy (K1 Generic.R (Exposed a) p)) (f :: forall b. FieldSchema b => Columnar' f b -> Columnar' g b) (K1 x) =- let x' = Columnar' x :: Columnar' f a- Columnar' y' = f x' :: Columnar' g a- in K1 y'---- instance GChangeRep (K1 Generic.R (Nullable x a) p) (K1 Generic.R (Nullable y a) p) x y where--- gChangeRep f (K1 (Nullable x)) = K1 (Nullable (f x))--- instance ( Generic (PrimaryKey table x)--- , Generic (PrimaryKey table y)--- , GChangeRep (Rep (PrimaryKey table x) ()) (Rep (PrimaryKey table y) ()) x y ) =>--- GChangeRep (K1 Generic.R (PrimaryKey table x) p) (K1 Generic.R (PrimaryKey table y) p) x y where--- gChangeRep f (K1 (PrimaryKey x)) = K1 (PrimaryKey (to' (gChangeRep f (from' x))))--- instance ( Generic (PrimaryKey table (Nullable x))--- , Generic (PrimaryKey table (Nullable y))--- , GChangeRep (Rep (PrimaryKey table (Nullable x)) ()) (Rep (PrimaryKey table (Nullable y)) ()) x y ) =>--- GChangeRep (K1 Generic.R (PrimaryKey table (Nullable x)) p) (K1 Generic.R (PrimaryKey table (Nullable y)) p) x y where--- gChangeRep f (K1 (PrimaryKey x)) = K1 (PrimaryKey (to' (gChangeRep f (from' x))))--- instance GChangeRep (Nullable f a) (Nullable g a) f g where--- gChangeRep f (Nullable x) = Nullable (f x)+fieldColDesc :: FieldSchema fs -> [SQLConstraint] -> SQLColumnSchema+fieldColDesc schema cs = let base = fsColDesc schema+ in base { csConstraints = csConstraints base ++ cs } -class ChangeRep x f g where- changeRep' :: Proxy f -> Proxy g -> Proxy x -> (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> x f -> x g-instance ( Generic (x f)- , Generic (x g)- , Generic (x Exposed)- , GChangeRep (Rep (x Exposed) ()) (Rep (x f) ()) (Rep (x g) ()) f g) =>- ChangeRep x f g where- changeRep' _ _ (Proxy :: Proxy x) f x = to' (gChangeRep (Proxy :: Proxy (Rep (x Exposed) ())) f (from' x))+class GZipTables f g h (exposedRep :: * -> *) fRep gRep hRep where+ gZipTables :: Monad m => Proxy exposedRep -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> fRep () -> gRep () -> m (hRep ())+instance ( GZipTables f g h exp1 f1 g1 h1+ , GZipTables f g h exp2 f2 g2 h2) =>+ GZipTables f g h (exp1 :*: exp2) (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where -class GAllValues (f :: * -> *) (ty :: *) x where- gAllValues :: Proxy ty -> (forall a. FieldSchema a => Columnar' f a -> b) -> x -> [b]-instance (GAllValues f (t1 x) (a x), GAllValues f (t2 x) (b x)) => GAllValues f ((t1 :*: t2) x) ((a :*: b) x) where- gAllValues Proxy f (a :*: b) = gAllValues (Proxy :: Proxy (t1 x)) f a ++ gAllValues (Proxy :: Proxy (t2 x)) f b-instance (GAllValues f (ty x) (p x)) => GAllValues f (M1 s h ty x) (M1 s g p x) where- gAllValues Proxy f (M1 a) = gAllValues (Proxy :: Proxy (ty x)) f a+ gZipTables _ combine (f1 :*: f2) (g1 :*: g2) =+ do h1 <- gZipTables (Proxy :: Proxy exp1) combine f1 g1+ h2 <- gZipTables (Proxy :: Proxy exp2) combine f2 g2+ return (h1 :*: h2)+instance GZipTables f g h exp fRep gRep hRep =>+ GZipTables f g h (M1 x y exp) (M1 x y fRep) (M1 x y gRep) (M1 x y hRep) where+ gZipTables _ combine (M1 f) (M1 g) = do h <- gZipTables (Proxy :: Proxy exp) combine f g+ return (M1 h)+instance ( fa ~ Columnar f a+ , ga ~ Columnar g a+ , ha ~ Columnar h a) =>+ GZipTables f g h (K1 Generic.R (Exposed a)) (K1 Generic.R fa) (K1 Generic.R ga) (K1 Generic.R ha) where+ gZipTables _ combine (K1 f) (K1 g) = do Columnar' h <- combine (Columnar' f :: Columnar' f a) (Columnar' g :: Columnar' g a)+ return (K1 (h :: Columnar h a)) instance ( Generic (PrimaryKey rel f)- , GAllValues f (Rep (PrimaryKey rel Exposed) ()) (Rep (PrimaryKey rel f) ()) ) =>- GAllValues f (K1 Generic.R (PrimaryKey rel Exposed) a) (K1 Generic.R (PrimaryKey rel f) a) where- gAllValues Proxy f (K1 x) =- gAllValues (Proxy :: Proxy (Rep (PrimaryKey rel Exposed) ())) f (from' x)-instance (FieldSchema x, fx ~ Columnar f x) => GAllValues f (K1 Generic.R (Exposed x) a) (K1 Generic.R fx a) where- gAllValues Proxy f (K1 a) = [f (Columnar' a :: Columnar' f x)]+ , Generic (PrimaryKey rel g)+ , Generic (PrimaryKey rel h) --- instance FieldSchema x => GAllValues f (K1 Generic.R (Nullable f x) a) where--- gAllValues f (K1 (Nullable a)) = [f a]--- instance ( Generic (PrimaryKey related g)--- , GAllValues f (Rep (PrimaryKey related g) ()) ) =>--- GAllValues f (K1 Generic.R (PrimaryKey related g) a) where--- gAllValues f (K1 (PrimaryKey x)) = gAllValues f (from' x)--- instance FieldSchema a => GAllValues f (f a) where--- gAllValues f x = [f x]+ , GZipTables f g h (Rep (PrimaryKey rel Exposed)) (Rep (PrimaryKey rel f)) (Rep (PrimaryKey rel g)) (Rep (PrimaryKey rel h))) =>+ GZipTables f g h (K1 Generic.R (PrimaryKey rel Exposed)) (K1 Generic.R (PrimaryKey rel f)) (K1 Generic.R (PrimaryKey rel g)) (K1 Generic.R (PrimaryKey rel h)) where+ gZipTables _ combine (K1 f) (K1 g) = do hRep <- gZipTables (Proxy :: Proxy (Rep (PrimaryKey rel Exposed))) combine (from' f) (from' g)+ return (K1 (to' hRep)) -type AllValues f xf xExposed = ( Generic xf- , Generic xExposed- , GAllValues f (Rep xExposed ()) (Rep xf ()))+instance ( Generic (PrimaryKey rel (Nullable f))+ , Generic (PrimaryKey rel (Nullable g))+ , Generic (PrimaryKey rel (Nullable h)) -allValues' :: AllValues f xf xExposed =>- Proxy xExposed -> (forall a. FieldSchema a => Columnar' f a -> b) -> xf -> [b]-allValues' (Proxy :: Proxy xExposed) f x =- gAllValues (Proxy :: Proxy (Rep xExposed ())) f (from' x)+ , GZipTables f g h (Rep (PrimaryKey rel (Nullable Exposed))) (Rep (PrimaryKey rel (Nullable f))) (Rep (PrimaryKey rel (Nullable g))) (Rep (PrimaryKey rel (Nullable h)))) =>+ GZipTables f g h+ (K1 Generic.R (PrimaryKey rel (Nullable Exposed)))+ (K1 Generic.R (PrimaryKey rel (Nullable f)))+ (K1 Generic.R (PrimaryKey rel (Nullable g)))+ (K1 Generic.R (PrimaryKey rel (Nullable h))) where+ gZipTables _ combine (K1 f) (K1 g) = do hRep <- gZipTables (Proxy :: Proxy (Rep (PrimaryKey rel (Nullable Exposed)))) combine (from' f) (from' g)+ return (K1 (to' hRep)) class GDefaultTableFieldSettings x where gDefTblFieldSettings :: Proxy x -> x@@ -455,10 +393,10 @@ instance (GDefaultTableFieldSettings (a p), GDefaultTableFieldSettings (b p)) => GDefaultTableFieldSettings ((a :*: b) p) where gDefTblFieldSettings (_ :: Proxy ((a :*: b) p)) = gDefTblFieldSettings (Proxy :: Proxy (a p)) :*: gDefTblFieldSettings (Proxy :: Proxy (b p)) -instance (Table table, FieldSchema field, Selector f ) =>+instance (Table table, HasDefaultFieldSchema field, Selector f ) => GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where gDefTblFieldSettings (_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = M1 (K1 s)- where s = defFieldSettings (T.pack name)+ where s = TableField (T.pack name) [] defFieldSchema name = unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (TableField table field)) ())) instance ( Table table, Table related@@ -466,9 +404,9 @@ , Generic (PrimaryKey related (TableField related)) , Generic (PrimaryKey related (TableField table))- , GChangeRep (Rep (PrimaryKey related Exposed) ())- (Rep (PrimaryKey related (TableField related)) ()) (Rep (PrimaryKey related (TableField table)) ())- (TableField related) (TableField table) ) =>+ , GZipTables (TableField related) (TableField related) (TableField table)+ (Rep (PrimaryKey related Exposed))+ (Rep (PrimaryKey related (TableField related))) (Rep (PrimaryKey related (TableField related))) (Rep (PrimaryKey related (TableField table))) ) => GDefaultTableFieldSettings (S1 f (K1 Generic.R (PrimaryKey related (TableField table))) p) where gDefTblFieldSettings _ = M1 . K1 $ primaryKeySettings'@@ -477,11 +415,11 @@ primaryKeySettings = primaryKey tableSettings primaryKeySettings' :: PrimaryKey related (TableField table)- primaryKeySettings' = to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey related Exposed) ())) convertToForeignKeyField (from' primaryKeySettings))+ primaryKeySettings' = to' (runIdentity (gZipTables (Proxy :: Proxy (Rep (PrimaryKey related Exposed))) convertToForeignKeyField (from' primaryKeySettings) (from' primaryKeySettings))) - convertToForeignKeyField :: Columnar' (TableField related) c -> Columnar' (TableField table) c- convertToForeignKeyField (Columnar' tf) =- Columnar' $+ convertToForeignKeyField :: Columnar' (TableField related) c -> Columnar' (TableField related) c -> Identity (Columnar' (TableField table) c)+ convertToForeignKeyField (Columnar' tf) _ =+ pure . Columnar' $ tf { _fieldName = keyName <> "__" <> _fieldName tf , _fieldConstraints = removeConstraints (_fieldConstraints tf) } @@ -496,11 +434,16 @@ , Generic (PrimaryKey related (TableField related)) , Generic (PrimaryKey related (TableField table)) , Generic (PrimaryKey related (Nullable (TableField table)))- , GChangeRep (Rep (PrimaryKey related Exposed) ())- (Rep (PrimaryKey related (TableField table)) ()) (Rep (PrimaryKey related (Nullable (TableField table))) ())- (TableField table) (Nullable (TableField table))- , GChangeRep (Rep (PrimaryKey related Exposed) ())- (Rep (PrimaryKey related (TableField related)) ()) (Rep (PrimaryKey related (TableField table)) ()) (TableField related) (TableField table) ) =>+ , GZipTables (TableField table) (TableField table) (Nullable (TableField table))+ (Rep (PrimaryKey related Exposed))+ (Rep (PrimaryKey related (TableField table)))+ (Rep (PrimaryKey related (TableField table)))+ (Rep (PrimaryKey related (Nullable (TableField table))))+ , GZipTables (TableField related) (TableField related) (TableField table)+ (Rep (PrimaryKey related Exposed))+ (Rep (PrimaryKey related (TableField related)))+ (Rep (PrimaryKey related (TableField related)))+ (Rep (PrimaryKey related (TableField table)))) => GDefaultTableFieldSettings (S1 f (K1 Generic.R (PrimaryKey related (Nullable (TableField table)))) p) where gDefTblFieldSettings _ =@@ -509,61 +452,24 @@ nonNullSettingsRep = from' nonNullSettings :: Rep (PrimaryKey related (TableField table)) () settings :: PrimaryKey related (Nullable (TableField table))- settings = to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey related Exposed) ())) removeNotNullConstraints nonNullSettingsRep)-- removeNotNullConstraints :: Columnar' (TableField table) ty -> Columnar' (Nullable (TableField table)) ty- removeNotNullConstraints (Columnar' tf) =- Columnar' $- tf { _fieldSettings = MaybeFieldSettings (_fieldSettings tf) }--class GFromSqlValues (ty :: * -> *) (schema :: * -> *) where- gFromSqlValues :: Proxy ty -> FromSqlValuesM (schema a)-instance GFromSqlValues ty x => GFromSqlValues (M1 s f ty) (M1 s f x) where- gFromSqlValues _ = M1 <$> gFromSqlValues (Proxy :: Proxy ty)-instance FieldSchema x => GFromSqlValues (K1 Generic.R (Exposed x)) (K1 Generic.R x) where- gFromSqlValues _ = K1 <$> fromSqlValue-instance FieldSchema (BeamEnum x) => GFromSqlValues (K1 Generic.R (Exposed (BeamEnum x))) (K1 Generic.R x) where- gFromSqlValues _ = K1 . unBeamEnum <$> fromSqlValue-instance (GFromSqlValues t1 a, GFromSqlValues t2 b) => GFromSqlValues (t1 :*: t2) (a :*: b) where- gFromSqlValues _ = (:*:) <$> gFromSqlValues (Proxy :: Proxy t1) <*> gFromSqlValues (Proxy :: Proxy t2)-instance ( Generic (PrimaryKey related f)- , GFromSqlValues (Rep (PrimaryKey related Exposed)) (Rep (PrimaryKey related f)) ) =>- GFromSqlValues (K1 Generic.R (PrimaryKey related Exposed)) (K1 Generic.R (PrimaryKey related f)) where-- gFromSqlValues _ = K1 . to' <$> gFromSqlValues (Proxy :: Proxy (Rep (PrimaryKey related Exposed)))--- instance FieldSchema (Maybe x) => GFromSqlValues (K1 Generic.R (Nullable Column x)) where--- gFromSqlValues = K1 . Nullable . Column <$> fromSqlValue--class GMakeSqlValues ty x sql where- gMakeSqlValues :: Proxy ty -> x -> sql-instance GMakeSqlValues (ty a) (p a) (sql a) => GMakeSqlValues (M1 s f ty a) (M1 s f p a) (M1 s f sql a) where- gMakeSqlValues _ (M1 x) = M1 (gMakeSqlValues (Proxy :: Proxy (ty a)) x)-instance (GMakeSqlValues (t1 a) (f a) (sql1 a), GMakeSqlValues (t2 a) (g a) (sql2 a)) => GMakeSqlValues ((t1 :*: t2) a) ((f :*: g) a) ((sql1 :*: sql2) a) where- gMakeSqlValues _ (f :*: g) = gMakeSqlValues (Proxy :: Proxy (t1 a)) f :*: gMakeSqlValues (Proxy :: Proxy (t2 a)) g-instance GMakeSqlValues (U1 x) (U1 a) (U1 sql) where- gMakeSqlValues _ _ = U1-instance FieldSchema x => GMakeSqlValues (K1 Generic.R (Exposed x) a) (K1 Generic.R x a) (K1 Generic.R (SqlValue' x) a) where- gMakeSqlValues _ (K1 x) = K1 (SqlValue' (makeSqlValue x))-instance FieldSchema (BeamEnum x) => GMakeSqlValues (K1 Generic.R (Exposed (BeamEnum x)) a) (K1 Generic.R x a) (K1 Generic.R (SqlValue' (BeamEnum x)) a) where- gMakeSqlValues _ (K1 x) = K1 (SqlValue' (makeSqlValue (BeamEnum x)))--- instance FieldSchema x => GMakeSqlValues (K1 Generic.R (Nullable Column x) a) where--- gMakeSqlValues (K1 (Nullable x)) = [makeSqlValue (columnValue x)]-instance ( Generic (PrimaryKey related f)- , Generic (PrimaryKey related SqlValue')- , GMakeSqlValues (Rep (PrimaryKey related Exposed) ()) (Rep (PrimaryKey related f) ()) (Rep (PrimaryKey related SqlValue') ()) ) =>- GMakeSqlValues (K1 Generic.R (PrimaryKey related Exposed) a) (K1 Generic.R (PrimaryKey related f) a) (K1 Generic.R (PrimaryKey related SqlValue') ()) where- gMakeSqlValues _ (K1 x) = K1 (to' (gMakeSqlValues (Proxy :: Proxy (Rep (PrimaryKey related Exposed) ())) (from' x)))--class ( Show (FieldSettings fs), Typeable fs- , Show fs ) => FieldSchema fs where- data FieldSettings fs :: *+ settings = to' (runIdentity (gZipTables (Proxy :: Proxy (Rep (PrimaryKey related Exposed))) removeNotNullConstraints nonNullSettingsRep nonNullSettingsRep)) - defSettings :: FieldSettings fs+ removeNotNullConstraints :: Columnar' (TableField table) ty -> Columnar' (TableField table) ty -> Identity (Columnar' (Nullable (TableField table)) ty)+ removeNotNullConstraints (Columnar' tf) _ =+ pure . Columnar' $+ tf { _fieldSchema = maybeFieldSchema (_fieldSchema tf) } - colDescFromSettings :: FieldSettings fs -> SQLColumnSchema+data FieldSchema ty = FieldSchema+ { fsColDesc :: SQLColumnSchema+ , fsHumanReadable :: String+ , fsMakeSqlValue :: ty -> SqlValue+ , fsFromSqlValue :: FromSqlValuesM ty }+instance Show (FieldSchema ty) where+ show (FieldSchema desc hr _ _) = concat ["FieldSchema (", show desc, ") (", show hr, ") _ _"] - makeSqlValue :: fs -> SqlValue- fromSqlValue :: FromSqlValuesM fs+-- | Type class for types which can construct a default 'TableField' given a column name.+class HasDefaultFieldSchema fs where+ defFieldSchema :: FieldSchema fs type FromSqlValuesM a = ErrorT String (State [SqlValue]) a popSqlValue, peekSqlValue :: FromSqlValuesM SqlValue@@ -574,13 +480,16 @@ class FromSqlValues a where fromSqlValues' :: FromSqlValuesM a valuesNeeded :: Proxy a -> Int-- default fromSqlValues' :: FieldSchema a => FromSqlValuesM a- fromSqlValues' = fromSqlValue- default valuesNeeded :: FieldSchema a => Proxy a -> Int valuesNeeded _ = 1++ default fromSqlValues' :: HasDefaultFieldSchema a => FromSqlValuesM a+ fromSqlValues' = fsFromSqlValue defFieldSchema instance Table tbl => FromSqlValues (tbl Identity) where- fromSqlValues' = tableFromSqlValues+ fromSqlValues' = zipTablesM combine settings settings+ where settings :: TableSettings tbl+ settings = tblFieldSettings++ combine (Columnar' tf) x = Columnar' <$> fsFromSqlValue (_fieldSchema tf) valuesNeeded _ = tableValuesNeeded (Proxy :: Proxy tbl) instance (FromSqlValues a, FromSqlValues b) => FromSqlValues (a, b) where fromSqlValues' = (,) <$> fromSqlValues' <*> fromSqlValues'@@ -588,37 +497,12 @@ instance (FromSqlValues a, FromSqlValues b, FromSqlValues c) => FromSqlValues (a, b, c) where fromSqlValues' = (,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c)--instance FieldSchema Int where- data FieldSettings Int = IntFieldDefault- deriving Show- defSettings = IntFieldDefault- colDescFromSettings _ = notNull- SqlColDesc- { colType = SqlNumericT- , colSize = Nothing- , colOctetLength = Nothing- , colDecDigits = Nothing- , colNullable = Nothing }- makeSqlValue i = SqlInteger (fromIntegral i)- fromSqlValue = fromSql <$> popSqlValue-instance FromSqlValues Int--instance FieldSchema a => FieldSchema (Maybe a) where- data FieldSettings (Maybe a) = MaybeFieldSettings (FieldSettings a)-- defSettings = MaybeFieldSettings defSettings-- colDescFromSettings (MaybeFieldSettings settings) = let SQLColumnSchema desc constraints = colDescFromSettings settings- in SQLColumnSchema desc (filter (/=SQLNotNull) constraints)-- makeSqlValue Nothing = SqlNull- makeSqlValue (Just x) = makeSqlValue x- fromSqlValue = do val <- peekSqlValue- case val of- SqlNull -> Nothing <$ popSqlValue- val -> Just <$> fromSqlValue-deriving instance Show (FieldSettings a) => Show (FieldSettings (Maybe a))+instance (FromSqlValues a, FromSqlValues b, FromSqlValues c, FromSqlValues d) => FromSqlValues (a, b, c, d) where+ fromSqlValues' = (,,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues'+ valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c) + valuesNeeded (Proxy :: Proxy d)+instance (FromSqlValues a, FromSqlValues b, FromSqlValues c, FromSqlValues d, FromSqlValues e) => FromSqlValues (a, b, c, d, e) where+ fromSqlValues' = (,,,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues'+ valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c) + valuesNeeded (Proxy :: Proxy d) + valuesNeeded (Proxy :: Proxy e) -- Internal functions @@ -642,3 +526,17 @@ unCamelCaseSel xs = case unCamelCase xs of [xs] -> xs _:xs -> intercalate "_" xs++maybeFieldSchema :: FieldSchema ty -> FieldSchema (Maybe ty)+maybeFieldSchema base = let SQLColumnSchema desc constraints = fsColDesc base+ in FieldSchema+ { fsColDesc = SQLColumnSchema desc (filter (/=SQLNotNull) constraints)+ , fsHumanReadable = "maybeFieldSchema (" ++ fsHumanReadable base ++ ")"+ , fsMakeSqlValue = \x ->+ case x of+ Nothing -> SqlNull+ Just x -> fsMakeSqlValue base x+ , fsFromSqlValue = do val <- peekSqlValue+ case val of+ SqlNull -> Nothing <$ popSqlValue+ val -> Just <$> fsFromSqlValue base }