diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## [1.1.0.1] – April 14, 2026 + +* Fix bug in normalizing whitespace + ## [1.1.0.0] – March 31, 2026 * Normalize whitespace - multiple consecutive whitespace characters are normalized to a single space. diff --git a/hasql-interpolate.cabal b/hasql-interpolate.cabal --- a/hasql-interpolate.cabal +++ b/hasql-interpolate.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hasql-interpolate -version: 1.1.0.0 +version: 1.1.0.1 author: Travis Staton, Mitchell Dalvi Rosen category: Hasql, Database, PostgreSQL @@ -19,22 +19,7 @@ snippets. A number of type classes are also provided to reduce encoder/decoder boilerplate. -library - exposed-modules: Hasql.Interpolate - Hasql.Interpolate.Internal.TH - - other-modules: Hasql.Interpolate.Internal.Json - Hasql.Interpolate.Internal.Encoder - Hasql.Interpolate.Internal.Decoder - Hasql.Interpolate.Internal.OneColumn - Hasql.Interpolate.Internal.OneRow - Hasql.Interpolate.Internal.RowsAffected - Hasql.Interpolate.Internal.Decoder.TH - Hasql.Interpolate.Internal.Sql - Hasql.Interpolate.Internal.CompositeValue - Hasql.Interpolate.Internal.EncodeRow - Hasql.Interpolate.Internal.EncodeRow.TH - +common component build-depends: aeson ^>= 1.5 || ^>= 2.0 || ^>= 2.1 || ^>= 2.2, array ^>= 0.5, base @@ -79,9 +64,26 @@ transformers ^>= 0.5 || ^>= 0.6, uuid ^>= 1.3, vector ^>= 0.11 || ^>= 0.12 || ^>= 0.13, + default-language: Haskell2010 +library + import: component + exposed-modules: Hasql.Interpolate + Hasql.Interpolate.Internal.TH + + other-modules: Hasql.Interpolate.Internal.Json + Hasql.Interpolate.Internal.Encoder + Hasql.Interpolate.Internal.Decoder + Hasql.Interpolate.Internal.OneColumn + Hasql.Interpolate.Internal.OneRow + Hasql.Interpolate.Internal.RowsAffected + Hasql.Interpolate.Internal.Decoder.TH + Hasql.Interpolate.Internal.Sql + Hasql.Interpolate.Internal.CompositeValue + Hasql.Interpolate.Internal.EncodeRow + Hasql.Interpolate.Internal.EncodeRow.TH + hs-source-dirs: lib - default-language: Haskell2010 ghc-options: -Wall -Wcompat @@ -93,15 +95,25 @@ -O2 test-suite unit + import: component type: exitcode-stdio-1.0 main-is: Main.hs - build-depends: base - , hasql ^>= 1.10 - , hasql-interpolate - , template-haskell - , tasty - , text + build-depends: + tasty , tasty-hunit , tmp-postgres >= 1.34.1.0 - hs-source-dirs: test - default-language: Haskell2010 + hs-source-dirs: lib, test + other-modules: + Hasql.Interpolate + Hasql.Interpolate.Internal.CompositeValue + Hasql.Interpolate.Internal.Decoder + Hasql.Interpolate.Internal.Decoder.TH + Hasql.Interpolate.Internal.EncodeRow + Hasql.Interpolate.Internal.EncodeRow.TH + Hasql.Interpolate.Internal.Encoder + Hasql.Interpolate.Internal.Json + Hasql.Interpolate.Internal.OneColumn + Hasql.Interpolate.Internal.OneRow + Hasql.Interpolate.Internal.RowsAffected + Hasql.Interpolate.Internal.Sql + Hasql.Interpolate.Internal.TH 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 @@ -48,6 +48,7 @@ notFollowedBy, runParser, single, + takeWhile1P, takeWhileP, try, ) @@ -67,6 +68,7 @@ | Sbe'Ident String | Sbe'DollarQuote String String | Sbe'Cquote String + | Sbe'Whitespace | Sbe'Sql String deriving stock (Show, Eq) @@ -94,6 +96,9 @@ dq :: Builder dq = "\"" +space :: Builder +space = " " + data ParserState = ParserState { ps'sqlBuilderExp :: [SqlBuilderExp] -> [SqlBuilderExp], ps'paramEncoder :: [ParamEncoder] -> [ParamEncoder], @@ -115,6 +120,7 @@ <|> splice <|> comment <|> multilineComment + <|> whitespace <|> someSql <|> eof @@ -127,20 +133,9 @@ pure next appendSqlBuilderExp :: SqlBuilderExp -> Parser () - 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 :)} + appendSqlBuilderExp x = do + st <- get + put st {ps'sqlBuilderExp = ps'sqlBuilderExp st . (x :)} appendEncoder :: ParamEncoder -> Parser () appendEncoder x = do @@ -256,28 +251,25 @@ '^', '$', '-', - '/' + '/', + ' ', + '\t', + '\n', + '\f', + '\r' ] + whitespace = do + _ <- takeWhile1P (Just "whitespace") isSpace + appendSqlBuilderExp Sbe'Whitespace + go + someSql = do s <- anySingle content <- takeWhileP (Just "sql") (\c -> IS.notMember (fromEnum c) breakCharsIS) - appendSqlBuilderExp (Sbe'Sql (normalizeWhitespace (s : content))) + appendSqlBuilderExp (Sbe'Sql (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 @@ -285,7 +277,7 @@ parseSqlExpr :: String -> Either (ParseErrorBundle String Void) SqlExpr parseSqlExpr str = do - ps <- runParser (execStateT sqlExprParser (ParserState id id id 0)) "" (dropWhile isSpace str) + ps <- runParser (execStateT sqlExprParser (ParserState id id id 0)) "" str pure SqlExpr { sqlBuilderExp = ps'sqlBuilderExp ps [], @@ -334,15 +326,17 @@ ) spliceBindings sqlBuilderExp <- - 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 <> 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 (Builder.fromString content) <> $b|] - in foldr go [e|pure mempty|] sqlBuilder + let go :: SqlBuilderExp -> (Q Exp, Bool) -> (Q Exp, Bool) + go a (b, omitWhitespace) = case a of + Sbe'Var i -> ([e|Ap $(varE (nameArr ! i)) <> $b|], False) + Sbe'Param -> ([e|Ap addParam <> $b|], False) + Sbe'Quote content -> ([e|pure (sq <> Builder.fromString content <> sq) <> $b|], False) + Sbe'Ident content -> ([e|pure (dq <> Builder.fromString content <> dq) <> $b|], False) + Sbe'DollarQuote tag content -> ([e|pure (dollar <> Builder.fromString tag <> dollar <> Builder.fromString content <> dollar <> Builder.fromString tag <> dollar) <> $b|], undefined) + Sbe'Cquote content -> ([e|pure (cquote <> content <> sq) <> $b|], False) + Sbe'Whitespace -> (if omitWhitespace then b else [e|pure space <> $b|], True) + Sbe'Sql content -> ([e|pure (Builder.fromString content) <> $b|], False) + in fst (foldr go ([e|pure mempty|], False) sqlBuilder) encExp <- let go a b = case a of Pe'Exp x -> [e|($(pure x) >$ E.param encodeField) <> $b|] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,17 +11,21 @@ module Main where import Control.Exception +import Control.Monad.Trans.State.Strict (evalState) 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 Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as Builder import qualified Database.Postgres.Temp as Tmp import GHC.Generics (Generic) import qualified Hasql.Connection import qualified Hasql.Connection.Settings import Hasql.Decoders (column) import Hasql.Interpolate +import Hasql.Interpolate.Internal.Sql import Hasql.Interpolate.Internal.TH import qualified Hasql.Session import Language.Haskell.TH @@ -46,6 +50,8 @@ "parser" [ testCase "quote" testParseQuotes, testCase "comment" testParseComment, + testCase "end comment" testParseEndComment, + testCase "end multiline comment" testParseEndMultiComment, testCase "param" testParseParam, testCase "whitespace" testNormalizeWhitespace ] @@ -68,41 +74,59 @@ let expected = SqlExpr expectedSqlExpr [] [] 0 expectedSqlExpr = [ Sbe'Quote "#{bonk}", - Sbe'Sql " ", + Sbe'Whitespace, Sbe'Quote "^{z''onk}", - Sbe'Sql " ", + Sbe'Whitespace, Sbe'Ident "#{k\"\"onk}", - Sbe'Sql " ", + Sbe'Whitespace, Sbe'DollarQuote "tag" "#{kiplonk}", - Sbe'Sql " ", + Sbe'Whitespace, Sbe'Cquote "newline \\n escaped \\'string\\'" ] parseSqlExpr "'#{bonk}' '^{z''onk}' \"#{k\"\"onk}\" $tag$#{kiplonk}$tag$ E'newline \\n escaped \\'string\\''" @?= Right expected testParseComment :: IO () testParseComment = do + sqlToText + [sql| + content -- trailing comment + hello /* / comment * */ world + /* comment + blerg /* nested comment */ + */ end + |] + @?= " content hello world end " + +testParseEndComment :: IO () +testParseEndComment = do let expected = SqlExpr expectedSqlExpr [] [] 0 expectedSqlExpr = - [ Sbe'Sql "content ", - Sbe'Sql " hello ", - Sbe'Sql " world ", - Sbe'Sql " end" - ] + [Sbe'Sql "select", Sbe'Whitespace, Sbe'Sql "1", Sbe'Whitespace, Sbe'Whitespace] inputStr = unlines - [ "content -- trailing comment", - "hello /* / comment * */ world", - "/* comment", - "blerg /* nested comment */", - "*/ end" + [ "select 1 ", + " -- comment", + "\n\n" ] parseSqlExpr inputStr @?= Right expected +testParseEndMultiComment :: IO () +testParseEndMultiComment = do + sqlToText + [sql| + select 1 + /* comment + blerg + */ + + |] + @?= " select 1 " + testParseParam :: IO () testParseParam = do let expected = SqlExpr - [Sbe'Param, Sbe'Sql " ", Sbe'Param] + [Sbe'Param, Sbe'Whitespace, Sbe'Param] [Pe'Exp (VarE (mkName "x")), Pe'Exp (LitE (IntegerL 2))] [] 0 @@ -165,11 +189,17 @@ 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" + let t actual expected = parseSqlExpr actual @?= Right (SqlExpr expected [] [] 0) + sqlToText [sql|select 1 |] @?= "select 1 " + sqlToText [sql| select 1|] @?= " select 1" + sqlToText [sql|select 1|] @?= "select 1" + sqlToText + [sql| + select 1 + where true + |] + @?= " select 1 where true " + sqlToText ([sql| select |] <> [sql| 1 |]) @?= " select 1 " withLocalTransaction :: IO Tmp.DB -> (Hasql.Connection.Connection -> IO a) -> IO a withLocalTransaction getDb k = @@ -184,11 +214,15 @@ Right () -> pure () bracket beginTrans (\() -> rollbackTrans) \() -> k conn -run :: DecodeResult a => Hasql.Connection.Connection -> Sql -> IO a +run :: (DecodeResult a) => Hasql.Connection.Connection -> Sql -> IO a run conn stmt = do 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 + +sqlToText :: Sql -> Text +sqlToText (Sql bldr _) = + TL.toStrict $ Builder.toLazyText $ evalState bldr 1 data Point = Point Int32 Int32 deriving stock (Generic, Eq, Show)