hasql-interpolate 1.1.0.0 → 1.1.0.1
raw patch · 4 files changed
+130/−86 lines, 4 filesdep −hasql-interpolatedep ~basedep ~template-haskelldep ~text
Dependencies removed: hasql-interpolate
Dependency ranges changed: base, template-haskell, text
Files
- CHANGELOG.md +4/−0
- hasql-interpolate.cabal +38/−26
- lib/Hasql/Interpolate/Internal/TH.hs +33/−39
- test/Main.hs +55/−21
CHANGELOG.md view
@@ -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.
hasql-interpolate.cabal view
@@ -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
lib/Hasql/Interpolate/Internal/TH.hs view
@@ -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|]
test/Main.hs view
@@ -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)