diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,8 @@ -## 0.12.2.4 +## 0.12.3.0 -- fix typo. +- add module to export SQL string representation for other systems. ## 0.12.2.3 @@ -229,7 +229,7 @@ ## 0.6.1.0 -- Add a configuration flag to print verbose compile-time messages. +- Add a configuration flag to pring verbose compile-time messages. ## 0.6.0.0 diff --git a/relational-query.cabal b/relational-query.cabal --- a/relational-query.cabal +++ b/relational-query.cabal @@ -1,7 +1,7 @@ name: relational-query -version: 0.12.2.4 +version: 0.12.3.0 synopsis: Typeful, Modular, Relational, algebraic query engine -description: This package contains typeful relation structure and +description: This package contiains typeful relation structure and relational-algebraic query building DSL which can translate into SQL query. . @@ -16,16 +16,11 @@ license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com -copyright: Copyright (c) 2013-2023 Kei Hibino +copyright: Copyright (c) 2013-2019 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 9.6.2 - , GHC == 9.4.6 - , GHC == 9.2.8 - , GHC == 9.0.2 - , GHC == 8.10.7 - , GHC == 8.8.1, GHC == 8.8.2 +tested-with: GHC == 8.8.1, GHC == 8.8.2 , GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3, GHC == 8.6.4, GHC == 8.6.5 , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3, GHC == 8.4.4 , GHC == 8.2.1, GHC == 8.2.2 @@ -82,6 +77,8 @@ Database.Relational.Derives Database.Relational.TH + Database.Relational.Export + -- for GHC version equal or more than 8.0 Database.Relational.OverloadedProjection Database.Relational.OverloadedInstances @@ -117,13 +114,14 @@ , template-haskell , th-reify-compat , th-constraint-compat - , th-data-compat , product-isomorphic >= 0.0.3 , sql-words >=0.1.5 , names-th , persistable-record >= 0.6 if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* + if impl(ghc == 7.4.*) || impl(ghc == 7.6.*) + build-depends: bytestring-short hs-source-dirs: src ghc-options: -Wall -fsimpl-tick-factor=200 @@ -180,6 +178,32 @@ default-language: Haskell2010 +test-suite exports + build-depends: base <5 + , quickcheck-simple + , product-isomorphic + , relational-query + , containers + , transformers + , bytestring + if impl(ghc == 7.4.*) + build-depends: ghc-prim == 0.2.* + if impl(ghc == 7.4.*) || impl(ghc == 7.6.*) + build-depends: bytestring-short + + type: exitcode-stdio-1.0 + main-is: exportsEq.hs + other-modules: + Lex + Model + Export + + hs-source-dirs: test + ghc-options: -Wall -fsimpl-tick-factor=200 + if impl(ghc >= 8) + ghc-options: -Wcompat + + default-language: Haskell2010 source-repository head type: git diff --git a/src/Database/Relational/Arrow.hs b/src/Database/Relational/Arrow.hs --- a/src/Database/Relational/Arrow.hs +++ b/src/Database/Relational/Arrow.hs @@ -11,7 +11,7 @@ -- Portability : unknown -- -- This module defines arrow version combinators which --- improves type-safety on building queries. +-- improves type-safty on building queries. -- Referencing the local projected records may cause to break -- the result query. -- It is possible to controls injection of previous local projected records diff --git a/src/Database/Relational/Constraint.hs b/src/Database/Relational/Constraint.hs --- a/src/Database/Relational/Constraint.hs +++ b/src/Database/Relational/Constraint.hs @@ -103,11 +103,11 @@ constraintKey :: Key c r ct -- | Inferred 'Unique' constraint 'Key'. --- Record type 'r' has unique key which type is 'ct' derived from primary 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 -- -- | Inferred 'NotNull' constraint 'Key'. --- -- Record type 'r' has not-null key which type is 'ct' derived from primary 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 diff --git a/src/Database/Relational/Derives.hs b/src/Database/Relational/Derives.hs --- a/src/Database/Relational/Derives.hs +++ b/src/Database/Relational/Derives.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : unknown -- --- This module defines typed SQLs derived from type information. +-- This module defines typed SQLs derived from type informations. module Database.Relational.Derives ( -- * Query derivation specifiedKey, diff --git a/src/Database/Relational/Export.hs b/src/Database/Relational/Export.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Export.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Database.Relational.Export +-- Copyright : 2021 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines templates to export SQL string representation to other systems. +module Database.Relational.Export ( + inlineQuery_, + inlineUpdate_, + inlineInsertValue_, + inlineInsertQuery_, + inlineDelete_, + ) where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.ByteString.Short (ShortByteString, toShort) + +import Language.Haskell.TH (Q, Dec, stringE) +import Language.Haskell.TH.Name.CamelCase (varName, varCamelcaseName) +import Language.Haskell.TH.Lib.Extra (simpleValD) + +import Database.Relational + (Query, Update, Insert, InsertQuery, Delete, + untypeQuery, UntypeableNoFetch (untypeNoFetch)) + + +inlineSQL_ :: (String -> Q ()) -- ^ action to check SQL string + -> String -- ^ SQL String + -> String -- ^ Variable name to define as inlined SQL + -> Q [Dec] -- ^ Result declarations +inlineSQL_ check sql declName = do + check sql + simpleValD (varName $ varCamelcaseName declName) + [t| ShortByteString |] + [| toShort $ T.encodeUtf8 $ T.pack $(stringE sql) |] + -- IsString instance of ShortByteString type does not handle multi-byte characters. + +inlineQuery_ :: (String -> Q ()) -- ^ action to check SQL string. for example to call prepare. if you do not need this, pass (const $ pure ()) + -> Query p a -- ^ query to inline + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineQuery_ check q declName = inlineSQL_ check (untypeQuery q) declName + +inlineNoFetch_ :: UntypeableNoFetch s + => (String -> Q ()) -- ^ action to check SQL string. for example to call prepare. if you do not need this, pass (const $ pure ()) + -> s a -- ^ statement to inline + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineNoFetch_ check q declName = inlineSQL_ check (untypeNoFetch q) declName + +inlineUpdate_ :: (String -> Q ()) -- ^ action to check SQL string. for example to call prepare. if you do not need this, pass (const $ pure ()) + -> Update p -- ^ statement to inline + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineUpdate_ = inlineNoFetch_ + +inlineInsertValue_ :: (String -> Q ()) -- ^ action to check SQL string. for example to call prepare. if you do not need this, pass (const $ pure ()) + -> Insert p -- ^ statement to inline + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineInsertValue_ = inlineNoFetch_ + +inlineInsertQuery_ :: (String -> Q ()) -- ^ action to check SQL string. for example to call prepare. if you do not need this, pass (const $ pure ()) + -> InsertQuery p -- ^ statement to inline + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineInsertQuery_ = inlineNoFetch_ + +inlineDelete_ :: (String -> Q ()) -- ^ action to check SQL string. for example to call prepare. if you do not need this, pass (const $ pure ()) + -> Delete p -- ^ statement to inline + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineDelete_ = inlineNoFetch_ diff --git a/src/Database/Relational/InternalTH/Base.hs b/src/Database/Relational/InternalTH/Base.hs --- a/src/Database/Relational/InternalTH/Base.hs +++ b/src/Database/Relational/InternalTH/Base.hs @@ -27,7 +27,6 @@ Dec, sigD, valD, instanceD, TyVarBndr (PlainTV), ) import Language.Haskell.TH.Compat.Constraint (classP) -import Language.Haskell.TH.Compat.Data (plainTVspecified) import Database.Record.Persistable (PersistableWidth, persistableWidth, PersistableRecordWidth, runPersistableRecordWidth) @@ -60,7 +59,7 @@ template :: TypeQ -> [TypeQ] -> Name -> Q [Dec] template ct pcts selN = do sig <- sigD selN $ - forallT (map plainTVspecified avs) + forallT (map PlainTV avs) (mapM (classP ''PersistableWidth . (:[]) . varT) avs) [t| Pi $tyRec $ct |] let runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |] diff --git a/src/Database/Relational/Monad/Trans/Assigning.hs b/src/Database/Relational/Monad/Trans/Assigning.hs --- a/src/Database/Relational/Monad/Trans/Assigning.hs +++ b/src/Database/Relational/Monad/Trans/Assigning.hs @@ -71,7 +71,7 @@ leftsR = Record.columns . targetRecord target rights = Record.columns vp --- | Add and assignment. +-- | Add and assginment. (<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m () (<-#) = flip assignTo diff --git a/src/Database/Relational/Monad/Trans/Restricting.hs b/src/Database/Relational/Monad/Trans/Restricting.hs --- a/src/Database/Relational/Monad/Trans/Restricting.hs +++ b/src/Database/Relational/Monad/Trans/Restricting.hs @@ -62,7 +62,7 @@ query' = restrictings . query' queryMaybe' = restrictings . queryMaybe' --- | Restricted 'MonadAggregate' instance. +-- | Resticted 'MonadAggregate' instance. instance MonadAggregate m => MonadAggregate (Restrictings c m) where groupBy = restrictings . groupBy groupBy' = restrictings . groupBy' diff --git a/src/Database/Relational/Pi/Unsafe.hs b/src/Database/Relational/Pi/Unsafe.hs --- a/src/Database/Relational/Pi/Unsafe.hs +++ b/src/Database/Relational/Pi/Unsafe.hs @@ -82,7 +82,7 @@ unsafeExpandIndexes' = expandIndexes' {-# DEPRECATED unsafeExpandIndexes' "Use expandIndexes' instead of this." #-} --- | Expand indexes from key. Inferred width version. +-- | Expand indexes from key. Infered width version. expandIndexes :: PersistableWidth a => Pi a b -> [Int] expandIndexes = expandIndexes' persistableWidth diff --git a/src/Database/Relational/Projectable.hs b/src/Database/Relational/Projectable.hs --- a/src/Database/Relational/Projectable.hs +++ b/src/Database/Relational/Projectable.hs @@ -234,12 +234,12 @@ exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS . Record.unsafeStringSqlList unsafeShowSql' --- | Concatenate operator corresponding SQL /||/ . +-- | Concatinate operator corresponding SQL /||/ . (.||.) :: OperatorContext c => Record c a -> Record c a -> Record c a (.||.) = unsafeBinOp (SQL..||.) --- | Concatenate operator corresponding SQL /||/ . Maybe type version. +-- | Concatinate operator corresponding SQL /||/ . Maybe type version. (?||?) :: (OperatorContext c, IsString a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) (?||?) = unsafeBinOp (SQL..||.) diff --git a/src/Database/Relational/Projectable/Instances.hs b/src/Database/Relational/Projectable/Instances.hs --- a/src/Database/Relational/Projectable/Instances.hs +++ b/src/Database/Relational/Projectable/Instances.hs @@ -37,9 +37,9 @@ instance SqlContext OverWindow where unsafeProjectSqlTerms = Record.unsafeFromSqlTerms --- | full SQL expression is available in Flat context +-- | full SQL expression is availabe in Flat context instance OperatorContext Flat --- | full SQL expression is available in Aggregated context +-- | full SQL expression is availabe in Aggregated context instance OperatorContext Aggregated -- | 'Aggregated' context is aggregated context diff --git a/src/Database/Relational/Projectable/Unsafe.hs b/src/Database/Relational/Projectable/Unsafe.hs --- a/src/Database/Relational/Projectable/Unsafe.hs +++ b/src/Database/Relational/Projectable/Unsafe.hs @@ -31,5 +31,5 @@ class AggregatedContext ac --- | Placeholder parameter type which has real parameter type argument 'p'. +-- | Placeholder parameter type which has real parameter type arguemnt 'p'. data PlaceHolders p = PlaceHolders diff --git a/src/Database/Relational/Record.hs b/src/Database/Relational/Record.hs --- a/src/Database/Relational/Record.hs +++ b/src/Database/Relational/Record.hs @@ -196,7 +196,7 @@ unsafeListFromSubQuery :: SubQuery -> RecordList p t unsafeListFromSubQuery = Sub --- | Map record show operatoions and concatenate to single SQL expression. +-- | Map record show operatoions and concatinate to single SQL expression. unsafeStringSqlList :: (p t -> StringSQL) -> RecordList p t -> StringSQL unsafeStringSqlList sf = d where d (List ps) = listStringSQL $ map sf ps diff --git a/src/Database/Relational/Relation.hs b/src/Database/Relational/Relation.hs --- a/src/Database/Relational/Relation.hs +++ b/src/Database/Relational/Relation.hs @@ -121,11 +121,11 @@ relation :: QuerySimple (Record Flat r) -> Relation () r relation = relation' . addUnitPH --- | Finalize 'QueryAggregate' monad and generate 'Relation' with place-holder parameter 'p'. +-- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'. aggregateRelation' :: AggregatedQuery p r -> Relation p r aggregateRelation' = unsafeTypeRelation . Aggregate.toSubQuery --- | Finalize 'QueryAggregate' monad and generate 'Relation'. +-- | Finalize 'QueryAggregate' monad and geneate 'Relation'. aggregateRelation :: QueryAggregate (Record Aggregated r) -> Relation () r aggregateRelation = aggregateRelation' . addUnitPH diff --git a/src/Database/Relational/Type.hs b/src/Database/Relational/Type.hs --- a/src/Database/Relational/Type.hs +++ b/src/Database/Relational/Type.hs @@ -302,7 +302,7 @@ derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' derivedInsert = insert --- | Make typed 'Insert' from 'Config', 'Table' and monadic built 'InsertTarget' object. +-- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p typedInsertValue' config tbl it = unsafeTypedInsert' @@ -312,11 +312,11 @@ (ci, n) = sqlChunkFromInsertTarget config tbl it {-# DEPRECATED typedInsertValue "use `typedInsertValue' defaultConfig` instead of this." #-} --- | Make typed 'Insert' from 'Table' and monadic built 'InsertTarget' object. +-- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object. typedInsertValue :: Table r -> InsertTarget p r -> Insert p typedInsertValue = typedInsertValue' defaultConfig --- | Make typed 'Insert' from 'Config', derived table and monadic built 'Register' object. +-- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p insertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs where @@ -324,20 +324,20 @@ rt = const derivedTable {-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-} --- | Make typed 'Insert' from 'Config', derived table and monadic built 'Register' object. +-- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p derivedInsertValue' = insertValue' --- | Make typed 'Insert' from 'defaultConfig', derived table and monadic built 'Register' object. +-- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p insertValue = insertValue' defaultConfig --- | Make typed 'Insert' from 'defaultConfig', derived table and monadic built 'Register' object with no(unit) placeholder. +-- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r => Register r () -> Insert () insertValueNoPH = insertValue . (>> return unitPH) {-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-} --- | Make typed 'Insert' from 'defaultConfig', derived table and monadic built 'Register' object. +-- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p derivedInsertValue = insertValue @@ -450,7 +450,7 @@ show = untypeDelete --- | Untype interface for typed no-result type statements +-- | Untype interface for typed no-result type statments -- with single type parameter which represents place-holder parameter 'p'. class UntypeableNoFetch s where untypeNoFetch :: s p -> String diff --git a/test/Export.hs b/test/Export.hs new file mode 100644 --- /dev/null +++ b/test/Export.hs @@ -0,0 +1,40 @@ +module Export where + +import Data.Functor.ProductIsomorphic (pureP, (|$|), (|*|)) +import Data.Int (Int32) + +import Model + +import Database.Relational + + +onX :: Relation () (Maybe SetA, SetB) +onX = relation $ do + a <- queryMaybe setA + b <- query setB + on $ a ?! intA0' .=. just (b ! intB0') + return $ (,) |$| a |*| b + +assignX :: Update () +assignX = update $ \_proj -> do + intA0' <-# value (0 :: Int32) + return $ pureP () + +registerX :: Insert (String, Maybe String) +registerX = insertValue $ do + intC0' <-# value 1 + (ph1, ()) <- placeholder (\ph' -> strC1' <-# ph') + intC2' <-# value 2 + (ph2, ()) <- placeholder (\ph' -> mayStrC3' <-# ph') + return $ (,) |$| ph1 |*| ph2 + +setAFromB :: Pi SetB SetA +setAFromB = SetA |$| intB0' |*| strB2' |*| strB2' + +insertQueryX :: InsertQuery () +insertQueryX = insertQuery setAFromB setA + +deleteX :: Delete () +deleteX = delete $ \proj -> do + wheres $ proj ! strA1' .=. value "A" + return $ pureP () diff --git a/test/Model.hs b/test/Model.hs --- a/test/Model.hs +++ b/test/Model.hs @@ -35,6 +35,7 @@ , ("may_str_c3" , [t| Maybe String |]) ] [''Generic] [0] $ Just 0) + $(defineTable defaultConfig "TEST" "set_i" [ ("int_i0" , [t| Int32 |]) ] [''Generic] [0] $ Just 0) diff --git a/test/exportsEq.hs b/test/exportsEq.hs new file mode 100644 --- /dev/null +++ b/test/exportsEq.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Test.QuickCheck.Simple (Test, eqTest, defaultMain) + +import Export (onX, assignX, registerX, insertQueryX, deleteX) + +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Short (ShortByteString, fromShort) + +import Database.Relational (relationalQuery) +import Database.Relational.Export + (inlineQuery_, inlineUpdate_, inlineInsertValue_, inlineInsertQuery_, inlineDelete_) + + +$(inlineQuery_ + (const $ return ()) + (relationalQuery onX) + "inlineOnX") + +$(inlineUpdate_ + (const $ return ()) + assignX + "inlineAssignX") + +$(inlineInsertValue_ + (const $ return ()) + registerX + "inlineRegisterX") + +$(inlineInsertQuery_ + (const $ return ()) + insertQueryX + "inlineInsertQueryX") + +$(inlineDelete_ + (const $ return ()) + deleteX + "inlineDeleteX") + +eqInline :: Show a => String -> ShortByteString -> a -> Test +eqInline name inline orig = eqTest name (B.unpack $ fromShort inline) (show orig) + +tests :: [Test] +tests = + [ eqInline "onX" inlineOnX onX + , eqInline "assignX" inlineAssignX assignX + , eqInline "registerX" inlineRegisterX registerX + , eqInline "insertQueryX" inlineInsertQueryX insertQueryX + , eqInline "deleteX" inlineDeleteX deleteX + ] + +main :: IO () +main = defaultMain tests