relational-query 0.8.4.0 → 0.8.5.0

raw patch · 14 files changed

+382/−86 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• relational-query.cabal +1/−1
• src/Database/Relational/Query/Arrow.hs +19/−3
• src/Database/Relational/Query/Constraint.hs +2/−2
• src/Database/Relational/Query/Effect.hs +43/−10
• src/Database/Relational/Query/Internal/BaseSQL.hs +21/−5
• src/Database/Relational/Query/Pi/Unsafe.hs +1/−1
• src/Database/Relational/Query/Projectable.hs +19/−11
• src/Database/Relational/Query/Relation.hs +1/−1
• src/Database/Relational/Query/SQL.hs +5/−1
• src/Database/Relational/Query/Type.hs +51/−13
• test/Lex.hs +4/−4
• test/sqlsEq.hs +33/−7
• test/sqlsEqArrow.hs +178/−27

@@ -1,5 +1,9 @@ <!-- -*- Markdown -*- --> +## 0.8.5.0+- Add derivedInsertValue definitions to arrow interface.+- Apply chunked-insert to derivedInsertValue.+ ## 0.8.4.0  - Fix of unsafeValueNull. ( https://github.com/khibino/haskell-relational-record/issues/55 )

@@ -1,5 +1,5 @@ name:                relational-query-version:             0.8.4.0+version:             0.8.5.0 synopsis:            Typeful, Modular, Relational, algebraic query engine description:         This package contiains typeful relation structure and                      relational-algebraic query building DSL which can

@@ -48,6 +48,7 @@   assign,    derivedUpdate', derivedUpdate,+  derivedInsertValue', derivedInsertValue,   derivedDelete', derivedDelete,    QueryA,@@ -58,7 +59,7 @@    Orderings, Window, Assignings, -  AssignStatement, RestrictedStatement,+  AssignStatement, Register, RestrictedStatement,   ) where  import Control.Category (Category)@@ -75,8 +76,10 @@    relation, relation', aggregateRelation, aggregateRelation', uniqueRelation',    groupBy', key, key', set, bkey, rollup, cube, groupingSets,    orderBy, asc, desc, partitionBy, over,-   derivedUpdate', derivedUpdate, derivedDelete', derivedDelete,-   QuerySimple, QueryAggregate, QueryUnique, Window)+   derivedUpdate', derivedUpdate,+   derivedInsertValue', derivedInsertValue,+   derivedDelete', derivedDelete,+   QuerySimple, QueryAggregate, QueryUnique, Window, Register) import qualified Database.Relational.Query as Monadic import Database.Relational.Query.Projection (ListProjection) import qualified Database.Relational.Query.Monad.Trans.Aggregating as Monadic@@ -126,6 +129,9 @@ -- | Arrow type corresponding to 'Monadic.AssignStatement' type AssignStatement r a = Assignings r Restrict (Projection Flat r) a +-- | Arrow type corresponding to 'Monadic.Register'+type Register r a = QueryA (Monadic.Register r) () a+ -- | Arrow type corresponding to 'Monadic.RestrictedStatement' type RestrictedStatement r a = QueryA Monadic.Restrict (Projection Flat r) a @@ -412,6 +418,16 @@ --   Make 'Update' from assigning statement arrow. derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p derivedUpdate = Monadic.derivedUpdate . runQueryA++-- | Same as 'Monadic.derivedInsertValue''.+--   Make 'Insert' from register arrow using configuration.+derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p+derivedInsertValue' config = Monadic.derivedInsertValue' config . ($ ()) . runQueryA++-- | Same as 'Monadic.derivedInsertValue'.+--   Make 'Insert' from register arrow.+derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p+derivedInsertValue = Monadic.derivedInsertValue . ($ ()) . runQueryA  -- | Same as 'Monadic.derivedDelete''. --   Make 'Update' from restrict statement arrow using configuration.

@@ -102,12 +102,12 @@   -- | Infer constraint key.   constraintKey :: Key c r ct --- | Infered 'Unique' constraint 'Key'.+-- | Inferred 'Unique' constraint 'Key'. --   Record type 'r' has unique key which type is 'ct' derived from primay key. derivedUniqueKey :: HasConstraintKey Primary r ct => Key Unique r ct derivedUniqueKey =  uniqueKey constraintKey --- -- | Infered 'NotNull' constraint 'Key'.+-- -- | Inferred 'NotNull' constraint 'Key'. -- --   Record type 'r' has not-null key which type is 'ct' derived from primay key. -- derivedNotNullKey :: HasConstraintKey Primary r ct => Key NotNull r ct -- derivedNotNullKey =  notNullKey constraintKey

@@ -19,30 +19,33 @@   updateTargetAllColumn, updateTargetAllColumn',    -- * Object to express insert terget.-  InsertTarget, insertTarget, insertTarget',+  InsertTarget, insertTarget, insertTarget', piRegister,    -- * Generate SQL from restriction.   sqlWhereFromRestriction,   sqlFromUpdateTarget,-  sqlFromInsertTarget+  sqlChunkFromInsertTarget,+  sqlFromInsertTarget,   ) where  import Data.Monoid ((<>))  import Language.SQL.Keyword (Keyword(..))-import Database.Record (PersistableWidth)+import Database.Record.Persistable (PersistableWidth) -import Database.Relational.Query.Internal.Config (Config, defaultConfig)+import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)-import Database.Relational.Query.Internal.BaseSQL (composeSets, composeValues)+import Database.Relational.Query.Internal.BaseSQL (composeSets, composeChunkValuesWithColumns) -import Database.Relational.Query.Pi (id')+import Database.Relational.Query.Pi (Pi, id')+import qualified Database.Relational.Query.Pi.Unsafe as Pi import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Sub (composeWhere) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable-  (PlaceHolders, placeholder, unitPlaceHolder, unsafeAddPlaceHolders, (><), rightId)+  (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders,+   pwPlaceholder, placeholder, (><), rightId) import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#)) import Database.Relational.Query.Monad.Restrict (RestrictedStatement) import qualified Database.Relational.Query.Monad.Restrict as Restrict@@ -151,7 +154,37 @@               -> InsertTarget p r insertTarget' = InsertTarget --- | SQL INSERT statement 'StringSQL' string from 'InsertTarget'+-- | parametalized 'Register' monad from 'Pi'+piRegister :: PersistableWidth r+           => Pi r r'+           -> Register r (PlaceHolders r')+piRegister pi' = do+  let (ph', ma) = pwPlaceholder (Pi.width' pi') (\ph -> pi' <-# ph)+  () <- ma+  return ph'++sqlChunkFromInsertTarget' :: Config+                          -> Int+                          -> Table r+                          -> InsertTarget p r+                          -> StringSQL+sqlChunkFromInsertTarget' config sz tbl (InsertTarget q) =+    INSERT <> INTO <> stringSQL (Table.name tbl) <> composeChunkValuesWithColumns sz (asR tbl)+  where+    (_ph, asR) = Register.extract q config++-- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget'+sqlChunkFromInsertTarget :: Config+                         -> Table r+                         -> InsertTarget p r+                         -> (StringSQL, Int)+sqlChunkFromInsertTarget config tbl it =+    (sqlChunkFromInsertTarget' config n tbl it, n)+  where+    th = chunksInsertSize config+    n  = (th + w - 1) `quot` w+    w  = Table.width tbl++-- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget' sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL-sqlFromInsertTarget config tbl (InsertTarget q) = INSERT <> INTO <> stringSQL (Table.name tbl) <> composeValues (asR tbl)-  where (_ph, asR) = Register.extract q config+sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1

@@ -11,7 +11,8 @@ module Database.Relational.Query.Internal.BaseSQL (   Duplication (..), showsDuplication,   Order (..), OrderColumn, OrderingTerm, composeOrderBy,-  AssignColumn, AssignTerm, Assignment, composeSets, composeValues,+  AssignColumn, AssignTerm, Assignment, composeSets,+  composeChunkValues, composeChunkValuesWithColumns,   ) where  import Data.Monoid (Monoid (..), (<>))@@ -70,7 +71,22 @@   assigns | null assignList = error "Update assignment list is null!"           | otherwise       = SET <> SQL.fold (|*|) assignList --- | Compose VALUES clause from ['Assignment'].-composeValues :: [Assignment] -> StringSQL-composeValues as = rowConsStringSQL cs <> VALUES <> rowConsStringSQL vs  where-  (cs, vs) = unzip as+-- | Compose VALUES clause from value expression list.+composeChunkValues :: Int         -- ^ record count per chunk+                   -> [StringSQL] -- ^ value expression list+                   -> Keyword+composeChunkValues n0 vs =+    VALUES <> cvs+  where+    n | n0 >= 1    =  n0+      | otherwise  =  error $ "Invalid record count value: " ++ show n0+    cvs = SQL.fold (|*|) . replicate n $ rowConsStringSQL vs++-- | Compose VALUES clause from value expression list.+composeChunkValuesWithColumns :: Int          -- ^ record count per chunk+                              -> [Assignment] -- ^+                              -> StringSQL+composeChunkValuesWithColumns sz as =+    rowConsStringSQL cs <> composeChunkValues sz vs+  where+    (cs, vs) = unzip as

@@ -18,7 +18,7 @@    pfmap, pap, -  width,+  width', width,    (<.>), (<?.>), (<?.?>), 

@@ -25,7 +25,7 @@    -- * Placeholders   PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,-  placeholder', placeholder, unitPlaceHolder,+  pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH,    -- * Projectable into SQL strings   ProjectableShowSql (unsafeShowSql'), unsafeShowSql,@@ -67,13 +67,12 @@ import Prelude hiding (pi)  import Data.String (IsString)-import Control.Applicative ((<$>))  import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL  import Database.Record-  (PersistableWidth, persistableWidth, PersistableRecordWidth, derivedWidth,+  (PersistableWidth, persistableWidth, PersistableRecordWidth,    HasColumnConstraint, NotNull) import Database.Record.Persistable (runPersistableRecordWidth) @@ -474,23 +473,32 @@  -- | No placeholder semantics unitPlaceHolder :: PlaceHolders ()-unitPlaceHolder =  unsafePlaceHolders+unitPlaceHolder = unsafePlaceHolders +-- | No placeholder semantics. Same as `unitPlaceHolder`+unitPH :: PlaceHolders ()+unitPH = unitPlaceHolder+ -- | Unsafely cast placeholder parameter type. unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b unsafeCastPlaceHolders PlaceHolders = PlaceHolders -unsafeProjectPlaceHolder' :: (PersistableWidth r, SqlProjectable p)-                               => (PersistableRecordWidth r, p r)-unsafeProjectPlaceHolder' =  unsafeProjectSqlTerms' . (`replicate` "?") <$> derivedWidth+-- | Provide scoped placeholder from width and return its parameter object.+pwPlaceholder :: SqlProjectable p+              => PersistableRecordWidth a+              -> (p a -> b)+              -> (PlaceHolders a, b)+pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw)+  where+    projectPlaceHolder :: SqlProjectable p+                       => PersistableRecordWidth a+                       -> p a+    projectPlaceHolder = unsafeProjectSqlTerms' . (`replicate` "?") . runPersistableRecordWidth -unsafeProjectPlaceHolder :: (PersistableWidth r, SqlProjectable p)-                               => p r-unsafeProjectPlaceHolder =  snd unsafeProjectPlaceHolder'  -- | Provide scoped placeholder and return its parameter object. placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) ->  (PlaceHolders t, a)-placeholder' f = (PlaceHolders, f unsafeProjectPlaceHolder)+placeholder' = pwPlaceholder persistableWidth  -- | Provide scoped placeholder and return its parameter object. Monadic version. placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a)

@@ -73,7 +73,7 @@ table :: Table r -> Relation () r table =  unsafeTypeRelation . return . SubQuery.fromTable --- | Infered 'Relation'.+-- | Inferred 'Relation'. derivedRelation :: TableDerivable r => Relation () r derivedRelation =  table derivedTable 

@@ -97,6 +97,7 @@   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@@ -108,15 +109,18 @@   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'-  n = th `quot` w + 1 +{-# DEPRECATED insertSQL "Deprecated." #-} -- | Generate insert SQL. insertSQL :: Pi r r' -- ^ Columns selector to insert           -> Table r -- ^ Table metadata

@@ -17,9 +17,10 @@   relationalQuerySQL,    -- * Typed update statement-  KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable,+  KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, derivedKeyUpdate,   Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate,-  typedUpdateAllColumn, restrictedUpdateAllColumn, restrictedUpdateTableAllColumn,+  typedUpdateAllColumn, derivedUpdateAllColumn', derivedUpdateAllColumn,+  restrictedUpdateAllColumn, restrictedUpdateTableAllColumn,    updateSQL, @@ -44,7 +45,7 @@  import Database.Record (PersistableWidth) -import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig)+import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (showStringSQL)  import Database.Relational.Query.Monad.BaseType (Relation, sqlFromRelationWith)@@ -54,12 +55,12 @@ import Database.Relational.Query.Relation (tableOf) import Database.Relational.Query.Effect   (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget',-   sqlWhereFromRestriction, sqlFromUpdateTarget, sqlFromInsertTarget)+   sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.SQL-  (QuerySuffix, showsQuerySuffix, insertPrefixSQL, insertSQL, insertSizedChunkSQL,+  (QuerySuffix, showsQuerySuffix, insertPrefixSQL,    updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL)  @@ -107,6 +108,13 @@ typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r typedKeyUpdateTable =  typedKeyUpdate . tableOf +-- derivedKeyUpdate'+-- Config parameter is not yet required for KeyUpdate.++-- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'.+derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r+derivedKeyUpdate = typedKeyUpdate derivedTable+ -- | Show update SQL string instance Show (KeyUpdate p a) where   show = untypeKeyUpdate@@ -144,6 +152,15 @@ derivedUpdate = derivedUpdate' defaultConfig  +-- | Make typed 'Update' from 'Config', 'Table' and 'Restriction'.+--   Update target is all column.+typedUpdateAllColumn' :: PersistableWidth r+                      => Config+                      -> Table r+                      -> Restriction p r+                      -> Update (r, p)+typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r+ -- | Make typed 'Update' from 'Table' and 'Restriction'. --   Update target is all column. typedUpdateAllColumn :: PersistableWidth r@@ -152,6 +169,22 @@                      -> Update (r, p) typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r +-- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'.+--   Update target is all column.+derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r)+                        => Config+                        -> RestrictedStatement r (PlaceHolders p)+                        -> Update (r, p)+derivedUpdateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction'++-- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'.+--   Update target is all column.+derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r)+                       => RestrictedStatement r (PlaceHolders p)+                       -> Update (r, p)+derivedUpdateAllColumn = derivedUpdateAllColumn' defaultConfig++{-# DEPRECATED restrictedUpdateAllColumn "Use derivedUpdateAllColumn or typedUpdateAllColumn instead of this." #-} -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. --   Update target is all column. restrictedUpdateAllColumn :: PersistableWidth r@@ -160,6 +193,7 @@                            -> Update (r, p) restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction' +{-# DEPRECATED restrictedUpdateTableAllColumn "Use derivedUpdateAllColumn or typedUpdateAllColumn instead of this." #-} -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. --   Update target is all column. restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r)@@ -197,22 +231,26 @@ unsafeTypedInsert s = Insert s Nothing  -- | Make typed 'Insert' from 'Table' and columns selector 'Pi' with configuration parameter.-typedInsert' :: Config -> Table r -> Pi r r' -> Insert r'-typedInsert' config tbl pi' = unsafeTypedInsert' (insertSQL pi' tbl) ci n  where-  (ci, n) = insertSizedChunkSQL pi' tbl $ chunksInsertSize config+typedInsert' :: PersistableWidth r => Config -> Table r -> Pi r r' -> Insert r'+typedInsert' config tbl =+  typedInsertValue' config tbl . insertTarget' . piRegister  -- | Make typed 'Insert' from 'Table' and columns selector 'Pi'.-typedInsert :: Table r -> Pi r r' -> Insert r'+typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r' typedInsert =  typedInsert' defaultConfig  -- | Table type inferred 'Insert'.-derivedInsert :: TableDerivable r => Pi r r' -> Insert r'-derivedInsert =  typedInsert derivedTable+derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'+derivedInsert = typedInsert derivedTable  -- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p-typedInsertValue' config tbl  =-  unsafeTypedInsert . showStringSQL . sqlFromInsertTarget config tbl+typedInsertValue' config tbl it =+    unsafeTypedInsert'+    (showStringSQL $ sqlFromInsertTarget config tbl it)+    (showStringSQL ci) n+  where+    (ci, n) = sqlChunkFromInsertTarget config tbl it  -- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object. typedInsertValue :: Table r -> InsertTarget p r -> Insert p

@@ -1,4 +1,4 @@-module Lex (eqProp) where+module Lex (eqProp, eqProp') where  import Control.Applicative   ((<$>), (<*>), pure, (*>), (<*), (<|>), empty, many, some)@@ -181,9 +181,9 @@   y <- run b   return $ x == y -eqProp' :: String -> (t -> String) -> t -> String -> Test-eqProp' name t x est = boolTest' name em (t x `eq` est)-  where em = unlines [show $ run $ t x, " -- compares --", show $ run est]+eqProp' :: String -> (a -> String) -> a -> String -> Test+eqProp' name fstr x est = boolTest' name em (fstr x `eq` est)+  where em = unlines [show $ run $ fstr x, " -- compares --", show $ run est]  eqProp :: Show a => String -> a -> String -> Test eqProp name = eqProp' name show

@@ -1,9 +1,10 @@  import Test.QuickCheck.Simple (Test, defaultMain)+import qualified Test.QuickCheck.Simple as QSimple  import Control.Applicative ((<$>), (<*>)) -import Lex (eqProp)+import Lex (eqProp, eqProp') import Model  import Data.Int (Int32, Int64)@@ -77,13 +78,32 @@   intA0' <-# value (0 :: Int32)   return unitPlaceHolder -registerX :: Insert ()+registerX :: Insert (String, Maybe String) registerX = derivedInsertValue $ do-  intA0' <-# value 1-  strA1' <-# value "Hello"-  strA2' <-# value "World"-  return unitPlaceHolder+  intC0' <-# value 1+  (ph1, ()) <- placeholder (\ph' -> strC1' <-# ph')+  intC2' <-# value 2+  (ph2, ()) <- placeholder (\ph' -> mayStrC3' <-# ph')+  return $ ph1 >< ph2 +eqChunkedInsert :: String+                -> Insert a+                -> String+                -> String+                -> Test+eqChunkedInsert name ins prefix row =+    maybe+    (name, success)+    (\(sql, n) ->+      let estimate =+            unwords+            $ prefix+            : replicate (n - 1) (row ++ ",") ++ [row]+      in eqProp' name id sql estimate)+    $ chunkedInsert ins+  where+    success = QSimple.Bool Nothing True+ monadic :: [Test] monadic =   [ eqProp "query"      queryX@@ -111,7 +131,9 @@   , eqProp "update"      assignX     "UPDATE TEST.set_a SET int_a0 = 0"   , eqProp "insert"      registerX-    "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (1, 'Hello', 'World')"+    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES (1, ?, 2, ?)"+  , eqChunkedInsert "insert chunked" registerX+    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES" "(1, ?, 2, ?)"   ]  _p_monadic :: IO ()@@ -608,8 +630,12 @@ effs =   [ eqProp "insert" insertX     "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)"+  , eqChunkedInsert "insert chunked" insertX+    "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES" "(?, ?, ?)"   , eqProp "insert1" insertI     "INSERT INTO TEST.set_i (int_i0) VALUES (?)"+  , eqChunkedInsert "insert1 chunked" insertI+    "INSERT INTO TEST.set_i (int_i0) VALUES" "(?)"   , eqProp "insertQuery" insertQueryX     "INSERT INTO TEST.set_b (int_b0, str_b2, str_b2) SELECT int_a0, str_a1, str_a2 FROM TEST.set_a"   , eqProp "updateKey" updateKeyX

@@ -1,39 +1,15 @@ {-# LANGUAGE Arrows #-}  import Test.QuickCheck.Simple (Test, defaultMain)+import qualified Test.QuickCheck.Simple as QSimple -import Lex (eqProp)+import Lex (eqProp, eqProp') import Model  import Data.Int (Int32, Int64) import Control.Arrow (returnA, arr, (<<<), (***)) import Database.Relational.Query.Arrow -numBin :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r-numBin op = relation $ proc () -> do-  returnA -< value 5 `op` value 3--strConcat :: Relation () String-strConcat = relation $ proc () -> do-  returnA -< value "Hello, " .||. value "World!"--strLike :: Relation () (Maybe Bool)-strLike = relation $ proc () -> do-  returnA -< value "Hoge" `like` "H%"--_p_numBin :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO ()-_p_numBin = print . numBin--bin :: [Test]-bin =-  [ eqProp "plus"  (numBin (.+.)) "SELECT ALL (5 + 3) AS f0"-  , eqProp "minus" (numBin (.-.)) "SELECT ALL (5 - 3) AS f0"-  , eqProp "mult"  (numBin (.*.)) "SELECT ALL (5 * 3) AS f0"-  , eqProp "div"   (numBin (./.)) "SELECT ALL (5 / 3) AS f0"-  , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0"-  , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0"-  ]- tables :: [Test] tables =   [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a"@@ -44,6 +20,132 @@ _p_tables :: IO () _p_tables =  mapM_ print [show setA, show setB, show setC] ++-- Monadic Operators tests++queryX :: Relation () SetA+queryX = relation $ proc () -> do+  a <- query setA -< ()+  returnA -< a++queryMaybeX :: Relation () (Maybe SetA)+queryMaybeX = relation $ proc () -> do+  a <- queryMaybe setA -< ()+  returnA -< a++onX :: Relation () (Maybe SetA, SetB)+onX = relation $ proc () -> do+  a <- queryMaybe setA -< ()+  b <- query      setB -< ()+  on -< a ?! intA0' .=. just (b ! intB0')+  returnA -< (,) |$| a |*| b++wheresX :: Relation () (SetA, SetB)+wheresX = relation $ proc () -> do+  a <- query      setA -< ()+  b <- query      setB -< ()+  wheres -< b ! intB0' .>=. value 3+  returnA -< (,) |$| a |*| b++groupByX :: Relation () (Int32, Integer)+groupByX = aggregateRelation $ proc () -> do+  a <- query      setA -< ()+  ga0 <- groupBy -< a ! intA0'+  returnA -< (,) |$| ga0 |*| count (a ! intA0')++havingX :: Relation () Int+havingX = aggregateRelation $ proc () -> do+  a <- query      setA -< ()+  let c = count (a ! intA0')+  having -< c .>. value 1+  returnA -< c++distinctX :: Relation () Int32+distinctX = relation $ proc () -> do+  distinct -< ()+  a <- query      setA -< ()+  returnA -< a ! intA0'++all'X :: Relation () Int32+all'X = relation $ proc () -> do+  all' -< ()+  a <- query      setA -< ()+  returnA -< a ! intA0'++assignX :: Update ()+assignX = derivedUpdate $ proc _proj -> do+  assign intA0' -< value (0 :: Int32)+  returnA -< unitPlaceHolder++registerX :: Insert (String, Maybe String)+registerX = derivedInsertValue $ proc () -> do+  assign intC0' -< value 1+  (ph1, ()) <- placeholder -< proc ph' -> do assign strC1' -< ph'+  assign intC2' -< value 2+  (ph2, ()) <- placeholder -< proc ph' -> do assign mayStrC3' -< ph'+  returnA -< ph1 >< ph2++eqChunkedInsert :: String+                -> Insert a+                -> String+                -> String+                -> Test+eqChunkedInsert name ins prefix row =+    maybe+    (name, success)+    (\(sql, n) ->+      let estimate =+            unwords+            $ prefix+            : replicate (n - 1) (row ++ ",") ++ [row]+      in eqProp' name id sql estimate)+    $ chunkedInsert ins+  where+    success = QSimple.Bool Nothing True++monadic :: [Test]+monadic =+  [ eqProp "query"      queryX+    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2 FROM TEST.set_a T0"+  , eqProp "queryMaybe" queryMaybeX+    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2 FROM TEST.set_a T0"+  , eqProp "on"         onX+    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \+    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \+    \  FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)"+  , eqProp "wheres"     wheresX+    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \+    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \+    \  FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0) \+    \ WHERE (T1.int_b0 >= 3)"+  , eqProp "groupBy"    groupByX+    "SELECT ALL T0.int_a0 AS f0, COUNT(T0.int_a0) AS f1 \+    \  FROM TEST.set_a T0 GROUP BY T0.int_a0"+  , eqProp "having"     havingX+    "SELECT ALL COUNT(T0.int_a0) AS f0 FROM TEST.set_a T0 HAVING (COUNT(T0.int_a0) > 1)"+  , eqProp "distinct"   distinctX+    "SELECT DISTINCT T0.int_a0 AS f0 FROM TEST.set_a T0"+  , eqProp "all'"       all'X+    "SELECT ALL T0.int_a0 AS f0 FROM TEST.set_a T0"+  , eqProp "update"      assignX+    "UPDATE TEST.set_a SET int_a0 = 0"+  , eqProp "insert"      registerX+    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES (1, ?, 2, ?)"+  , eqChunkedInsert "insert chunked" registerX+    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES" "(1, ?, 2, ?)"+  ]++_p_monadic :: IO ()+_p_monadic =+  mapM_ putStrLn+  [ show queryX, show queryMaybeX, show onX, show wheresX+  , show groupByX, show havingX, show distinctX, show all'X+  , show assignX+  ]+++-- Direct Join Operators+ cross :: Relation () (SetA, SetB) cross =  setA `inner` setB `on'` [] @@ -175,6 +277,55 @@ _p_nested :: IO () _p_nested =  mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] ++-- Projection Operators++bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r+bin53 op = relation $ proc () -> do+  returnA -< value 5 `op` value 3++strIn :: Relation () (Maybe Bool)+strIn = relation $ proc () -> do+  returnA -< value "foo" `in'` values ["foo", "bar"]++boolTF :: (Projection Flat (Maybe Bool) -> Projection Flat (Maybe Bool) -> Projection Flat r) -> Relation () r+boolTF op = relation $ proc () -> do+  returnA -< valueTrue `op` valueFalse++strConcat :: Relation () String+strConcat = relation $ proc () -> do+  returnA -< value "Hello, " .||. value "World!"++strLike :: Relation () (Maybe Bool)+strLike = relation $ proc () -> do+  returnA -< value "Hoge" `like` "H%"++_p_bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO ()+_p_bin53 = print . bin53++bin :: [Test]+bin =+  [ eqProp "equal" (bin53 (.=.))  "SELECT ALL (5 =  3) AS f0"+  , eqProp "lt"    (bin53 (.<.))  "SELECT ALL (5 <  3) AS f0"+  , eqProp "le"    (bin53 (.<=.)) "SELECT ALL (5 <= 3) AS f0"+  , eqProp "gt"    (bin53 (.>.))  "SELECT ALL (5 >  3) AS f0"+  , eqProp "ge"    (bin53 (.>=.)) "SELECT ALL (5 >= 3) AS f0"+  , eqProp "ne"    (bin53 (.<>.)) "SELECT ALL (5 <> 3) AS f0"++  , eqProp "and"   (boolTF and')  "SELECT ALL ((0=0) AND (0=1)) AS f0"+  , eqProp "or"    (boolTF or')   "SELECT ALL ((0=0) OR  (0=1)) AS f0"++  , eqProp "in"    strIn          "SELECT ALL ('foo' IN ('foo', 'bar')) AS f0"++  , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0"+  , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0"++  , eqProp "plus"  (bin53 (.+.)) "SELECT ALL (5 + 3) AS f0"+  , eqProp "minus" (bin53 (.-.)) "SELECT ALL (5 - 3) AS f0"+  , eqProp "mult"  (bin53 (.*.)) "SELECT ALL (5 * 3) AS f0"+  , eqProp "div"   (bin53 (./.)) "SELECT ALL (5 / 3) AS f0"+  ]+ justX :: Relation () (SetA, Maybe SetB) justX =  relation $ proc () -> do   a <- query setA -< ()@@ -403,7 +554,7 @@  tests :: [Test] tests =-  concat [ bin, tables, directJoins, join3s, nested, maybes+  concat [ tables, monadic, directJoins, join3s, nested, bin, maybes          , groups, orders, partitions, exps, effs]  main :: IO ()