diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## [1.1.0.0] – March 31, 2026 + +* Normalize whitespace - multiple consecutive whitespace characters are normalized to a single space. +* Support `hasql-1.10` + ## [1.0.1.0] - July 16, 2024 * Add `DecodeValue` instance for `ByteString` and `LazyByteString` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2021-2024 Travis Staton, Mitchell Dalvi Rosen +Copyright 2021-2025 Travis Staton, Mitchell Dalvi Rosen Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/hasql-interpolate.cabal b/hasql-interpolate.cabal --- a/hasql-interpolate.cabal +++ b/hasql-interpolate.cabal @@ -1,15 +1,15 @@ cabal-version: 2.4 name: hasql-interpolate -version: 1.0.1.0 +version: 1.1.0.0 author: Travis Staton, Mitchell Dalvi Rosen category: Hasql, Database, PostgreSQL -copyright: Copyright (C) 2021-2024 Travis Staton, Mitchell Dalvi Rosen +copyright: Copyright (C) 2021-2025 Travis Staton, Mitchell Dalvi Rosen extra-source-files: CHANGELOG.md homepage: https://github.com/awkward-squad/hasql-interpolate license-file: LICENSE license: BSD-3-Clause -tested-with: GHC == 9.2.8, GHC == 9.4.5 +tested-with: GHC == 9.10.3, GHC == 9.12.2 maintainer: Travis Staton , Mitchell Dalvi Rosen synopsis: QuasiQuoter that supports expression interpolation for hasql description: @@ -37,16 +37,43 @@ build-depends: aeson ^>= 1.5 || ^>= 2.0 || ^>= 2.1 || ^>= 2.2, array ^>= 0.5, - base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20, + base + ^>= 4.14 + || ^>= 4.15 + || ^>= 4.16 + || ^>= 4.17 + || ^>= 4.18 + || ^>= 4.19 + || ^>= 4.20 + || ^>= 4.21, bytestring ^>= 0.11.2.0 || ^>= 0.12, - containers ^>= 0.5 || ^>= 0.6 || ^>= 0.7, + containers ^>= 0.5 || ^>= 0.6 || ^>= 0.7 || ^>= 0.8, haskell-src-meta ^>= 0.8, - hasql ^>= 1.8, + hasql ^>= 1.10, iproute ^>= 1.7, - megaparsec ^>= 8.0.0 || ^>= 9.0 || ^>= 9.1 || ^>= 9.2 || ^>= 9.3 || ^>= 9.4 || ^>= 9.5 || ^>= 9.6, + megaparsec + ^>= 8.0.0 + || ^>= 9.0 + || ^>= 9.1 + || ^>= 9.2 + || ^>= 9.3 + || ^>= 9.4 + || ^>= 9.5 + || ^>= 9.6 + || ^>= 9.7, mtl ^>= 2.1 || ^>= 2.2 || ^>= 2.3, scientific ^>= 0.3, - template-haskell ^>= 2.14 || ^>= 2.15 || ^>= 2.16 || ^>= 2.17 || ^>= 2.18 || ^>= 2.19 || ^>= 2.20 || ^>= 2.21 || ^>= 2.22, + template-haskell + ^>= 2.14 + || ^>= 2.15 + || ^>= 2.16 + || ^>= 2.17 + || ^>= 2.18 + || ^>= 2.19 + || ^>= 2.20 + || ^>= 2.21 + || ^>= 2.22 + || ^>= 2.23, text ^>= 1.2.4 || ^>= 2.0 || ^>= 2.1, time ^>= 1.9.3 || ^>= 1.10 || ^>= 1.11 || ^>= 1.12 || ^>= 1.14, transformers ^>= 0.5 || ^>= 0.6, @@ -69,12 +96,12 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base - , hasql + , hasql ^>= 1.10 , hasql-interpolate , template-haskell , tasty , text , tasty-hunit - , tmp-postgres + , tmp-postgres >= 1.34.1.0 hs-source-dirs: test default-language: Haskell2010 diff --git a/lib/Hasql/Interpolate.hs b/lib/Hasql/Interpolate.hs --- a/lib/Hasql/Interpolate.hs +++ b/lib/Hasql/Interpolate.hs @@ -37,8 +37,8 @@ where import Control.Monad.Trans.State.Strict (evalState) -import Data.ByteString.Builder (toLazyByteString) -import Data.ByteString.Lazy (toStrict) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as Builder import Hasql.Decoders (Result, foldlRows) import Hasql.Interpolate.Internal.CompositeValue import Hasql.Interpolate.Internal.Decoder @@ -50,7 +50,7 @@ import Hasql.Interpolate.Internal.RowsAffected import Hasql.Interpolate.Internal.Sql import Hasql.Interpolate.Internal.TH -import Hasql.Statement (Statement (..)) +import qualified Hasql.Statement as Statement -- | Interpolate a 'Sql' into a 'Statement' using the 'DecodeResult' -- type class to determine the appropriate decoder. @@ -60,18 +60,21 @@ -- example bonk = interp False [sql| select x, y from t where t.x > #{bonk} |] -- @ interp :: - DecodeResult b => + (DecodeResult b) => -- | 'True' if the 'Statement' should be prepared Bool -> Sql -> - Statement () b + Statement.Statement () b interp prepared = interpWith prepared decodeResult -- | interpolate then consume with 'foldlRows' -interpFoldl :: DecodeRow a => Bool -> (b -> a -> b) -> b -> Sql -> Statement () b +interpFoldl :: (DecodeRow a) => Bool -> (b -> a -> b) -> b -> Sql -> Statement.Statement () b interpFoldl prepared f z = interpWith prepared (foldlRows f z decodeRow) -- | A more general version of 'interp' that allows for passing an -- explicit decoder. -interpWith :: Bool -> Result b -> Sql -> Statement () b -interpWith prepare decoder (Sql bldr enc) = Statement (toStrict (toLazyByteString (evalState bldr 1))) enc decoder prepare +interpWith :: Bool -> Result b -> Sql -> Statement.Statement () b +interpWith prepare decoder (Sql bldr enc) = + if prepare + then Statement.preparable (TL.toStrict $ Builder.toLazyText $ evalState bldr 1) enc decoder + else Statement.unpreparable (TL.toStrict $ Builder.toLazyText $ evalState bldr 1) enc decoder diff --git a/lib/Hasql/Interpolate/Internal/CompositeValue.hs b/lib/Hasql/Interpolate/Internal/CompositeValue.hs --- a/lib/Hasql/Interpolate/Internal/CompositeValue.hs +++ b/lib/Hasql/Interpolate/Internal/CompositeValue.hs @@ -28,16 +28,16 @@ = CompositeValue a instance (Generic a, GToComposite (Rep a)) => DecodeValue (CompositeValue a) where - decodeValue = coerce @(Value a) (composite (to <$> gtoComposite)) + decodeValue = fmap (coerce @a) (record (to <$> gtoComposite)) class GToComposite a where gtoComposite :: Composite (a p) -instance GToComposite a => GToComposite (M1 t i a) where +instance (GToComposite a) => GToComposite (M1 t i a) where gtoComposite = M1 <$> gtoComposite instance (GToComposite a, GToComposite b) => GToComposite (a :*: b) where gtoComposite = (:*:) <$> gtoComposite <*> gtoComposite -instance DecodeValue a => GToComposite (K1 i a) where +instance (DecodeValue a) => GToComposite (K1 i a) where gtoComposite = K1 <$> field decodeField diff --git a/lib/Hasql/Interpolate/Internal/Json.hs b/lib/Hasql/Interpolate/Internal/Json.hs --- a/lib/Hasql/Interpolate/Internal/Json.hs +++ b/lib/Hasql/Interpolate/Internal/Json.hs @@ -58,28 +58,28 @@ -- | Parse a postgres @jsonb@ using 'D.jsonb' instance DecodeValue Jsonb where - decodeValue = coerce D.jsonb + decodeValue = Jsonb <$> D.jsonb -- | Parse a postgres @json@ using 'D.json' instance DecodeValue Json where - decodeValue = coerce D.json + decodeValue = Json <$> D.json -- | Parse a postgres @jsonb@ using 'D.jsonbBytes' instance DecodeValue JsonbBytes where - decodeValue = coerce (D.jsonbBytes Right) + decodeValue = D.jsonbBytes (Right . JsonbBytes) -- | Parse a postgres @json@ using 'D.jsonBytes' instance DecodeValue JsonBytes where - decodeValue = coerce (D.jsonBytes Right) + decodeValue = D.jsonBytes (Right . JsonBytes) -- | Parse a postgres @json@ to anything that is an instance of -- 'Aeson.FromJSON' -instance Aeson.FromJSON a => DecodeValue (AsJson a) where +instance (Aeson.FromJSON a) => DecodeValue (AsJson a) where decodeValue = AsJson <$> D.jsonBytes (first T.pack . Aeson.eitherDecodeStrict) -- | Parse a postgres @jsonb@ to anything that is an instance of -- 'Aeson.FromJSON' -instance Aeson.FromJSON a => DecodeValue (AsJsonb a) where +instance (Aeson.FromJSON a) => DecodeValue (AsJsonb a) where decodeValue = AsJsonb <$> D.jsonbBytes (first T.pack . Aeson.eitherDecodeStrict) -- | Encode an Aeson 'Aeson.Value' to a postgres @json@ using 'E.json' @@ -99,9 +99,9 @@ encodeValue = coerce E.jsonbBytes -- | Encode anything that is an instance of 'Aeson.ToJSON' to a postgres @json@ -instance Aeson.ToJSON a => EncodeValue (AsJson a) where +instance (Aeson.ToJSON a) => EncodeValue (AsJson a) where encodeValue = BL.toStrict . Aeson.encode . coerce @_ @a >$< E.jsonBytes -- | Encode anything that is an instance of 'Aeson.ToJSON' to a postgres @jsonb@ -instance Aeson.ToJSON a => EncodeValue (AsJsonb a) where +instance (Aeson.ToJSON a) => EncodeValue (AsJsonb a) where encodeValue = BL.toStrict . Aeson.encode . coerce @_ @a >$< E.jsonbBytes diff --git a/lib/Hasql/Interpolate/Internal/Sql.hs b/lib/Hasql/Interpolate/Internal/Sql.hs --- a/lib/Hasql/Interpolate/Internal/Sql.hs +++ b/lib/Hasql/Interpolate/Internal/Sql.hs @@ -6,29 +6,28 @@ where import Control.Monad.Trans.State.Strict -import Data.ByteString.Builder import Data.String (IsString (..)) +import qualified Data.Text.Lazy.Builder as Builder import Hasql.Encoders -- | A SQL string with interpolated expressions. data Sql = Sql { -- | The sql string. It is stateful over an 'Int' in order to -- assign the postgresql parameter placeholders (e.g. @$1@, @$2@) - sqlTxt :: State Int Builder, + sqlTxt :: State Int Builder.Builder, -- | The encoders associated with the sql string. Already applied -- to their parameters. encoder :: Params () } instance IsString Sql where - fromString str = Sql (pure (stringUtf8 str)) mempty + fromString str = Sql (pure (Builder.fromString str)) mempty instance Semigroup Sql where a <> b = Sql { sqlTxt = - ( (<>) <$> sqlTxt a <*> sqlTxt b - ), + ((<>) <$> sqlTxt a <*> sqlTxt b), encoder = encoder a <> encoder b } {-# INLINE (<>) #-} diff --git a/lib/Hasql/Interpolate/Internal/TH.hs b/lib/Hasql/Interpolate/Internal/TH.hs --- a/lib/Hasql/Interpolate/Internal/TH.hs +++ b/lib/Hasql/Interpolate/Internal/TH.hs @@ -24,12 +24,13 @@ import Control.Monad (replicateM) import Control.Monad.State.Strict (State, StateT, execStateT, get, put, state) import Data.Array (listArray, (!)) -import Data.ByteString.Builder (Builder, stringUtf8) import Data.Char import Data.Functor import Data.Functor.Contravariant import qualified Data.IntSet as IS import Data.Monoid (Ap (..)) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Builder import Data.Void import qualified Hasql.Encoders as E import Hasql.Interpolate.Internal.Encoder (EncodeField (..)) @@ -126,9 +127,20 @@ pure next appendSqlBuilderExp :: SqlBuilderExp -> Parser () - appendSqlBuilderExp x = do - st <- get - put st {ps'sqlBuilderExp = ps'sqlBuilderExp st . (x :)} + appendSqlBuilderExp x = + case x of + -- special case: trim trailing whitespace if at the very end + Sbe'Sql s -> do + st <- get + put + st + { ps'sqlBuilderExp = \case + [] -> ps'sqlBuilderExp st [Sbe'Sql (dropTrailingWhitespace s)] + xs -> ps'sqlBuilderExp st (x : xs) + } + _ -> do + st <- get + put st {ps'sqlBuilderExp = ps'sqlBuilderExp st . (x :)} appendEncoder :: ParamEncoder -> Parser () appendEncoder x = do @@ -250,17 +262,30 @@ someSql = do s <- anySingle content <- takeWhileP (Just "sql") (\c -> IS.notMember (fromEnum c) breakCharsIS) - appendSqlBuilderExp (Sbe'Sql (s : content)) + appendSqlBuilderExp (Sbe'Sql (normalizeWhitespace (s : content))) go +-- Everywhere in a string, collapse consecutive runs of whitespace to a single space +-- +-- normalizeWhitespace " foo\n \n \n \t\t bar " = " foo bar " +normalizeWhitespace :: String -> String +normalizeWhitespace = \case + x : xs | isSpace x -> ' ' : normalizeWhitespace (dropWhile isSpace xs) + x : xs -> x : normalizeWhitespace xs + "" -> "" + +dropTrailingWhitespace :: String -> String +dropTrailingWhitespace = + reverse . dropWhile isSpace . reverse + addParam :: State Int Builder addParam = state \i -> let !i' = i + 1 - in (dollar <> stringUtf8 (show i), i') + in (dollar <> Builder.fromString (show i), i') parseSqlExpr :: String -> Either (ParseErrorBundle String Void) SqlExpr parseSqlExpr str = do - ps <- runParser (execStateT sqlExprParser (ParserState id id id 0)) "" str + ps <- runParser (execStateT sqlExprParser (ParserState id id id 0)) "" (dropWhile isSpace str) pure SqlExpr { sqlBuilderExp = ps'sqlBuilderExp ps [], @@ -312,11 +337,11 @@ let go a b = case a of Sbe'Var i -> [e|Ap $(varE (nameArr ! i)) <> $b|] Sbe'Param -> [e|Ap addParam <> $b|] - Sbe'Quote content -> [e|pure (sq <> stringUtf8 content <> sq) <> $b|] - Sbe'Ident content -> [e|pure (dq <> stringUtf8 content <> dq) <> $b|] - Sbe'DollarQuote tag content -> [e|pure (dollar <> stringUtf8 tag <> dollar <> stringUtf8 content <> dollar <> stringUtf8 tag <> dollar) <> $b|] + Sbe'Quote content -> [e|pure (sq <> Builder.fromString content <> sq) <> $b|] + Sbe'Ident content -> [e|pure (dq <> Builder.fromString content <> dq) <> $b|] + Sbe'DollarQuote tag content -> [e|pure (dollar <> Builder.fromString tag <> dollar <> Builder.fromString content <> dollar <> Builder.fromString tag <> dollar) <> $b|] Sbe'Cquote content -> [e|pure (cquote <> content <> sq) <> $b|] - Sbe'Sql content -> [e|pure (stringUtf8 content) <> $b|] + Sbe'Sql content -> [e|pure (Builder.fromString content) <> $b|] in foldr go [e|pure mempty|] sqlBuilder encExp <- let go a b = case a of diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,14 +12,18 @@ import Control.Exception import Data.Int +import Data.String (fromString) import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import qualified Database.Postgres.Temp as Tmp import GHC.Generics (Generic) -import qualified Hasql.Connection as Hasql +import qualified Hasql.Connection +import qualified Hasql.Connection.Settings import Hasql.Decoders (column) import Hasql.Interpolate import Hasql.Interpolate.Internal.TH -import qualified Hasql.Session as Hasql +import qualified Hasql.Session import Language.Haskell.TH import Test.Tasty import Test.Tasty.HUnit @@ -42,7 +46,8 @@ "parser" [ testCase "quote" testParseQuotes, testCase "comment" testParseComment, - testCase "param" testParseParam + testCase "param" testParseParam, + testCase "whitespace" testNormalizeWhitespace ] executionTests :: IO Tmp.DB -> TestTree @@ -79,9 +84,9 @@ let expected = SqlExpr expectedSqlExpr [] [] 0 expectedSqlExpr = [ Sbe'Sql "content ", - Sbe'Sql "\nhello ", - Sbe'Sql " world\n", - Sbe'Sql " end\n" + Sbe'Sql " hello ", + Sbe'Sql " world ", + Sbe'Sql " end" ] inputStr = unlines @@ -126,7 +131,7 @@ res <- run conn [sql| select * from (values (row(0,0)), (row(1,1)) ) as t |] res @?= map OneColumn expected -data T = T Int64 Bool Text deriving stock (Eq, Show) +data T = T Int32 Bool Text deriving stock (Eq, Show) instance DecodeRow T where decodeRow = @@ -158,26 +163,34 @@ res <- run conn [sql| select * from (values (0,0), (1,1) ) as t(x,y) where t.x = #{xVal} and ^{snippet} |] res @?= expected -withLocalTransaction :: IO Tmp.DB -> (Hasql.Connection -> IO a) -> IO a +testNormalizeWhitespace :: IO () +testNormalizeWhitespace = do + let t actual expected = parseSqlExpr actual @?= Right (SqlExpr [Sbe'Sql expected] [] [] 0) + t "select 1 " "select 1" + t " select 1" "select 1" + t "select 1" "select 1" + t "\n select 1 \n where true \n " "select 1 where true" + +withLocalTransaction :: IO Tmp.DB -> (Hasql.Connection.Connection -> IO a) -> IO a withLocalTransaction getDb k = - getDb >>= \db -> bracket (either (fail . show) pure =<< Hasql.acquire (Tmp.toConnectionString db)) Hasql.release \conn -> do + getDb >>= \db -> bracket (either (fail . show) pure =<< Hasql.Connection.acquire (fromString (Text.unpack (Text.decodeUtf8 (Tmp.toConnectionString db))))) Hasql.Connection.release \conn -> do let beginTrans = do - Hasql.run (Hasql.statement () (interp False [sql| begin |])) conn >>= \case + Hasql.Connection.use conn (Hasql.Session.statement () (interp False [sql| begin |])) >>= \case Left err -> fail (show err) Right () -> pure () rollbackTrans = do - Hasql.run (Hasql.statement () (interp False [sql| rollback |])) conn >>= \case + Hasql.Connection.use conn (Hasql.Session.statement () (interp False [sql| rollback |])) >>= \case Left err -> fail (show err) Right () -> pure () bracket beginTrans (\() -> rollbackTrans) \() -> k conn -run :: DecodeResult a => Hasql.Connection -> Sql -> IO a +run :: DecodeResult a => Hasql.Connection.Connection -> Sql -> IO a run conn stmt = do - Hasql.run (Hasql.statement () (interp False stmt)) conn >>= \case + Hasql.Connection.use conn (Hasql.Session.statement () (interp False stmt)) >>= \case Left err -> assertFailure ("Hasql statement unexpectedly failed with error: " <> show err) Right x -> pure x -data Point = Point Int64 Int64 +data Point = Point Int32 Int32 deriving stock (Generic, Eq, Show) deriving (DecodeValue) via CompositeValue Point deriving anyclass (DecodeRow)