relational-query 0.8.5.1 → 0.8.6.0
raw patch · 13 files changed
+143/−89 lines, 13 filesdep ~names-thdep ~persistable-recordPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: names-th, persistable-record
API changes (from Hackage documentation)
- Database.Relational.Query.SQL: insertSizedChunkSQL :: Pi r r' -> Table r -> Int -> (String, Int)
+ Database.Relational.Query.Monad.BaseType: relationWidth :: Relation p r -> PersistableRecordWidth r
+ Database.Relational.Query.Pi: pzero :: Pi a ()
+ Database.Relational.Query.Pi.Unsafe: instance Control.Category.Category Database.Relational.Query.Pi.Unsafe.Pi
+ Database.Relational.Query.Pi.Unsafe: instance Database.Record.Persistable.PersistableWidth r0 => GHC.Show.Show (Database.Relational.Query.Pi.Unsafe.Pi r0 r1)
+ Database.Relational.Query.Pi.Unsafe: pzero :: Pi a ()
+ Database.Relational.Query.Pi.Unsafe: unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int]
+ Database.Relational.Query.Projection: wpi :: PersistableRecordWidth a -> Projection c a -> Pi a b -> Projection c b
+ Database.Relational.Query.Pure: instance Database.Relational.Query.Pure.ShowConstantTermsSQL ()
+ Database.Relational.Query.Table: recordWidth :: Table r -> PersistableRecordWidth r
- Database.Relational.Query.Pi: id' :: PersistableWidth a => Pi a a
+ Database.Relational.Query.Pi: id' :: Pi a a
- Database.Relational.Query.Pi.Unsafe: pi :: [a] -> Pi r0 r1 -> [a]
+ Database.Relational.Query.Pi.Unsafe: pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a]
- Database.Relational.Query.Pi.Unsafe: unsafeExpandIndexes :: Pi a b -> [Int]
+ Database.Relational.Query.Pi.Unsafe: unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int]
- Database.Relational.Query.Pi.Unsafe: width :: Pi r a -> Int
+ Database.Relational.Query.Pi.Unsafe: width :: PersistableWidth r => Pi r a -> Int
- Database.Relational.Query.Pi.Unsafe: width' :: Pi r ct -> PersistableRecordWidth ct
+ Database.Relational.Query.Pi.Unsafe: width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct
- Database.Relational.Query.ProjectableExtended: (!) :: Projection c a -> Pi a b -> Projection c b
+ Database.Relational.Query.ProjectableExtended: (!) :: PersistableWidth a => Projection c a -> Pi a b -> Projection c b
- Database.Relational.Query.ProjectableExtended: (!??) :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -> Pi a b -> Projection cont c
+ Database.Relational.Query.ProjectableExtended: (!??) :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -> Pi a b -> Projection cont c
- Database.Relational.Query.ProjectableExtended: (?!) :: Projection c (Maybe a) -> Pi a b -> Projection c (Maybe b)
+ Database.Relational.Query.ProjectableExtended: (?!) :: PersistableWidth a => Projection c (Maybe a) -> Pi a b -> Projection c (Maybe b)
- Database.Relational.Query.ProjectableExtended: (?!?) :: Projection c (Maybe a) -> Pi a (Maybe b) -> Projection c (Maybe b)
+ Database.Relational.Query.ProjectableExtended: (?!?) :: PersistableWidth a => Projection c (Maybe a) -> Pi a (Maybe b) -> Projection c (Maybe b)
- Database.Relational.Query.ProjectableExtended: flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -> Pi a b -> Projection cont c
+ Database.Relational.Query.ProjectableExtended: flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -> Pi a b -> Projection cont c
- Database.Relational.Query.Projection: pi :: Projection c a -> Pi a b -> Projection c b
+ Database.Relational.Query.Projection: pi :: PersistableWidth a => Projection c a -> Pi a b -> Projection c b
- Database.Relational.Query.Projection: piMaybe :: Projection c (Maybe a) -> Pi a b -> Projection c (Maybe b)
+ Database.Relational.Query.Projection: piMaybe :: PersistableWidth a => Projection c (Maybe a) -> Pi a b -> Projection c (Maybe b)
- Database.Relational.Query.Projection: piMaybe' :: Projection c (Maybe a) -> Pi a (Maybe b) -> Projection c (Maybe b)
+ Database.Relational.Query.Projection: piMaybe' :: PersistableWidth a => Projection c (Maybe a) -> Pi a (Maybe b) -> Projection c (Maybe b)
- Database.Relational.Query.SQL: insertSQL :: Pi r r' -> Table r -> String
+ Database.Relational.Query.SQL: insertSQL :: PersistableWidth r => Pi r r' -> Table r -> String
Files
- ChangeLog.md +7/−0
- relational-query.cabal +2/−2
- src/Database/Relational/Query/Derives.hs +2/−2
- src/Database/Relational/Query/Monad/BaseType.hs +10/−2
- src/Database/Relational/Query/Monad/Trans/Assigning.hs +2/−2
- src/Database/Relational/Query/Pi.hs +5/−4
- src/Database/Relational/Query/Pi/Unsafe.hs +61/−27
- src/Database/Relational/Query/ProjectableExtended.hs +10/−6
- src/Database/Relational/Query/Projection.hs +22/−10
- src/Database/Relational/Query/Pure.hs +4/−0
- src/Database/Relational/Query/Relation.hs +2/−3
- src/Database/Relational/Query/SQL.hs +10/−29
- src/Database/Relational/Query/Table.hs +6/−2
ChangeLog.md view
@@ -1,10 +1,17 @@ <!-- -*- Markdown -*- --> +## 0.8.6.0++- add Show instance of Pi.+- add pzero and ConstantTermsSQL instance of ().+- add Category instance of Pi.+ ## 0.8.5.1 - add tested-with 8.2.1. ## 0.8.5.0+ - Add derivedInsertValue definitions to arrow interface. - Apply chunked-insert to derivedInsertValue.
relational-query.cabal view
@@ -1,5 +1,5 @@ name: relational-query-version: 0.8.5.1+version: 0.8.6.0 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can@@ -90,7 +90,7 @@ , th-reify-compat , sql-words >=0.1.4 , names-th- , persistable-record >=0.3 && <0.5+ , persistable-record >=0.4.2 && <0.5 hs-source-dirs: src ghc-options: -Wall -fsimpl-tick-factor=200
src/Database/Relational/Query/Derives.hs view
@@ -38,7 +38,7 @@ import Database.Relational.Query.Projectable (placeholder, (.=.)) import Database.Relational.Query.ProjectableExtended ((!)) import Database.Relational.Query.Monad.Class (wheres)-import Database.Relational.Query.Monad.BaseType (Relation)+import Database.Relational.Query.Monad.BaseType (Relation, relationWidth) import Database.Relational.Query.Relation (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) import Database.Relational.Query.Constraint@@ -55,7 +55,7 @@ -> Relation p a -- ^ Result restricted 'Relation' specifiedKey key rel = relation' $ do q <- query rel- (param, ()) <- placeholder (\ph -> wheres $ q ! key .=. ph)+ (param, ()) <- placeholder (\ph -> wheres $ Projection.wpi (relationWidth rel) q key .=. ph) return (param, q) -- | Query restricted with specified unique key.
src/Database/Relational/Query/Monad/BaseType.hs view
@@ -14,7 +14,7 @@ qualifyQuery, askConfig, -- * Relation type- Relation, unsafeTypeRelation, untypeRelation,+ Relation, unsafeTypeRelation, untypeRelation, relationWidth, dump, sqlFromRelationWith, sqlFromRelation,@@ -25,10 +25,12 @@ import Data.Functor.Identity (Identity, runIdentity) import Control.Applicative ((<$>)) +import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth)+ import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) -import Database.Relational.Query.Sub (Qualified, SubQuery, showSQL)+import Database.Relational.Query.Sub (Qualified, SubQuery, showSQL, width) import qualified Database.Relational.Query.Monad.Trans.Qualify as Qualify import Database.Relational.Query.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) import Database.Relational.Query.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig)@@ -59,6 +61,12 @@ -- | Sub-query Qualify monad from relation. untypeRelation :: Relation p r -> ConfigureQuery SubQuery untypeRelation (SubQuery qsub) = qsub++-- | 'PersistableRecordWidth' of 'Relation' type.+relationWidth :: Relation p r -> PersistableRecordWidth r+relationWidth rel =+ unsafePersistableRecordWidth . width $ configureQuery (untypeRelation rel) defaultConfig+ --- Assume that width is independent from Config structure unsafeCastPlaceHolder :: Relation a r -> Relation b r unsafeCastPlaceHolder (SubQuery qsub) = SubQuery qsub
src/Database/Relational/Query/Monad/Trans/Assigning.hs view
@@ -35,7 +35,7 @@ import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Pi (Pi)-import Database.Relational.Query.Table (Table)+import Database.Relational.Query.Table (Table, recordWidth) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..))@@ -63,7 +63,7 @@ type AssignTarget r v = Pi r v targetProjection :: AssignTarget r v -> Table r -> Projection Flat v-targetProjection pi' tbl = Projection.pi (Projection.unsafeFromTable tbl) pi'+targetProjection pi' tbl = Projection.wpi (recordWidth tbl) (Projection.unsafeFromTable tbl) pi' -- | Add an assignment. assignTo :: Monad m => Projection Flat v -> AssignTarget r v -> Assignings r m ()
src/Database/Relational/Query/Pi.hs view
@@ -11,23 +11,24 @@ -- Contains normal interfaces. module Database.Relational.Query.Pi ( -- * Projection path- Pi, pfmap, pap, (<.>), (<?.>), (<?.?>),+ Pi, pfmap, pap, pzero, (<.>), (<?.>), (<?.?>), id', fst', snd' ) where +import qualified Control.Category as Category import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Query.Pi.Unsafe- (Pi, pfmap, pap, (<.>), (<?.>), (<?.?>), definePi)+ (Pi, pfmap, pap, pzero, (<.>), (<?.>), (<?.?>), definePi) -- | Identity projection path.-id' :: PersistableWidth a => Pi a a-id' = definePi 0+id' :: Pi a a+id' = Category.id -- | Projection path for fst of tuple. fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst.
src/Database/Relational/Query/Pi/Unsafe.hs view
@@ -3,7 +3,7 @@ -- | -- Module : Database.Relational.Query.Pi.Unsafe--- Copyright : 2013 Kei Hibino+-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -18,6 +18,8 @@ pfmap, pap, + pzero,+ width', width, (<.>), (<?.>), (<?.?>),@@ -26,10 +28,12 @@ definePi, defineDirectPi', defineDirectPi, + unsafeExpandIndexes', unsafeExpandIndexes ) where -import Prelude hiding (pi)+import Prelude hiding (pi, (.), id)+import Control.Category (Category (..), (>>>)) import Data.Array (listArray, (!)) import Database.Record.Persistable@@ -52,20 +56,30 @@ -- | Projection path from type 'r0' into type 'r1'. -- This type also indicate key object which type is 'r1' for record type 'r0'.-data Pi r0 r1 = Pi (Pi' r0 r1) (PersistableRecordWidth r1)+newtype Pi r0 r1 = Pi { runPi :: PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1) } -unsafePiAppend :: (PersistableRecordWidth c' -> PersistableRecordWidth c)- -> Pi a b' -> Pi b c' -> Pi a c-unsafePiAppend f (Pi p0 _) (Pi p1 w) =- Pi (p0 `unsafePiAppend'` p1) (f w)+instance PersistableWidth r0 => Show (Pi r0 r1) where+ show p = unwords ["Pi", show $ unsafeExpandIndexes p] +unsafePiAppend :: (PersistableRecordWidth b' -> PersistableRecordWidth b)+ -> (PersistableRecordWidth c' -> PersistableRecordWidth c)+ -> Pi a b' -> Pi b c' -> Pi a c+unsafePiAppend wbf wcf (Pi f) (Pi g) = Pi $ \wa ->+ let (pab, wb) = f wa+ (pbc, wc) = g $ wbf wb+ in (pab `unsafePiAppend'` pbc, wcf wc)+ -- | Unsafely untype key to expand indexes.-unsafeExpandIndexes :: Pi a b -> [Int]-unsafeExpandIndexes = d where- d (Pi (Map is) _) = is- d (Pi (Leftest i) w) = [ i .. i + w' - 1 ] where+unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int]+unsafeExpandIndexes' wa (Pi f) = d $ f wa where+ d (Map is, _) = is+ d (Leftest i, w) = [ i .. i + w' - 1 ] where w' = runPersistableRecordWidth w +-- | Unsafely untype key to expand indexes.+unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int]+unsafeExpandIndexes = unsafeExpandIndexes' persistableWidth+ -- | Unsafely cast width proof object of record. Result record must be same width. unsafeCastRecordWidth :: PersistableRecordWidth a -> PersistableRecordWidth a' unsafeCastRecordWidth = unsafePersistableRecordWidth . runPersistableRecordWidth@@ -74,7 +88,9 @@ unsafeCast = c where d (Leftest i) = Leftest i d (Map m) = Map m- c (Pi p w) = Pi (d p) (unsafeCastRecordWidth w)+ c (Pi f) = Pi $ \wa ->+ let (pb, wb) = f wa in+ (d pb, unsafeCastRecordWidth wb) -- | Projectable fmap of 'Pi' type. pfmap :: ProductConstructor (a -> b)@@ -83,37 +99,55 @@ -- | Projectable ap of 'Pi' type. pap :: Pi r (a -> b) -> Pi r a -> Pi r b-pap b@(Pi _ wb) c@(Pi _ wc) =- Pi- (Map $ unsafeExpandIndexes b ++ unsafeExpandIndexes c)- (unsafeCastRecordWidth $ wb <&> wc)+pap pab pb =+ Pi $ \wr ->+ let (_, wab) = runPi pab wr+ (_, wb) = runPi pb wr in+ (Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb,+ unsafeCastRecordWidth $ wab <&> wb) {- should switch to safe projectable-applicative -} +-- | 'Pi' with zero width which projects to unit+pzero :: Pi a ()+pzero = Pi $ \_ -> (Map [], persistableWidth)+ -- | Get record width proof object.-width' :: Pi r ct -> PersistableRecordWidth ct-width' (Pi _ w) = w+width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct+width' (Pi f) = snd $ f persistableWidth -- | Get record width.-width :: Pi r a -> Int+width :: PersistableWidth r => Pi r a -> Int width = runPersistableRecordWidth . width' +justWidth :: PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a+justWidth = unsafeCastRecordWidth+++instance Category Pi where+ id = Pi $ \pw -> (Leftest 0, pw)+ Pi fb . Pi fa = Pi $ \wa ->+ let (pb, wb) = fa wa+ (pc, wc) = fb wb+ in (unsafePiAppend' pb pc, wc)+ -- | Compose projection path. (<.>) :: Pi a b -> Pi b c -> Pi a c-(<.>) = unsafePiAppend id+(<.>) = (>>>) -- | Compose projection path. 'Maybe' phantom functor is 'map'-ed. (<?.>) :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)-(<?.>) = unsafePiAppend maybeWidth+(<?.>) = unsafePiAppend justWidth maybeWidth -- | Compose projection path. 'Maybe' phantom functors are 'join'-ed like '>=>'. (<?.?>) :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c)-(<?.?>) = unsafePiAppend id+(<?.?>) = unsafePiAppend justWidth id infixl 8 <.>, <?.>, <?.?> -- | Unsafely project untyped value list.-pi :: [a] -> Pi r0 r1 -> [a]-pi cs (Pi p' w) = d p' where- d (Leftest i) = take (runPersistableRecordWidth w) . drop i $ cs+pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a]+pi w0 (Pi f) cs = d p' where+ (p', w1) = f w0+ d (Leftest i) = take (runPersistableRecordWidth w1) . drop i $ cs d (Map is) = [cs' ! i | i <- is] cs' = listArray (0, length cs) cs @@ -121,7 +155,7 @@ definePi' :: PersistableRecordWidth r1 -> Int -- ^ Index of flat SQL value list -> Pi r0 r1 -- ^ Result projection path-definePi' pw i = Pi (Leftest i) pw+definePi' pw i = Pi $ \_ -> (Leftest i, pw) -- | Unsafely define projection path from type 'r0' into type 'r1'. -- Use inferred 'PersistableRecordWidth'.@@ -134,7 +168,7 @@ defineDirectPi' :: PersistableRecordWidth r1 -> [Int] -- ^ Indexes of flat SQL value list -> Pi r0 r1 -- ^ Result projection path-defineDirectPi' pw is = Pi (Map is) pw+defineDirectPi' pw is = Pi $ \_ -> (Map is, pw) -- | Unsafely define projection path from type 'r0' into type 'r1'. -- Use inferred 'PersistableRecordWidth'.
src/Database/Relational/Query/ProjectableExtended.hs view
@@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.ProjectableExtended--- Copyright : 2013 Kei Hibino+-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -38,6 +38,7 @@ import Prelude hiding (pi) import qualified Language.SQL.Keyword as SQL+import Database.Record (PersistableWidth) import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) import Database.Relational.Query.Projection (Projection)@@ -119,14 +120,16 @@ some' = unsafeAggregateOp SQL.SOME -- | Get narrower projection along with projection path.-(!) :: Projection c a -- ^ Source projection+(!) :: PersistableWidth a+ => Projection c a -- ^ Source projection -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower projected object (!) = Projection.pi -- | Get narrower projection along with projection path -- 'Maybe' phantom functor is 'map'-ed.-(?!) :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type+(?!) :: PersistableWidth a+ => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a b -- ^ Projection path -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result (?!) = Projection.piMaybe@@ -134,7 +137,8 @@ -- | Get narrower projection along with projection path -- and project into result projection type. -- Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed.-(?!?) :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type+(?!?) :: PersistableWidth a+ => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result (?!?) = Projection.piMaybe'@@ -154,14 +158,14 @@ flatten = id -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path.-flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)+flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Projection cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type flattenPiMaybe p = flatten . Projection.piMaybe p -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path.-(!??) :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)+(!??) :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Projection cont c -- ^ Narrower flatten and projected object.
src/Database/Relational/Query/Projection.hs view
@@ -27,6 +27,7 @@ -- * Projections pi, piMaybe, piMaybe',+ wpi, flattenMaybe, just, @@ -44,7 +45,8 @@ import qualified Language.SQL.Keyword as SQL -import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint)+import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint, PersistableWidth, persistableWidth)+import Database.Record.Persistable (PersistableRecordWidth) import qualified Database.Record.KeyConstraint as KeyConstraint import Database.Relational.Query.Internal.SQL (StringSQL, listStringSQL, )@@ -103,30 +105,40 @@ -- | Unsafely trace projection path.-unsafeProject :: Projection c a' -> Pi a b -> Projection c b'-unsafeProject p pi' =+unsafeProject :: PersistableRecordWidth a -> Projection c a' -> Pi a b -> Projection c b'+unsafeProject w p pi' = Internal.projectFromColumns- . (`UnsafePi.pi` pi')+ . (UnsafePi.pi w pi') . columns $ p -- | Trace projection path to get narrower 'Projection'.-pi :: Projection c a -- ^ Source 'Projection'+wpi :: PersistableRecordWidth a+ -> Projection c a -- ^ Source 'Projection'+ -> Pi a b -- ^ Projection path+ -> Projection c b -- ^ Narrower 'Projection'+wpi = unsafeProject++-- | Trace projection path to get narrower 'Projection'.+pi :: PersistableWidth a+ => Projection c a -- ^ Source 'Projection' -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower 'Projection'-pi = unsafeProject+pi = unsafeProject persistableWidth -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type.-piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type+piMaybe :: PersistableWidth a+ => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a b -- ^ Projection path -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result-piMaybe = unsafeProject+piMaybe = unsafeProject persistableWidth -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. -- Leaf type of projection path is 'Maybe'.-piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type+piMaybe' :: PersistableWidth a+ => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result-piMaybe' = unsafeProject+piMaybe' = unsafeProject persistableWidth unsafeCast :: Projection c r -> Projection c r' unsafeCast = typedProjection . untypeProjection
src/Database/Relational/Query/Pure.hs view
@@ -81,6 +81,10 @@ showConstantTermsSQL :: ShowConstantTermsSQL a => a -> [String] showConstantTermsSQL = map showStringSQL . showConstantTermsSQL' +-- | Constant SQL terms of '()'.+instance ShowConstantTermsSQL () where+ showConstantTermsSQL' () = []+ -- | Constant SQL terms of 'Int8'. instance ShowConstantTermsSQL Int8 where showConstantTermsSQL' = intTermsSQL
src/Database/Relational/Query/Relation.hs view
@@ -47,7 +47,7 @@ import Database.Relational.Query.Context (Flat, Aggregated) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery,- Relation, unsafeTypeRelation, untypeRelation)+ Relation, unsafeTypeRelation, untypeRelation, relationWidth) import Database.Relational.Query.Monad.Class (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), on) import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)@@ -66,7 +66,6 @@ import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, projectZip)-import Database.Relational.Query.ProjectableExtended ((!)) -- | Simple 'Relation' from 'Table'.@@ -371,7 +370,7 @@ -> UniqueRelation ph Flat b aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do (ph, a) <- query' rel- return (ph, ag $ a ! k)+ return (ph, ag $ Projection.wpi (relationWidth rel) a k) -- | Scalar sub-query with place-holder parameter 'p'. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)
src/Database/Relational/Query/SQL.hs view
@@ -20,7 +20,7 @@ updateOtherThanKeySQL', updateOtherThanKeySQL, -- * Insert SQL- insertPrefixSQL, insertSQL, insertSizedChunkSQL,+ insertPrefixSQL, insertSQL, -- * Delete SQL deletePrefixSQL', deletePrefixSQL@@ -31,6 +31,7 @@ import Language.SQL.Keyword (Keyword(..), (.=.), (|*|)) import qualified Language.SQL.Keyword as SQL+import Database.Record (PersistableWidth) import Database.Record.ToSql (untypedUpdateValuesIndex) import Database.Relational.Query.Internal.SQL@@ -38,7 +39,7 @@ import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi-import Database.Relational.Query.Table (Table, name, columns)+import Database.Relational.Query.Table (Table, name, columns, recordWidth) import qualified Database.Relational.Query.Projection as Projection @@ -89,43 +90,23 @@ -> Pi r p -- ^ Key columns -> String -- ^ Result SQL updateOtherThanKeySQL tbl key =- updateOtherThanKeySQL' (name tbl) (columns tbl) (UnsafePi.unsafeExpandIndexes key)+ updateOtherThanKeySQL' (name tbl) (columns tbl) (UnsafePi.unsafeExpandIndexes' (recordWidth tbl) key) -- | Generate prefix string of insert SQL. insertPrefixSQL :: Pi r r' -> Table r -> StringSQL insertPrefixSQL pi' table = INSERT <> INTO <> stringSQL (name table) <> rowConsStringSQL cols where- cols = Projection.columns . Projection.pi (Projection.unsafeFromTable table) $ pi'--{-# DEPRECATED insertChunkSQL "Deprecated." #-}--- | Generate records chunk insert SQL.-insertChunkSQL :: Int -- ^ Records count to insert- -> Pi r r' -- ^ Columns selector to insert- -> Table r -- ^ Table metadata- -> String -- ^ Result SQL-insertChunkSQL n0 pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs where- n | n0 >= 1 = n0- | otherwise = error $ "Invalid chunk count value: " ++ show n0- w = UnsafePi.width pi'- vs = SQL.fold (|*|) . replicate n $ rowConsStringSQL (replicate w "?")--{-# DEPRECATED insertSizedChunkSQL "Deprecated." #-}--- | Generate size measured records chunk insert SQL.-insertSizedChunkSQL :: Pi r r' -- ^ Columns selector to insert- -> Table r -- ^ Table metadata- -> Int -- ^ Chunk size threshold (column count)- -> (String, Int) -- ^ Result SQL and records count of chunk-insertSizedChunkSQL pi' tbl th = (insertChunkSQL n pi' tbl, n) where- n | w <= 0 = th + 1- | otherwise = th `quot` w + 1- w = UnsafePi.width pi'+ cols = Projection.columns . Projection.wpi (recordWidth table) (Projection.unsafeFromTable table) $ pi' {-# DEPRECATED insertSQL "Deprecated." #-} -- | Generate insert SQL.-insertSQL :: Pi r r' -- ^ Columns selector to insert+insertSQL :: PersistableWidth r+ => Pi r r' -- ^ Columns selector to insert -> Table r -- ^ Table metadata -> String -- ^ Result SQL-insertSQL = insertChunkSQL 1+insertSQL pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs where+ w = UnsafePi.width pi'+ vs = rowConsStringSQL (replicate w "?") -- | Generate all column delete SQL by specified table. Untyped table version. deletePrefixSQL' :: String -> StringSQL
src/Database/Relational/Query/Table.hs view
@@ -10,7 +10,7 @@ -- This module defines table type which has table metadatas. module Database.Relational.Query.Table ( -- * Phantom typed table type- Table, unType, name, shortName, width, columns, index, table, toMaybe,+ Table, unType, name, shortName, width, columns, index, table, toMaybe, recordWidth, -- * Table existence inference TableDerivable (..)@@ -18,7 +18,7 @@ import Data.Array (listArray) -import Database.Record (PersistableWidth)+import Database.Record.Persistable (PersistableWidth, PersistableRecordWidth, unsafePersistableRecordWidth) import Database.Relational.Query.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!)) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, )@@ -66,3 +66,7 @@ -- | Inference rule of 'Table' existence. class PersistableWidth r => TableDerivable r where derivedTable :: Table r++-- | PersistableRecordWidth of table+recordWidth :: Table r -> PersistableRecordWidth r+recordWidth = unsafePersistableRecordWidth . width