diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# hpqtypes-extra-1.10.4.0 (2021-02-04) +* Generate valid INSERT SELECT query with data modifying WITH clauses +* Add DerivingVia helpers for enums + # hpqtypes-extra-1.10.3.0 (2020-11-16) * Include LIMIT clause in UNION subqueries of the select diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,79 @@ +module Main where + +import Control.DeepSeq +import Data.Int +import Test.Tasty.Bench + +import Database.PostgreSQL.PQTypes.Deriving + +main :: IO () +main = defaultMain + [ bgroup "enum" + [ bench "encode" $ nf (encodeEnum @T) T42 + , bench "decode" $ nf (decodeEnum @T) 42 + ] + , bgroup "enum-text" + [ bench "encode" $ nf (encodeEnumAsText @S) S42 + , bench "decode" $ nf (decodeEnumAsText @S) "text_42" + ] + ] + +data T = T01 | T02 | T03 | T04 | T05 | T06 | T07 | T08 | T09 | T10 + | T11 | T12 | T13 | T14 | T15 | T16 | T17 | T18 | T19 | T20 + | T21 | T22 | T23 | T24 | T25 | T26 | T27 | T28 | T29 | T30 + | T31 | T32 | T33 | T34 | T35 | T36 | T37 | T38 | T39 | T40 + | T41 | T42 | T43 | T44 | T45 | T46 | T47 | T48 | T49 | T50 + deriving (Eq, Show, Enum, Bounded) + +instance NFData T where + rnf = (`seq` ()) + +-- | Enum encoding for 'T'. +-- +-- >>> isInjective (encodeEnum @T) +-- True +instance EnumEncoding T where + type EnumBase T = Int16 + encodeEnum = \case + T01 -> 1; T02 -> 2; T03 -> 3; T04 -> 4; T05 -> 5 + T06 -> 6; T07 -> 7; T08 -> 8; T09 -> 9; T10 -> 10 + T11 -> 11; T12 -> 12; T13 -> 13; T14 -> 14; T15 -> 15 + T16 -> 16; T17 -> 17; T18 -> 18; T19 -> 19; T20 -> 20 + T21 -> 21; T22 -> 22; T23 -> 23; T24 -> 24; T25 -> 25 + T26 -> 26; T27 -> 27; T28 -> 28; T29 -> 29; T30 -> 30 + T31 -> 31; T32 -> 32; T33 -> 33; T34 -> 34; T35 -> 35 + T36 -> 36; T37 -> 37; T38 -> 38; T39 -> 39; T40 -> 40 + T41 -> 41; T42 -> 42; T43 -> 43; T44 -> 44; T45 -> 45 + T46 -> 46; T47 -> 47; T48 -> 48; T49 -> 49; T50 -> 50 + +---------------------------------------- + +data S = S01 | S02 | S03 | S04 | S05 | S06 | S07 | S08 | S09 | S10 + | S11 | S12 | S13 | S14 | S15 | S16 | S17 | S18 | S19 | S20 + | S21 | S22 | S23 | S24 | S25 | S26 | S27 | S28 | S29 | S30 + | S31 | S32 | S33 | S34 | S35 | S36 | S37 | S38 | S39 | S40 + | S41 | S42 | S43 | S44 | S45 | S46 | S47 | S48 | S49 | S50 + deriving (Eq, Show, Enum, Bounded) + +instance NFData S where + rnf = (`seq` ()) + +-- | Enum encoding for 'S'. +-- +-- >>> isInjective (encodeEnumAsText @S) +-- True +instance EnumAsTextEncoding S where + encodeEnumAsText = \case + S01 -> "text_01"; S02 -> "text_02"; S03 -> "text_03"; S04 -> "text_04" + S05 -> "text_05"; S06 -> "text_06"; S07 -> "text_07"; S08 -> "text_08" + S09 -> "text_09"; S10 -> "text_10"; S11 -> "text_11"; S12 -> "text_12" + S13 -> "text_13"; S14 -> "text_14"; S15 -> "text_15"; S16 -> "text_16" + S17 -> "text_17"; S18 -> "text_18"; S19 -> "text_19"; S20 -> "text_20" + S21 -> "text_21"; S22 -> "text_22"; S23 -> "text_23"; S24 -> "text_24" + S25 -> "text_25"; S26 -> "text_26"; S27 -> "text_27"; S28 -> "text_28" + S29 -> "text_29"; S30 -> "text_30"; S31 -> "text_31"; S32 -> "text_32" + S33 -> "text_33"; S34 -> "text_34"; S35 -> "text_35"; S36 -> "text_36" + S37 -> "text_37"; S38 -> "text_38"; S39 -> "text_39"; S40 -> "text_40" + S41 -> "text_41"; S42 -> "text_42"; S43 -> "text_43"; S44 -> "text_44" + S45 -> "text_45"; S46 -> "text_46"; S47 -> "text_47"; S48 -> "text_48" + S49 -> "text_49"; S50 -> "text_50"; diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ -cabal-version: 1.18 +cabal-version: 2.2 name: hpqtypes-extras -version: 1.10.3.0 +version: 1.10.4.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -10,7 +10,7 @@ of a database schema. homepage: https://github.com/scrive/hpqtypes-extras -license: BSD3 +license: BSD-3-Clause license-file: LICENSE extra-source-files: CHANGELOG.md, README.md author: Scrive AB @@ -20,18 +20,40 @@ copyright: Scrive AB category: Database build-type: Simple -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3 Source-repository head Type: git Location: https://github.com/scrive/hpqtypes-extras.git +common common-stanza + Default-Language: Haskell2010 + Default-Extensions: BangPatterns + , DeriveDataTypeable + , ExistentialQuantification + , FlexibleContexts + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiWayIf + , OverloadedStrings + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + , UndecidableInstances + , ViewPatterns + library + Import: common-stanza hs-source-dirs: src ghc-options: -Wall exposed-modules: Database.PostgreSQL.PQTypes.Checks + , Database.PostgreSQL.PQTypes.Deriving , Database.PostgreSQL.PQTypes.ExtrasOptions , Database.PostgreSQL.PQTypes.Migrate , Database.PostgreSQL.PQTypes.Model @@ -52,11 +74,12 @@ build-depends: base >= 4.9 && < 5 , hpqtypes >= 1.8.0.0 && < 2.0.0.0 - , base16-bytestring >= 0.1 && < 0.2 + , base16-bytestring >= 0.1 && < 1.0.1.0 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.7 , cryptohash >= 0.11 && < 0.12 , exceptions >= 0.10 && < 0.11 + , extra >= 1.6.17 && < 1.8.0 , mtl >= 2.2 && < 2.3 , fields-json >= 0.4 && < 0.5 , text >= 1.2 && < 1.3 @@ -68,26 +91,11 @@ , safe >= 0.3 && < 0.4 default-language: Haskell2010 - default-extensions: BangPatterns - , DeriveDataTypeable - , ExistentialQuantification - , FlexibleContexts - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiWayIf - , OverloadedStrings - , RankNTypes - , RecordWildCards - , ScopedTypeVariables - , StandaloneDeriving - , TupleSections - , TypeFamilies - , UndecidableInstances - , ViewPatterns + default-extensions: other-extensions: CPP - , TypeApplications test-suite hpqtypes-extras-tests + Import: common-stanza type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs @@ -100,6 +108,7 @@ , ScopedTypeVariables ghc-options: -Wall build-depends: base, + QuickCheck, exceptions, hpqtypes, hpqtypes-extras, @@ -109,5 +118,18 @@ tasty, tasty-hunit, text, + time, transformers, uuid-types + +benchmark bench + Import: common-stanza + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: Main.hs + + ghc-options: -Wall + build-depends: base + , deepseq + , hpqtypes-extras + , tasty-bench diff --git a/src/Database/PostgreSQL/PQTypes/Deriving.hs b/src/Database/PostgreSQL/PQTypes/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Deriving.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module Database.PostgreSQL.PQTypes.Deriving ( + -- * Helpers, to be used with @deriving via@ (@-XDerivingVia@). + SQLEnum(..) + , EnumEncoding(..) + , SQLEnumAsText(..) + , EnumAsTextEncoding(..) + -- * For use in doctests. + , isInjective + ) where + +import Control.Exception (SomeException(..), throwIO) +import Data.List.Extra (enumerate, nubSort) +import Data.Map.Strict (Map) +import Data.Text (Text) +import Data.Typeable +import Database.PostgreSQL.PQTypes +import qualified Data.Map.Strict as Map + +-- | Helper newtype to be used with @deriving via@ to derive @(PQFormat, ToSQL, +-- FromSQL)@ instances for enums, given an instance of 'EnumEncoding'. +-- +-- /Hint:/ non-trivial 'Enum' instances can be derived using the 'generic-data' +-- package! +-- +-- >>> :{ +-- data Colours = Blue | Black | Red | Mauve | Orange +-- deriving (Eq, Show, Enum, Bounded) +-- instance EnumEncoding Colours where +-- type EnumBase Colours = Int16 +-- encodeEnum = \case +-- Blue -> 1 +-- Black -> 7 +-- Red -> 2 +-- Mauve -> 6 +-- Orange -> 3 +-- :} +-- +-- /Note:/ To get SQL-specific instances use @DerivingVia@: +-- +-- @ +-- data Colours = ... +-- ... +-- deriving (PQFormat, ToSQL, FromSQL) via SQLEnum Colours +-- @ +-- +-- >>> isInjective (encodeEnum @Colours) +-- True +-- +-- >>> decodeEnum @Colours 7 +-- Right Black +-- +-- >>> decodeEnum @Colours 42 +-- Left [(1,3),(6,7)] +newtype SQLEnum a = SQLEnum a + +class + ( -- The semantic type needs to be finitely enumerable. + Enum a + , Bounded a + -- The base type needs to be enumerable and ordered. + , Enum (EnumBase a) + , Ord (EnumBase a) + ) => EnumEncoding a where + type EnumBase a + -- | Encode @a@ as a base type. + encodeEnum :: a -> EnumBase a + + -- | Decode base type to an @a@. If the conversion fails, a list of valid + -- ranges is returned instead. + -- + -- /Note:/ The default implementation looks up values in 'decodeEnumMap' and + -- can be overwritten for performance if necessary. + decodeEnum :: EnumBase a -> Either [(EnumBase a, EnumBase a)] a + decodeEnum b = maybe (Left . intervals $ Map.keys (decodeEnumMap @a)) Right + $ Map.lookup b (decodeEnumMap @a) + + -- | Include the inverse map as a top-level part of the 'EnumEncoding' + -- instance to ensure it is only computed once by GHC. + decodeEnumMap :: Map (EnumBase a) a + decodeEnumMap = Map.fromList [ (encodeEnum a, a) | a <- enumerate ] + +instance PQFormat (EnumBase a) => PQFormat (SQLEnum a) where + pqFormat = pqFormat @(EnumBase a) + +instance + ( EnumEncoding a + , PQFormat (EnumBase a) + , ToSQL (EnumBase a) + ) => ToSQL (SQLEnum a) where + type PQDest (SQLEnum a) = PQDest (EnumBase a) + toSQL (SQLEnum a) = toSQL $ encodeEnum a + +instance + ( EnumEncoding a + , PQFormat (EnumBase a) + , FromSQL (EnumBase a) + , Show (EnumBase a) + , Typeable (EnumBase a) + ) => FromSQL (SQLEnum a) where + type PQBase (SQLEnum a) = PQBase (EnumBase a) + fromSQL base = do + b <- fromSQL base + case decodeEnum b of + Left validRange -> throwIO $ SomeException RangeError + { reRange = validRange + , reValue = b + } + Right a -> return $ SQLEnum a + +-- | A special case of 'SQLEnum', where the enum is to be encoded as text +-- ('SQLEnum' can't be used because of the 'Enum' constraint on the domain of +-- 'encodeEnum'). +-- +-- >>> :{ +-- data Person = Alfred | Bertrand | Charles +-- deriving (Eq, Show, Enum, Bounded) +-- instance EnumAsTextEncoding Person where +-- encodeEnumAsText = \case +-- Alfred -> "alfred" +-- Bertrand -> "bertrand" +-- Charles -> "charles" +-- :} +-- +-- /Note:/ To get SQL-specific instances use @DerivingVia@: +-- +-- @ +-- data Person = ... +-- ... +-- deriving (PQFormat, ToSQL, FromSQL) via SQLEnumAsText Person +-- @ +-- +-- >>> isInjective (encodeEnumAsText @Person) +-- True +-- +-- >>> decodeEnumAsText @Person "bertrand" +-- Right Bertrand +-- +-- >>> decodeEnumAsText @Person "batman" +-- Left ["alfred","bertrand","charles"] +newtype SQLEnumAsText a = SQLEnumAsText a + +class (Enum a, Bounded a) => EnumAsTextEncoding a where + -- | Encode @a@ as 'Text'. + encodeEnumAsText :: a -> Text + + -- | Decode 'Text' to an @a@. If the conversion fails, a list of valid values + -- is returned instead. + -- + -- /Note:/ The default implementation looks up values in 'decodeEnumAsTextMap' + -- and can be overwritten for performance if necessary. + decodeEnumAsText :: Text -> Either [Text] a + decodeEnumAsText text = maybe (Left $ Map.keys (decodeEnumAsTextMap @a)) Right + $ Map.lookup text (decodeEnumAsTextMap @a) + + -- | Include the inverse map as a top-level part of the 'SQLEnumTextEncoding' + -- instance to ensure it is only computed once by GHC. + decodeEnumAsTextMap :: Map Text a + decodeEnumAsTextMap = Map.fromList [ (encodeEnumAsText a, a) | a <- enumerate ] + +instance EnumAsTextEncoding a => PQFormat (SQLEnumAsText a) where + pqFormat = pqFormat @Text + +instance EnumAsTextEncoding a => ToSQL (SQLEnumAsText a) where + type PQDest (SQLEnumAsText a) = PQDest Text + toSQL (SQLEnumAsText a) = toSQL $ encodeEnumAsText a + +instance EnumAsTextEncoding a => FromSQL (SQLEnumAsText a) where + type PQBase (SQLEnumAsText a) = PQBase Text + fromSQL base = do + text <- fromSQL base + case decodeEnumAsText text of + Left validValues -> throwIO $ SomeException InvalidValue + { ivValue = text + , ivValidValues = Just validValues + } + Right a -> return $ SQLEnumAsText a + +-- | To be used in doctests to prove injectivity of encoding functions. +-- +-- >>> isInjective (id :: Bool -> Bool) +-- True +-- +-- >>> isInjective (\(_ :: Bool) -> False) +-- False +isInjective :: (Enum a, Bounded a, Eq a, Eq b) => (a -> b) -> Bool +isInjective f = null [ (a, b) | a <- enumerate, b <- enumerate, a /= b, f a == f b ] + +-- | Internal helper: given a list of values, decompose it into a list of +-- intervals. +-- +-- >>> intervals [42,2,1,0,3,88,-1,43,42] +-- [(-1,3),(42,43),(88,88)] +-- +-- prop> nubSort xs == concatMap (\(l,r) -> [l .. r]) (intervals xs) +intervals :: forall a . (Enum a, Ord a) => [a] -> [(a, a)] +intervals as = case nubSort as of + [] -> [] + (first : ascendingRest) -> accumIntervals (first, first) ascendingRest + where + accumIntervals :: (a, a) -> [a] -> [(a, a)] + accumIntervals (lower, upper) [] = [(lower, upper)] + accumIntervals (lower, upper) (first' : ascendingRest') = if succ upper == first' + then accumIntervals (lower, first') ascendingRest' + else (lower, upper) : accumIntervals (first', first') ascendingRest' + +-- $setup +-- >>> import Data.Int diff --git a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs --- a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} module Database.PostgreSQL.PQTypes.Model.ColumnType ( ColumnType(..) , columnTypeToSQL diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs --- a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs @@ -4,27 +4,28 @@ monadic DSL for building SQL statements on the fly. Some examples: >>> :{ ->>> | sqlSelect "documents" $ do ->>> | sqlResult "id" ->>> | sqlResult "title" ->>> | sqlResult "mtime" ->>> | sqlOrderBy "documents.mtime DESC" ->>> | sqlWhereILike "documents.title" "%pattern%" ->>> :} -SQL " SELECT id, title, mtime FROM documents WHERE (documents.title ILIKE <\"%pattern%\">) ORDER BY documents.mtime DESC " +sqlSelect "documents" $ do + sqlResult "id" + sqlResult "title" + sqlResult "mtime" + sqlOrderBy "documents.mtime DESC" + sqlWhereILike "documents.title" "%pattern%" +:} +SQL " SELECT id, title, mtime FROM documents WHERE (documents.title ILIKE <\"%pattern%\">) ORDER BY documents.mtime DESC " @SQL.Builder@ supports SELECT as 'sqlSelect' and data manipulation using 'sqlInsert', 'sqlInsertSelect', 'sqlDelete' and 'sqlUpdate'. ->>> import Data.Time.Clock ->>> now <- getCurrentTime +>>> import Data.Time +>>> let title = "title" :: String +>>> let ctime = read "2020-01-01 00:00:00 UTC" :: UTCTime >>> :{ ->>> | sqlInsert "documents" $ do ->>> | sqlSet "title" title ->>> | sqlSet "ctime" now ->>> | sqlResult "id" ->>> :} -SQL " INSERT INTO documents (title, ctime) VALUES (<\"title\">, <\"2017-02-01 17:56:20.324894547 UTC\">) RETURNING id" +sqlInsert "documents" $ do + sqlSet "title" title + sqlSet "ctime" ctime + sqlResult "id" +:} +SQL " INSERT INTO documents (title, ctime) VALUES (<\"title\">, <2020-01-01 00:00:00 UTC>) RETURNING id" The 'sqlInsertSelect' is particulary interesting as it supports INSERT of values taken from a SELECT clause from same or even different @@ -38,12 +39,12 @@ element. >>> :{ ->>> | sqlInsert "documents" $ do ->>> | sqlSet "ctime" now ->>> | sqlSetList "title" ["title1", "title2", "title3"] ->>> | sqlResult "id" ->>> :} -SQL " INSERT INTO documents (ctime, title) VALUES (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title1\">) , (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title2\">) , (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title3\">) RETURNING id" +sqlInsert "documents" $ do + sqlSet "ctime" ctime + sqlSetList "title" ["title1", "title2", "title3"] + sqlResult "id" +:} +SQL " INSERT INTO documents (ctime, title) VALUES (<2020-01-01 00:00:00 UTC>, <\"title1\">) , (<2020-01-01 00:00:00 UTC>, <\"title2\">) , (<2020-01-01 00:00:00 UTC>, <\"title3\">) RETURNING id" The above will insert 3 new documents. @@ -51,17 +52,17 @@ 'sqlOrderBy', @GROUP BY@ as 'sqlGroupBy'. >>> :{ ->>> | sqlSelect "documents" $ do ->>> | sqlResult "id" ->>> | sqlResult "title" ->>> | sqlResult "mtime" ->>> | sqlOrderBy "documents.mtime DESC" ->>> | sqlOrderBy "documents.title" ->>> | sqlGroupBy "documents.status" ->>> | sqlJoinOn "users" "documents.user_id = users.id" ->>> | sqlWhere $ mkSQL "documents.title ILIKE" "%pattern%" ->>> :} -SQL " SELECT id, title, mtime FROM documents JOIN users ON documents.user_id = users.id WHERE (documents.title ILIKE <\"%pattern%\">) GROUP BY documents.status ORDER BY documents.mtime DESC, documents.title " +sqlSelect "documents" $ do + sqlResult "id" + sqlResult "title" + sqlResult "mtime" + sqlOrderBy "documents.mtime DESC" + sqlOrderBy "documents.title" + sqlGroupBy "documents.status" + sqlJoinOn "users" "documents.user_id = users.id" + sqlWhere $ mkSQL "documents.title ILIKE" "%pattern%" +:} +SQL " SELECT id, title, mtime FROM documents JOIN users ON documents.user_id = users.id WHERE (documents.title ILIKE <\"%pattern%\">) GROUP BY documents.status ORDER BY documents.mtime DESC, documents.title " Joins are done by 'sqlJoinOn', 'sqlLeftJoinOn', 'sqlRightJoinOn', 'sqlJoinOn', 'sqlFullJoinOn'. If everything fails use 'sqlJoin' and @@ -69,16 +70,16 @@ some kind of abstract syntax data type is lacking. >>> :{ ->>> | sqlDelete "mails" $ do ->>> | sqlWhere "id > 67" ->>> :} +sqlDelete "mails" $ do + sqlWhere "id > 67" +:} SQL " DELETE FROM mails WHERE (id > 67) " >>> :{ ->>> | sqlUpdate "document_tags" $ do ->>> | sqlSet "value" (123 :: Int) ->>> | sqlWhere "name = 'abc'" ->>> :} +sqlUpdate "document_tags" $ do + sqlSet "value" (123 :: Int) + sqlWhere "name = 'abc'" +:} SQL " UPDATE document_tags SET value=<123> WHERE (name = 'abc') " Exception returning and 'kWhyNot' are a subsystem for querying why a @@ -123,8 +124,7 @@ -} --- TODO: clean this up and fix the mess with --- "randomly" wrapping stuff in parentheses. +-- TODO: clean this up, add more documentation. module Database.PostgreSQL.PQTypes.SQL.Builder ( sqlWhere @@ -484,22 +484,27 @@ makeLongEnough (Many x) = take longest (x ++ repeat "DEFAULT") instance Sqlable SqlInsertSelect where - toSQLCommand cmd = - "INSERT INTO" <+> sqlInsertSelectWhat cmd <+> - parenthesize (sqlConcatComma (map fst (sqlInsertSelectSet cmd))) <+> - parenthesize (toSQLCommand (SqlSelect { sqlSelectFrom = sqlInsertSelectFrom cmd - , sqlSelectUnion = [] - , sqlSelectDistinct = sqlInsertSelectDistinct cmd - , sqlSelectResult = fmap snd $ sqlInsertSelectSet cmd - , sqlSelectWhere = sqlInsertSelectWhere cmd - , sqlSelectOrderBy = sqlInsertSelectOrderBy cmd - , sqlSelectGroupBy = sqlInsertSelectGroupBy cmd - , sqlSelectHaving = sqlInsertSelectHaving cmd - , sqlSelectOffset = sqlInsertSelectOffset cmd - , sqlSelectLimit = sqlInsertSelectLimit cmd - , sqlSelectWith = sqlInsertSelectWith cmd - })) <+> - emitClausesSepComma "RETURNING" (sqlInsertSelectResult cmd) + toSQLCommand cmd = smconcat + -- WITH clause needs to be at the top level, so we emit it here and not + -- include it in the SqlSelect below. + [ emitClausesSepComma "WITH" $ + map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlInsertSelectWith cmd) + , "INSERT INTO" <+> sqlInsertSelectWhat cmd + , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd + , parenthesize . toSQLCommand $ SqlSelect { sqlSelectFrom = sqlInsertSelectFrom cmd + , sqlSelectUnion = [] + , sqlSelectDistinct = sqlInsertSelectDistinct cmd + , sqlSelectResult = fmap snd $ sqlInsertSelectSet cmd + , sqlSelectWhere = sqlInsertSelectWhere cmd + , sqlSelectOrderBy = sqlInsertSelectOrderBy cmd + , sqlSelectGroupBy = sqlInsertSelectGroupBy cmd + , sqlSelectHaving = sqlInsertSelectHaving cmd + , sqlSelectOffset = sqlInsertSelectOffset cmd + , sqlSelectLimit = sqlInsertSelectLimit cmd + , sqlSelectWith = [] + } + , emitClausesSepComma "RETURNING" $ sqlInsertSelectResult cmd + ] instance Sqlable SqlUpdate where toSQLCommand cmd = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -34,7 +34,8 @@ instance IsOption ConnectionString where defaultValue = ConnectionString - "postgresql://postgres@localhost/travis_ci_test" + -- For GitHub Actions CI + "host=postgres user=postgres password=postgres" parseValue = Just . ConnectionString optionName = return "connection-string" optionHelp = return "Postgres connection string"