diff --git a/beam.cabal b/beam.cabal --- a/beam.cabal +++ b/beam.cabal @@ -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 + diff --git a/src/Database/Beam.hs b/src/Database/Beam.hs --- a/src/Database/Beam.hs +++ b/src/Database/Beam.hs @@ -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 diff --git a/src/Database/Beam/Backend.hs b/src/Database/Beam/Backend.hs --- a/src/Database/Beam/Backend.hs +++ b/src/Database/Beam/Backend.hs @@ -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' diff --git a/src/Database/Beam/Query.hs b/src/Database/Beam/Query.hs --- a/src/Database/Beam/Query.hs +++ b/src/Database/Beam/Query.hs @@ -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 diff --git a/src/Database/Beam/Query/Combinators.hs b/src/Database/Beam/Query/Combinators.hs --- a/src/Database/Beam/Query/Combinators.hs +++ b/src/Database/Beam/Query/Combinators.hs @@ -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 diff --git a/src/Database/Beam/Query/Internal.hs b/src/Database/Beam/Query/Internal.hs --- a/src/Database/Beam/Query/Internal.hs +++ b/src/Database/Beam/Query/Internal.hs @@ -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 diff --git a/src/Database/Beam/Query/Types.hs b/src/Database/Beam/Query/Types.hs --- a/src/Database/Beam/Query/Types.hs +++ b/src/Database/Beam/Query/Types.hs @@ -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) diff --git a/src/Database/Beam/SQL.hs b/src/Database/Beam/SQL.hs --- a/src/Database/Beam/SQL.hs +++ b/src/Database/Beam/SQL.hs @@ -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")) diff --git a/src/Database/Beam/SQL/Types.hs b/src/Database/Beam/SQL/Types.hs --- a/src/Database/Beam/SQL/Types.hs +++ b/src/Database/Beam/SQL/Types.hs @@ -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 diff --git a/src/Database/Beam/Schema/Fields.hs b/src/Database/Beam/Schema/Fields.hs --- a/src/Database/Beam/Schema/Fields.hs +++ b/src/Database/Beam/Schema/Fields.hs @@ -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 + diff --git a/src/Database/Beam/Schema/Tables.hs b/src/Database/Beam/Schema/Tables.hs --- a/src/Database/Beam/Schema/Tables.hs +++ b/src/Database/Beam/Schema/Tables.hs @@ -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 }