packages feed

selda 0.3.2.0 → 0.3.3.0

raw patch · 17 files changed

+310/−139 lines, 17 files

Files

ChangeLog.md view
@@ -1,6 +1,13 @@ # Revision history for Selda  +## 0.3.3.0 -- 2018-09-01++* Ad hoc selectors using OverloadedLabels.+* Shorter build times.+* Minor API updates and simplifications.++ ## 0.3.2.0 -- 2018-08-07  * Some aggregates are now nullable.
README.md view
@@ -145,4 +145,3 @@ * Streaming * MySQL/MariaDB backend. * MSSQL backend.-* Automatically sanity check changelog, versions and date before release.
selda.cabal view
@@ -1,5 +1,5 @@ name:                selda-version:             0.3.2.0+version:             0.3.3.0 synopsis:            Multi-backend, high-level EDSL for interacting with SQL databases. description:         This package provides an EDSL for writing portable, type-safe, high-level                      database code. Its feature set includes querying and modifying databases,@@ -47,6 +47,7 @@     Database.Selda     Database.Selda.Backend     Database.Selda.Migrations+    Database.Selda.SqlType     Database.Selda.Unsafe     Database.Selda.Validation   other-modules:@@ -62,17 +63,20 @@     Database.Selda.Query     Database.Selda.Query.Type     Database.Selda.Selectors+    Database.Selda.Selectors.MakeSelectors     Database.Selda.SQL     Database.Selda.SQL.Print     Database.Selda.SQL.Print.Config     Database.Selda.SqlRow-    Database.Selda.SqlType     Database.Selda.Table     Database.Selda.Table.Compile     Database.Selda.Table.Type     Database.Selda.Table.Validation     Database.Selda.Transform     Database.Selda.Types+  if impl(ghc >= 7.11)+    other-modules:+      Database.Selda.Selectors.FieldSelectors   other-extensions:     OverloadedStrings     GADTs
src/Database/Selda.hs view
@@ -28,9 +28,8 @@   , Table, Query, Row, Col, Res, Result   , query, queryInto   , transaction, setLocalCache, withoutForeignKeyEnforcement+     -- * Constructing queries-  , Selector, Source, Selected, (!), Assignment ((:=)), with-  , (+=), (-=), (*=), (||=), (&&=), ($=)   , SqlType (..), SqlRow (..), SqlEnum (..)   , Columns   , Order (..)@@ -40,52 +39,71 @@   , order, ascending, descending   , orderRandom   , inner, suchThat++    -- * Working with selectors+  , Selector, Coalesce+#if MIN_VERSION_base(4, 9, 0)+  , HasField, FieldType, IsLabel+#endif+  , (!), (?), Assignment ((:=)), with+  , (+=), (-=), (*=), (||=), (&&=), ($=)+     -- * Expressions over columns   , Set (..)-  , ID, invalidId, isInvalidId, untyped, toId+  , ID, invalidId, isInvalidId, untyped, fromId, toId   , RowID, invalidRowId, isInvalidRowId, fromRowId, toRowId   , (.==), (./=), (.>), (.<), (.>=), (.<=), like   , (.&&), (.||), not_-  , literal, int, float, text, true, false, null_+  , literal, is, int, float, text, true, false, null_   , roundTo, length_, isNull, ifThenElse, ifNull, matchNull   , new, only   , Mappable (..)+     -- * Converting between column types   , round_, just, fromBool, fromInt, toString+     -- * Inner queries   , Aggr, Aggregates, OuterCols, AggrCols, LeftCols, Inner, SqlOrd   , innerJoin, leftJoin   , aggregate, groupBy   , count, avg, sum_, max_, min_+     -- * Modifying tables   , insert, insert_, insertWithPK, tryInsert, insertUnless, insertWhen, def   , update, update_, upsert   , deleteFrom, deleteFrom_+     -- * Prepared statements   , Preparable, Prepare   , prepared+     -- * Defining schemas   , Generic   , TableName, ColName, Attr (..), Attribute-  , Selectors, ForeignKey (..)+  , Selectors, GSelectors, ForeignKey (..)   , table, tableFieldMod, tableWithSelectors, selectors   , primary, autoPrimary, untypedAutoPrimary, unique   , IndexMethod (..), index, indexUsing+     -- * Creating and dropping tables   , createTable, tryCreateTable   , dropTable, tryDropTable+     -- * Compiling and inspecting queries   , OnError (..)   , compile   , compileCreateTable, compileDropTable   , compileInsert, compileUpdate+     -- * Tuple convenience functions   , Tup, Head   , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth+     -- * Useful re-exports-  , MonadIO, liftIO+  , MonadIO, MonadMask, liftIO   , Text, Day, TimeOfDay, UTCTime   ) where+import Control.Monad.Catch (MonadMask) import Data.Typeable (Typeable) import Database.Selda.Backend import Database.Selda.Column@@ -97,9 +115,9 @@ import Database.Selda.Query import Database.Selda.Query.Type import Database.Selda.Selectors+import Database.Selda.Selectors.MakeSelectors import Database.Selda.SQL hiding (distinct) import Database.Selda.SqlRow-import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile import Database.Selda.Table.Validation@@ -114,6 +132,7 @@ import Unsafe.Coerce  #if MIN_VERSION_base(4, 9, 0)+import Database.Selda.Selectors.FieldSelectors import GHC.TypeLits as TL #endif @@ -215,10 +234,10 @@ -- > q2 = do -- >   person <- select people -- >   return (person ! name)-from :: (Typeable a, SqlType b)-     => Selector (Source a) b-     -> Query s (Row s a)-     -> Query s (Col s (Selected a b))+from :: (Typeable t, SqlType a)+     => Selector t a+     -> Query s (Row s t)+     -> Query s (Col s a) from s q = (! s) <$> q infixr 7 `from` @@ -343,6 +362,11 @@ -- >   return (name ! sName) just :: SqlType a => Col s a -> Col s (Maybe a) just = cast++-- | Returns 'true' if the given field in the given row is equal to the given+--   literal.+is :: SqlType c => Selector r c -> c -> Row s r -> Col s Bool+is s x r = r ! s .== literal x  -- | SQL NULL, at any type you like. null_ :: SqlType a => Col s (Maybe a)
src/Database/Selda/Backend.hs view
@@ -3,22 +3,23 @@ module Database.Selda.Backend   ( MonadSelda (..), SeldaT, SeldaM, SeldaError (..)   , StmtID, BackendID (..), QueryRunner, SeldaBackend (..), SeldaConnection-  , SqlType (..), SqlValue (..), SqlTypeRep (..)+  , SqlValue (..)   , IndexMethod (..)-  , Param (..), Lit (..), ColAttr (..)+  , Param (..), ColAttr (..)   , PPConfig (..), defPPConfig   , TableName, ColName, ColumnInfo (..)   , columnInfo, fromColInfo   , mkTableName, mkColName, fromTableName, fromColName, rawTableName   , newConnection, allStmts, seldaBackend   , runSeldaT, seldaClose-  , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat+  , module SqlType   ) where import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Data.IORef import Database.Selda.Backend.Internal+import Database.Selda.SqlType as SqlType import Database.Selda.Table (IndexMethod (..)) import Database.Selda.Types
src/Database/Selda/Backend/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures #-} -- | Internal backend API. module Database.Selda.Backend.Internal   ( StmtID, BackendID (..)@@ -218,7 +218,7 @@ --   'wrapTransaction' flush the entire cache and disable caching when --   invoked. If you want to use Selda's built-in caching mechanism, you will --   need to implement these operations yourself.-class (MonadIO m, MonadMask m) => MonadSelda m where+class MonadIO m => MonadSelda m where   -- | Get the connection in use by the computation.   seldaConnection :: m SeldaConnection @@ -245,6 +245,7 @@                   -> m () -- ^ Signal transaction rollback to SQL backend.                   -> m a  -- ^ Transaction to perform.                   -> m a+  default wrapTransaction :: MonadMask m => m () -> m () -> m a -> m a   wrapTransaction commit rollback act = do     bracketOnError (pure ())                    (const rollback)
src/Database/Selda/Frontend.hs view
@@ -92,7 +92,7 @@ -- --   Like 'insert', if even one of the inserted rows would cause a constraint --   violation, the whole insert operation fails.-tryInsert :: (MonadSelda m, Relational a) => Table a -> [a] -> m Bool+tryInsert :: (MonadSelda m, MonadCatch m, Relational a) => Table a -> [a] -> m Bool tryInsert tbl row = do   mres <- try $ insert tbl row   case mres of@@ -241,7 +241,7 @@ --   will be rolled back and the exception re-thrown, even if the exception --   is caught and handled within the transaction. transaction :: MonadSelda m => m a -> m a-transaction m =+transaction m = do   wrapTransaction (void $ exec "COMMIT" []) (void $ exec "ROLLBACK" []) $ do     exec "BEGIN TRANSACTION" [] *> m @@ -253,7 +253,7 @@ --   Use with extreme caution, preferably only for migrations. -- --   On the PostgreSQL backend, at least PostgreSQL 9.6 is required.-withoutForeignKeyEnforcement :: MonadSelda m => m a -> m a+withoutForeignKeyEnforcement :: (MonadSelda m, MonadMask m) => m a -> m a withoutForeignKeyEnforcement m = do   b <- seldaBackend   bracket_ (liftIO $ disableForeignKeys b True)@@ -309,4 +309,8 @@ exec :: MonadSelda m => Text -> [Param] -> m Int exec q ps = do   backend <- seldaBackend-  fmap fst . liftIO $ runStmt backend q ps+  liftIO $ execIO backend q ps++-- | Like 'exec', but in 'IO'.+execIO :: SeldaBackend -> Text -> [Param] -> IO Int+execIO backend q ps = fmap fst $ runStmt backend q ps
src/Database/Selda/Generic.hs view
@@ -19,17 +19,16 @@ #if MIN_VERSION_base(4, 9, 0) import qualified GHC.TypeLits as TL import qualified GHC.Generics as G ((:+:)(..))+import qualified Database.Selda.Column as C (Col) #endif import Control.Exception (Exception (..), try, throw) import System.IO.Unsafe import Database.Selda.Types-import Database.Selda.Selectors import Database.Selda.SqlType import Database.Selda.SqlRow (SqlRow) import Database.Selda.Table.Type import Database.Selda.SQL (Param (..)) import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..))-import qualified Database.Selda.Column as C (Col) #if !MIN_VERSION_base(4, 11, 0) import Data.Monoid #endif@@ -45,7 +44,6 @@   ( Generic a   , SqlRow a   , GRelation (Rep a)-  , GSelectors a (Rep a)   )  -- | Extract all insert parameters from a generic value.
src/Database/Selda/Migrations.hs view
@@ -39,7 +39,7 @@ -- --   The migration is performed as a migration, ensuring that either the entire --   migration passes, or none of it does.-migrate :: (MonadSelda m, Relational a, Relational b)+migrate :: (MonadSelda m, MonadMask m, Relational a, Relational b)         => Table a -- ^ Table to migrate from.         -> Table b -- ^ Table to migrate to.         -> (Row () a -> Row () b)@@ -49,20 +49,20 @@  -- | Like 'migrate', but allows the column upgrade to access --   the entire database.-migrateM :: (MonadSelda m, Relational a, Relational b)+migrateM :: (MonadSelda m, MonadMask m, Relational a, Relational b)          => Table a          -> Table b          -> (Row s a -> Query s (Row s b))          -> m () migrateM t1 t2 upg = migrateAll True [Migration t1 t2 upg] -wrap :: MonadSelda m => Bool -> m a -> m a+wrap :: (MonadSelda m, MonadMask m) => Bool -> m a -> m a wrap enforceFKs   | enforceFKs = transaction   | otherwise  = withoutForeignKeyEnforcement  -- | Perform all given migrations as a single transaction.-migrateAll :: MonadSelda m+migrateAll :: (MonadSelda m, MonadMask m)            => Bool -- ^ Enforce foreign keys during migration?            -> MigrationStep -- ^ Migration step to perform.            -> m ()@@ -82,7 +82,7 @@ --   indexed columns are not taken into account. Two columns @c1@ and @c2@ are --   considered to be identical if @c1@ is indexed with index method @foo@ and --   @c2@ is indexed with index method @bar@.-autoMigrate :: MonadSelda m+autoMigrate :: (MonadSelda m, MonadMask m)             => Bool -- ^ Enforce foreign keys during migration?             -> [MigrationStep] -- ^ Migration steps to perform.             -> m ()@@ -110,7 +110,7 @@ -- | Workhorse for migration. --   Is NOT performed as a transaction, so exported functions need to --   properly wrap calls this function.-migrateInternal :: (MonadSelda m, Relational a, Relational b)+migrateInternal :: (MonadSelda m, MonadThrow m, Relational a, Relational b)                 => Table a                 -> Table b                 -> (Row s a -> Query s (Row s b))
src/Database/Selda/Query.hs view
@@ -11,8 +11,7 @@ import Database.Selda.Inner import Database.Selda.Query.Type import Database.Selda.SQL as SQL-import Database.Selda.SqlType (SqlType, Lit (LNull), SqlTypeRep (..))-import Database.Selda.SqlRow (SqlRow (nestedCols))+import Database.Selda.SqlType (SqlType) import Database.Selda.Table import Database.Selda.Transform import Control.Monad.State.Strict
src/Database/Selda/Selectors.hs view
@@ -1,49 +1,40 @@-{-# LANGUAGE ScopedTypeVariables, TypeFamilies, MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts, RankNTypes, AllowAmbiguousTypes, GADTs #-}-{-# LANGUAGE DeriveGeneric, CPP #-}+{-# LANGUAGE TypeFamilies, GADTs, CPP #-} module Database.Selda.Selectors-  ( Assignment ((:=)), Selected, Selector, Source, Selectors, GSelectors-  , (!), with, ($=)-  , selectorsFor, selectorIndex, unsafeSelector+  ( Assignment ((:=)), Selector, Coalesce+  , (!), (?), with, ($=)+  , selectorIndex, unsafeSelector   ) where-import Control.Monad.State.Strict import Database.Selda.SqlRow (SqlRow) import Database.Selda.SqlType-import Database.Selda.Types import Database.Selda.Column import Data.List (foldl')-import Data.Proxy-import GHC.Generics hiding (Selector, (:*:))-import qualified GHC.Generics as G import Unsafe.Coerce --- | The result of a '(!)' operation.---   If either the source row, the column to extract,---   or both, is nullable, the result is also nullable.-type family Selected a b where-  Selected (Maybe a) (Maybe b) = Maybe b-  Selected (Maybe a) b         = Maybe b-  Selected a         b         = b---- | The source type of a '(!)' operation.-type family Source a where-  Source (Maybe a) = a-  Source a         = a+-- | Coalesce nested nullable column into a single level of nesting.+type family Coalesce a where+  Coalesce (Maybe (Maybe a)) = Coalesce (Maybe a)+  Coalesce a                 = a  -- | A selector indicating the nth (zero-based) column of a table. -- --   Will cause errors in queries during compilation, execution, or both, --   unless handled with extreme care. You really shouldn't use it at all.-unsafeSelector :: SqlRow a => Int -> Selector a b+unsafeSelector :: (SqlRow a, SqlType b) => Int -> Selector a b unsafeSelector = Selector  -- | Extract the given column from the given row.---   Extracting a value from a nullable column will yield a nullable value.---   In other words, this operator is null-coalescing.-(!) :: SqlType b => Row s a -> Selector (Source a) b -> Col s (Selected a b)+(!) :: SqlType a => Row s t -> Selector t a -> Col s a (Many xs) ! (Selector i) = case xs !! i of Untyped x -> One (unsafeCoerce x)+infixl 9 ! +-- | Extract the given column from the given nullable row.+--   Nullable rows usually result from left joins.+--   If a nullable column is extracted from a nullable row, the resulting+--   nested @Maybe@s will be squashed into a single level of nesting.+(?) :: SqlType a => Row s (Maybe t) -> Selector t a -> Col s (Coalesce (Maybe a))+Many xs ? Selector i = case xs !! i of Untyped x -> One (unsafeCoerce x)+infixl 9 ?+ upd :: Row s a -> Assignment s a -> Row s a upd (Many xs) (Selector i := (One x')) =   case splitAt i xs of@@ -84,41 +75,3 @@ --   'with' functions to get and set values on rows, or to specify --   foreign keys. newtype Selector t a = Selector {selectorIndex :: Int}---- | Generate selectors for the given type.-selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r-selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r))---- | An inductive tuple of selectors for the given relation.-type Selectors r = Sels r (Rep r)--type family Sels t f where-  Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))-  Sels t (a G.:*: b)           = Sels t a :*: Sels t b-  Sels t (M1 x y f)            = Sels t f-  Sels t (K1 i a)              = Selector t a---- | Any table type that can have selectors generated.-class GSelectors t (f :: * -> *) where-  mkSel :: Proxy f -> Proxy t -> State Int (Sels t f)--instance SqlType a => GSelectors t (K1 i a) where-  mkSel _ _ = Selector <$> state (\n -> (n, n+1))--instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>-         GSelectors t (M1 x y f) where-  mkSel _ = mkSel (Proxy :: Proxy f)--instance GSelectors t (a G.:*: (b G.:*: c)) =>-         GSelectors t ((a G.:*: b) G.:*: c) where-  mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c)))--instance {-# OVERLAPPABLE #-}-  ( GSelectors t a-  , GSelectors t b-  , Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)-  ) => GSelectors t (a G.:*: b) where-    mkSel _ p = do-      x <- mkSel (Proxy :: Proxy a) p-      xs <- mkSel (Proxy :: Proxy b) p-      return (x :*: xs)
+ src/Database/Selda/Selectors/FieldSelectors.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DataKinds, KindSignatures, TypeOperators, PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-}+{-# LANGUAGE TypeApplications, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Create Selda selectors from plain record field selectors.+--   Requires the @OverloadedLabels@ language extension.+module Database.Selda.Selectors.FieldSelectors+  (FieldType, HasField, IsLabel+  ) where+import Database.Selda.Generic (Relational)+import Database.Selda.Selectors as S+import Database.Selda.SqlType (SqlType)+import Data.Kind (Constraint)+import GHC.Generics+import GHC.TypeLits+import GHC.OverloadedLabels++-- | Get the next nested type.+type family GetFieldType (f :: * -> *) :: * where+  GetFieldType (M1 c i f) = GetFieldType f+  GetFieldType (K1 i a)   = a++-- | Get the type of the field @name@ from the generic representation @a@,+--   returning the default value @b@ if the field does not exist.+type family GFieldType (a :: * -> *) (b :: *) (name :: Symbol) :: * where+  GFieldType (M1 S ('MetaSel ('Just name) su ss ds) f) b name = GetFieldType f+  GFieldType (M1 c i a) b name = GFieldType a b name+  GFieldType (a :*: b) c name  = GFieldType a (GFieldType b c name) name+  GFieldType a b name          = b++-- | The type of the @name@ field, in the record type @t@.+type FieldType name t = GFieldType (Rep t) (NoSuchSelector t name) name++type family NonError (t :: k) :: Constraint where+  NonError (NoSuchSelector t s) = TypeError+    ( 'Text "Row type '" ':<>: 'ShowType t ':<>:+      'Text "' has no selector " ':<>: 'ShowType s ':<>: 'Text "."+    )+  NonError t = ()++-- | Internal representation of the "no such selector" error message.+data NoSuchSelector (t :: *) (s :: Symbol)++-- | Any table type @t@, which has a field named @name@.+class ( Relational t+      , SqlType (FieldType name t)+      , GRSel name (Rep t)+      , NonError (FieldType name t)) =>+  HasField (name :: Symbol) t++instance ( Relational t+         , SqlType (FieldType name t)+         , GRSel name (Rep t)+         , NonError (FieldType name t)) =>+  HasField (name :: Symbol) t++instance (Relational t, HasField name t, FieldType name t ~ a) =>+         IsLabel name (S.Selector t a) where+#if MIN_VERSION_base(4, 10, 0)+  fromLabel = field @name @t+#else+  fromLabel _ = field @name @t+#endif++-- | Create a selector from a record selector and a type application.+--+--   For example:+-- > data Foo = Foo+-- >   { foo :: Int+-- >   , bar :: Text+-- >   } deriving Generic+-- > instance SqlRow Foo+-- >+-- > fooTable :: Table Foo+-- > fooTable = table "foo"+-- >+-- > getAllBars :: Query s (Col s Text)+-- > getAllBars = do+-- >   t <- select fooTable+-- >   return (t ! field @"bar")+field :: forall name t.+       (Relational t, HasField name t)+    => S.Selector t (FieldType name t)+field =+  case gSel @name @(Rep t) 0 of+    Left n -> unsafeSelector n+    _      -> error "unreachable"++class GRSel (s :: Symbol) (f :: * -> *) where+  gSel :: Int -> Either Int Int++instance GRSel name (M1 S ('MetaSel ('Just name) su ss ds) f) where+  gSel = Left++instance {-# OVERLAPPABLE #-} GRSel name f => GRSel name (M1 i s f) where+  gSel = gSel @name @f++instance (GRSel name a, GRSel name b) => GRSel name (a :*: b) where+  gSel n = gSel @name @a n >>= gSel @name @b . succ++instance GRSel name (K1 i a) where+  gSel = Right
+ src/Database/Selda/Selectors/MakeSelectors.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE ScopedTypeVariables, TypeOperators, KindSignatures #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+-- | Utilities for creating selectors for non-record types.+--   Importing this module may significantly increase compilation times.+module Database.Selda.Selectors.MakeSelectors+ ( Selectors, GSelectors+ , selectors, tableWithSelectors+ ) where+import Control.Monad.State.Strict+import Data.Proxy+import GHC.Generics hiding (Selector, (:*:))+import qualified GHC.Generics as G+import Database.Selda.Generic (Relational)+import Database.Selda.Selectors+import Database.Selda.SqlRow+import Database.Selda.SqlType+import Database.Selda.Table+import Database.Selda.Types++-- | Generate selector functions for the given table.+--   Selectors can be used to access the fields of a query result tuple, avoiding+--   the need to pattern match on the entire tuple.+--+-- > tbl :: Table (Int, Text)+-- > tbl = table "foo" []+-- > (tblBar :*: tblBaz) = selectors tbl+-- >+-- > q :: Query s Text+-- > q = do+-- >   row <- select tbl+-- >   return (row ! tblBaz)+selectors :: forall a. (Relational a, GSelectors a (Rep a))+          => Table a+          -> Selectors a+selectors _ = selectorsFor (Proxy :: Proxy a)++-- | A pair of the table with the given name and columns, and all its selectors.+--   For example:+--+-- > tbl :: Table (Int, Text)+-- > (tbl, tblBar :*: tblBaz)+-- >   =  tableWithSelectors "foo" []+-- >+-- > q :: Query s Text+-- > q = tblBaz `from` select tbl+tableWithSelectors :: forall a. (Relational a, GSelectors a (Rep a))+                   => TableName+                   -> [Attr a]+                   -> (Table a, Selectors a)+tableWithSelectors name cs = (t, s)+  where+    t = table name cs+    s = selectors t++-- | Generate selectors for the given type.+selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r+selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r))++-- | An inductive tuple of selectors for the given relation.+type Selectors r = Sels r (Rep r)++type family Sels t f where+  Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))+  Sels t (a G.:*: b)           = Sels t a :*: Sels t b+  Sels t (M1 x y f)            = Sels t f+  Sels t (K1 i a)              = Selector t a++-- | Any table type that can have selectors generated.+class GSelectors t (f :: * -> *) where+  mkSel :: Proxy f -> Proxy t -> State Int (Sels t f)++instance (SqlRow t, SqlType a) => GSelectors t (K1 i a) where+  mkSel _ _ = unsafeSelector <$> state (\n -> (n, n+1))++instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>+         GSelectors t (M1 x y f) where+  mkSel _ = mkSel (Proxy :: Proxy f)++instance GSelectors t (a G.:*: (b G.:*: c)) =>+         GSelectors t ((a G.:*: b) G.:*: c) where+  mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c)))++instance {-# OVERLAPPABLE #-}+  ( GSelectors t a+  , GSelectors t b+  , Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)+  ) => GSelectors t (a G.:*: b) where+    mkSel _ p = do+      x <- mkSel (Proxy :: Proxy a) p+      xs <- mkSel (Proxy :: Proxy b) p+      return (x :*: xs)
src/Database/Selda/SqlRow.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds #-} {-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeOperators, DefaultSignatures, ScopedTypeVariables, CPP #-} #if MIN_VERSION_base(4, 10, 0)@@ -12,6 +12,9 @@ import Database.Selda.SqlType import Data.Typeable import GHC.Generics+#if MIN_VERSION_base(4, 9, 0)+import qualified GHC.TypeLits as TL+#endif  newtype ResultReader a = R (State [SqlValue] a)   deriving (Functor, Applicative, Monad)@@ -51,6 +54,16 @@   gNextResult = liftM2 (:*:) gNextResult gNextResult   gNestedCols _ = gNestedCols (Proxy :: Proxy a) + gNestedCols (Proxy :: Proxy b) +#if MIN_VERSION_base(4, 9, 0)+instance+  (TL.TypeError+    ( 'TL.Text "Selda currently does not support creating tables from sum types."+      'TL.:$$:+      'TL.Text "Restrict your table type to a single data constructor."+    )) => GSqlRow (a :+: b) where+  gNextResult = error "unreachable"+  gNestedCols = error "unreachable"+#endif  -- * Various instances instance SqlRow a => SqlRow (Maybe a) where
src/Database/Selda/SqlType.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances, DefaultSignatures #-}--- | Types representable in Selda's subset of SQL.+-- | Types representable as columns in Selda's subset of SQL. module Database.Selda.SqlType   ( SqlType (..), SqlEnum (..)-  , Lit (..), RowID, ID (..), SqlValue (..), SqlTypeRep (..)+  , Lit (..), RowID, ID, SqlValue (..), SqlTypeRep (..)   , invalidRowId, isInvalidRowId, toRowId, fromRowId-  , toId, invalidId, isInvalidId+  , fromId, toId, invalidId, isInvalidId, untyped   , compLit, litType   , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat   ) where@@ -216,6 +216,11 @@ --   Use with caution, preferably only when reading user input. toId :: Int -> ID a toId = ID . toRowId++-- | Create a typed row identifier from an integer.+--   Use with caution, preferably only when reading user input.+fromId :: ID a -> Int+fromId (ID i) = fromRowId i  -- | A typed row identifier which is guaranteed to not match any row in any --   table.
src/Database/Selda/Table.hs view
@@ -7,7 +7,7 @@   ( Attr (..), Table (..), Attribute   , ColInfo (..), ColAttr (..), IndexMethod (..)   , ForeignKey (..)-  , table, tableFieldMod, tableWithSelectors, selectors+  , table, tableFieldMod -- , tableWithSelectors, selectors   , primary, autoPrimary, untypedAutoPrimary, unique   , index, indexUsing   , tableExpr@@ -108,39 +108,6 @@ -- | Remove duplicate attributes. tidy :: ColInfo -> ColInfo tidy ci = ci {colAttrs = snub $ colAttrs ci}---- | A pair of the table with the given name and columns, and all its selectors.---   For example:------ > tbl :: Table (Int, Text)--- > (tbl, tblBar :*: tblBaz)--- >   =  tableWithSelectors "foo" []--- >--- > q :: Query s Text--- > q = tblBaz `from` select tbl-tableWithSelectors :: forall a. Relational a-                   => TableName-                   -> [Attr a]-                   -> (Table a, Selectors a)-tableWithSelectors name cs = (t, s)-  where-    t = table name cs-    s = selectors t---- | Generate selector functions for the given table.---   Selectors can be used to access the fields of a query result tuple, avoiding---   the need to pattern match on the entire tuple.------ > tbl :: Table (Int, Text)--- > tbl = table "foo" []--- > (tblBar :*: tblBaz) = selectors tbl--- >--- > q :: Query s Text--- > q = do--- >   row <- select tbl--- >   return (row ! tblBaz)-selectors :: forall a. Relational a => Table a -> Selectors a-selectors _ = selectorsFor (Proxy :: Proxy a)  -- | Some attribute that may be set on a column of type @c@, in a table of --   type @t@.
src/Database/Selda/Validation.hs view
@@ -26,7 +26,7 @@ --   database. --   Throws a 'ValidationError' if the schema does not validate, or if --   inconsistencies were found.-validateTable :: MonadSelda m => Table a -> m ()+validateTable :: (MonadSelda m, MonadThrow m) => Table a -> m () validateTable t = do   validateSchema t   diffs <- diffTable t