Replace haskell-src-exts with ghc-lib-parser

.hlint.yaml

@@ -4,6 +4,9 @@
 
 - arguments:
   - "--cpp-define=MIN_VERSION_base(a,b,c)=1"
+  - "--cpp-define=MIN_VERSION_template_haskell(2,21,0)=1"
+  - "--cpp-define=MIN_VERSION_template_haskell(2,22,0)=1"
+  - "--cpp-define=MIN_VERSION_template_haskell(2,23,0)=0"
   - "-XQuasiQuotes"
   - "-XTemplateHaskell"
   - "-XOverloadedRecordDot"

hpgsql-tests/ParsingSpec.hs

@@ -299,25 +299,25 @@ spec = do
 
     it "parseSql AcceptQuasiQuoterExpressions preserves quasiquoter expressions with parentheses" $ do
       let input = "SELECT ^{escapeIdentifier (fromQuery name)}, #{someFunc (arg1) arg2}"
-          result = parseSql AcceptQuasiQuoterExpressions input
+          result = parseSql (AcceptQuasiQuoterExpressions []) input
           qqExprs = [(k, t) | QuasiQuoterExpression k t <- result]
       qqExprs `shouldBe` [(QQEmbeddedQuery, "escapeIdentifier (fromQuery name)"), (QQInterpolation, "someFunc (arg1) arg2")]
 
     it "parseSql AcceptQuasiQuoterExpressions handles nested parentheses in expressions" $ do
       let input = "SELECT #{f (g (x))}"
-          result = parseSql AcceptQuasiQuoterExpressions input
+          result = parseSql (AcceptQuasiQuoterExpressions []) input
           qqExprs = [(k, t) | QuasiQuoterExpression k t <- result]
       qqExprs `shouldBe` [(QQInterpolation, "f (g (x))")]
 
     it "parseSql AcceptQuasiQuoterExpressions inside parenthesised SQL expressions" $ do
       let input = "SELECT (#{someFunc (arg)})"
-          result = parseSql AcceptQuasiQuoterExpressions input
+          result = parseSql (AcceptQuasiQuoterExpressions []) input
           qqExprs = [(k, t) | QuasiQuoterExpression k t <- result]
       qqExprs `shouldBe` [(QQInterpolation, "someFunc (arg)")]
 
     it "parseSql AcceptQuasiQuoterExpressions handles } inside Haskell strings" $ do
       let input = "SELECT #{\"abc}\" ++ x}"
-          result = parseSql AcceptQuasiQuoterExpressions input
+          result = parseSql (AcceptQuasiQuoterExpressions []) input
           qqExprs = [(k, t) | QuasiQuoterExpression k t <- result]
       qqExprs `shouldBe` [(QQInterpolation, "\"abc}\" ++ x")]
 

hpgsql-tests/SqlQuasiquoterSpec.hs

@@ -4,16 +4,21 @@ import Control.Monad (forM_)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Char (isDigit)
+import Data.Functor.Contravariant (contramap)
+import Data.Int (Int32)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NE
+import Data.Proxy (Proxy (..))
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import qualified Data.Vector as Vector
+import GHC.Generics (Generic)
 import Hedgehog (Gen, PropertyT, annotateShow, forAll, (===))
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 import Hpgsql.Builder (BinaryField (..))
-import Hpgsql.Encoding (RowEncoder (..), ToPgRow (..))
+import Hpgsql.Encoding (FromPgField, LowerCasedPgEnum (..), RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeEncoder, typeFieldEncoder, typeOidWithName)
 import Hpgsql.InternalTypes (Query (..), SingleQuery (..))
 import Hpgsql.ParsingInternal (ParsingOpts (..), parseSql)
 import Hpgsql.Query (breakQueryIntoStatements, mkQuery, sql)
@@ -144,23 +149,68 @@ genMkQuery =
         pure (mkQuery "SELECT $1, $2, $3, $4, $5;" params, toComparableParams params)
     ]
 
+data SomeRecord = SomeRecord {field1 :: Int, field2 :: Int}
+
+data SomeGenericEnum = EVal1 | EVal2 | EVal3
+  deriving stock (Bounded, Enum, Eq, Generic, Show)
+  deriving (ToPgField) via (LowerCasedPgEnum SomeGenericEnum)
+
+data IntAndBool = IntAndBool {ibInt :: Int, ibBool :: Bool}
+  deriving stock (Eq, Show)
+
+instance ToPgField IntAndBool where
+  fieldEncoder =
+    typeFieldEncoder (typeOidWithName "int_and_bool") $
+      compositeTypeEncoder $
+        contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder
+
+-- | This exists to test TypeApplications inside quasiquoters.
+polyFunc42 :: Proxy a -> Int
+polyFunc42 _ = 42
+
+infixFunc :: Char -> String -> String
+infixFunc c s = c : s
+
 -- | Queries built with the sql quasiquoter and #{} interpolation.
+-- These test a variety of GHC extensions and language syntax/features
+-- inside quasiquoters.
 genInterpolatedQuery :: Gen (Query, [(Maybe Oid, BinaryField)])
 genInterpolatedQuery =
   Gen.choice
     [ pure ([sql|SELECT 1, '#{x}', '^{y}';|], []),
       do
         x <- genInt
-        pure ([sql|SELECT #{x};|], toComparableParams (Only x)),
+        y <- genInt
+        c <- genChar
+        pure ([sql|SELECT #{c `infixFunc` "abc"} #{if True then x else 0}, #{polyFunc42 (Proxy @String)}, #{Vector.fromList $ 37 : [45, y]};|], toComparableParams (c `infixFunc` "abc", x, polyFunc42 (Proxy @String), Vector.fromList [37, 45, y])),
       do
-        x <- genInt
+        x <- SomeRecord <$> genInt <*> genInt
         y <- genInt
-        pure ([sql|SELECT #{x}, #{y};|], toComparableParams (x, y)),
+        z <- Gen.bool
+        pure ([sql|SELECT #{x.field1}, #{-(x.field2)}, #{IntAndBool { ibInt = y, {- Some comment -} ibBool = z }}, #{'a'};|], toComparableParams (x.field1, -(x.field2), IntAndBool y z, 'a')),
       do
         x <- genInt
         y <- genInt
         z <- genInt
-        pure ([sql|SELECT #{x} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, y, z))
+        e :: SomeGenericEnum <- Gen.enum minBound maxBound
+        pure ([sql|SELECT #{x}, #{e} FROM t WHERE #{y} BETWEEN 0 AND #{fromIntegral z + 1.421::Float};|], toComparableParams (x, e, y, fromIntegral z + 1.421 :: Float)),
+      do
+        x <- genInt
+        b <- Gen.bool
+        pure
+          ( [sql|SELECT #{fst <$> Just (b, False)}, #{case compare x 0 of
+                                                      !EQ -> "abc"::Text
+                                                      GT -> "cde"
+                                                      LT -> "xyz"
+                                                      _ -> error "Impossible"};|],
+            toComparableParams
+              ( b,
+                case compare x 0 of
+                  !EQ -> "abc" :: Text
+                  GT -> "cde"
+                  LT -> "xyz"
+              )
+          )
     ]
 
 -- | Queries built with ^{} embedded queries, including reused placeholders.

hpgsql/hpgsql.cabal

@@ -43,7 +43,10 @@ library
       Hpgsql.Types
   other-modules:
       Hpgsql.Base
+      Hpgsql.GhcParseExp
+      Hpgsql.GhcParserOpts
       Hpgsql.Internal
+      Hpgsql.LanguageHaskell.FromThExtension
       Hpgsql.Locking
       Hpgsql.Msgs
       Hpgsql.Networking
@@ -104,7 +107,7 @@ library
     crypton >= 1.0.0 && < 1.1,
     memory >= 0.18.0 && < 0.19,
     hashable >= 1.5 && < 1.6,
-    haskell-src-meta >= 0.8 && < 0.9,
+    ghc-lib-parser >= 9.6 && < 9.14,
     network >= 3.2 && < 3.3,
     network-uri >= 2.6 && < 2.7,
     safe-exceptions >= 0.1 && < 0.2,