Merge minor update for relational-query-0.12.3.x

devel/GNUmakefile

@@ -3,21 +3,56 @@ all: clean build
 
 haddock_opt = --hyperlink-source --haddock-options=--css=../devel/black.css
 
+v1 = $$(case $(shell cabal --numeric-version) in \
+          3.*|2.4.*) \
+            echo 'v1-'; \
+            ;; \
+          0.*|1.*|2.0.*|2.2.*) \
+            ;; \
+          *) \
+            ;; \
+        esac)
+
+
 ncpu = $(shell cat /proc/cpuinfo | egrep '^processor' | wc -l)
-jobs = --jobs=$(shell expr $(ncpu) '*' 3 '/' 4)
+njobs = $(shell expr $(ncpu) '*' 3 '/' 4)
+ghc_version = $(shell ghc --numeric-version)
+jobs = $$(case $(ghc_version) in \
+            7.4.*|7.6.*) \
+              ;; \
+            *) \
+              echo -j$(njobs); \
+              ;; \
+          esac)
+
+gc = $$(case $(ghc_version) in \
+            7.4.*|7.6.*) \
+              ;; \
+            7.8.*|7.10.*|8.0.*) \
+              echo --ghc-option=+RTS --ghc-option=-qg --ghc-option=-RTS; \
+              ;; \
+            *) \
+              echo --ghc-option=+RTS --ghc-option=-qn2 --ghc-option=-RTS; \
+              ;; \
+          esac)
 
 build:
-	cabal v1-configure -O0 --enable-tests
+	cabal $(v1)configure -O0 --enable-tests
-	cabal v1-build $(jobs) --ghc-option=-Wall
+	cabal $(v1)build $(jobs) --ghc-option=-Wall $(gc)
-	cabal v1-haddock $(haddock_opt)
+	cabal $(v1)haddock $(haddock_opt)
-	cabal v1-test
+	cabal $(v1)test
 
 haddock:
-	cabal v1-configure
+	cabal $(v1)configure
-	cabal v1-haddock $(haddock_opt)
+	cabal $(v1)haddock $(haddock_opt)
 
 check:
-	cabal v1-check
+	cabal check
+
+info:
+	@echo v1prefix=$(v1)
+	@echo jobs=$(jobs)
+	@echo gc=$(gc)
 
 wc:
 	make clean-hs
@@ -25,7 +60,7 @@ wc:
 
 clean:
 	make clean-hs
-	cabal v1-clean
+	cabal $(v1)clean
 	[ ! -d .debian-build ] || rm -r .debian-build
 	[ ! -d .stack-work ] || rm -r .stack-work
 	test ! -d src || find src \( -name '*.o' -o -name '*.hi' -o -name '*.dyn_o' -o  -name '*.dyn_hi' \) -exec rm {} \;

relational-query/ChangeLog.md

@@ -1,5 +1,9 @@
 <!-- -*- Markdown -*- -->
 
+## 0.12.3.0
+
+- add module to export SQL string representation for other systems.
+
 ## 0.12.2.3
 
 - update for GHC 8.8.x.

relational-query/relational-query.cabal

@@ -1,5 +1,5 @@
 name:                relational-query
-version:             0.12.2.3
+version:             0.12.3.0
 synopsis:            Typeful, Modular, Relational, algebraic query engine
 description:         This package contiains typeful relation structure and
                      relational-algebraic query building DSL which can
@@ -77,6 +77,8 @@ library
                        Database.Relational.Derives
                        Database.Relational.TH
 
+                       Database.Relational.Export
+
                        -- for GHC version equal or more than 8.0
                        Database.Relational.OverloadedProjection
                        Database.Relational.OverloadedInstances
@@ -123,6 +125,8 @@ library
                        , 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 +184,32 @@ test-suite sqlsArrow
 
   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

relational-query/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_

relational-query/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 ()

relational-query/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