packages feed

hasql-interpolate 1.0.1.0 → 1.1.0.0

raw patch · 9 files changed

+132/−60 lines, 9 filesdep ~hasqldep ~tmp-postgres

Dependency ranges changed: hasql, tmp-postgres

Files

CHANGELOG.md view
@@ -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`
LICENSE view
@@ -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:
hasql-interpolate.cabal view
@@ -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 <hello@travisstaton.com>, Mitchell Dalvi Rosen <mitchellwrosen@gmail.com> 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
lib/Hasql/Interpolate.hs view
@@ -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
lib/Hasql/Interpolate/Internal/CompositeValue.hs view
@@ -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
lib/Hasql/Interpolate/Internal/Json.hs view
@@ -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
lib/Hasql/Interpolate/Internal/Sql.hs view
@@ -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 (<>) #-}
lib/Hasql/Interpolate/Internal/TH.hs view
@@ -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
test/Main.hs view
@@ -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)