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,69 @@ 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 42+#{let y = x + 1 in y*9}, #{fst <$> Just (b, False)}, #{case compare x 0 of
+                                                      !EQ -> "abc"::Text
+                                                      GT -> "cde"
+                                                      LT -> "xyz"
+                                                      _ -> error "Impossible"};|],
+            toComparableParams
+              ( let y = x + 1 in y * 9,
+                fst <$> Just (b, False),
+                case compare x 0 of
+                  !EQ -> "abc" :: Text
+                  GT -> "cde"
+                  LT -> "xyz"
+              )
+          )
     ]
 
 -- | Queries built with ^{} embedded queries, including reused placeholders.

hpgsql/hpgsql.cabal

@@ -44,6 +44,9 @@ library
   other-modules:
       Hpgsql.Base
       Hpgsql.Internal
+      Hpgsql.LanguageHaskell.FromThExtension
+      Hpgsql.LanguageHaskell.GhcParserOpts
+      Hpgsql.LanguageHaskell.ParseHaskellExpression
       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,

hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs

@@ -0,0 +1,173 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+
+module Hpgsql.LanguageHaskell.FromThExtension where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import GHC.LanguageExtensions.Type (Extension (..))
+import qualified "template-haskell" Language.Haskell.TH as TH
+
+fromThToGhcLibExtension :: TH.Extension -> Maybe Extension
+fromThToGhcLibExtension = \case
+  TH.AllowAmbiguousTypes -> Just AllowAmbiguousTypes
+  TH.AlternativeLayoutRule -> Just AlternativeLayoutRule
+  TH.AlternativeLayoutRuleTransitional -> Just AlternativeLayoutRuleTransitional
+  TH.ApplicativeDo -> Just ApplicativeDo
+  TH.Arrows -> Just Arrows
+  TH.AutoDeriveTypeable -> Just AutoDeriveTypeable
+  TH.BangPatterns -> Just BangPatterns
+  TH.BinaryLiterals -> Just BinaryLiterals
+  TH.BlockArguments -> Just BlockArguments
+  TH.CApiFFI -> Just CApiFFI
+  TH.CUSKs -> Just CUSKs
+  TH.ConstrainedClassMethods -> Just ConstrainedClassMethods
+  TH.ConstraintKinds -> Just ConstraintKinds
+  TH.Cpp -> Just Cpp
+  TH.DataKinds -> Just DataKinds
+  TH.DatatypeContexts -> Just DatatypeContexts
+  TH.DeepSubsumption -> Just DeepSubsumption
+  TH.DefaultSignatures -> Just DefaultSignatures
+  TH.DeriveAnyClass -> Just DeriveAnyClass
+  TH.DeriveDataTypeable -> Just DeriveDataTypeable
+  TH.DeriveFoldable -> Just DeriveFoldable
+  TH.DeriveFunctor -> Just DeriveFunctor
+  TH.DeriveGeneric -> Just DeriveGeneric
+  TH.DeriveLift -> Just DeriveLift
+  TH.DeriveTraversable -> Just DeriveTraversable
+  TH.DerivingStrategies -> Just DerivingStrategies
+  TH.DerivingVia -> Just DerivingVia
+  TH.DisambiguateRecordFields -> Just DisambiguateRecordFields
+  TH.DoAndIfThenElse -> Just DoAndIfThenElse
+  TH.DuplicateRecordFields -> Just DuplicateRecordFields
+  TH.EmptyCase -> Just EmptyCase
+  TH.EmptyDataDecls -> Just EmptyDataDecls
+  TH.EmptyDataDeriving -> Just EmptyDataDeriving
+  TH.ExistentialQuantification -> Just ExistentialQuantification
+  TH.ExplicitForAll -> Just ExplicitForAll
+  TH.ExplicitNamespaces -> Just ExplicitNamespaces
+  TH.ExtendedDefaultRules -> Just ExtendedDefaultRules
+  TH.FieldSelectors -> Just FieldSelectors
+  TH.FlexibleContexts -> Just FlexibleContexts
+  TH.FlexibleInstances -> Just FlexibleInstances
+  TH.ForeignFunctionInterface -> Just ForeignFunctionInterface
+  TH.FunctionalDependencies -> Just FunctionalDependencies
+  TH.GADTSyntax -> Just GADTSyntax
+  TH.GADTs -> Just GADTs
+  TH.GHCForeignImportPrim -> Just GHCForeignImportPrim
+  TH.GeneralizedNewtypeDeriving -> Just GeneralizedNewtypeDeriving
+  TH.HexFloatLiterals -> Just HexFloatLiterals
+  TH.ImplicitParams -> Just ImplicitParams
+  TH.ImplicitPrelude -> Just ImplicitPrelude
+  TH.ImportQualifiedPost -> Just ImportQualifiedPost
+  TH.ImpredicativeTypes -> Just ImpredicativeTypes
+  TH.IncoherentInstances -> Just IncoherentInstances
+  TH.InstanceSigs -> Just InstanceSigs
+  TH.InterruptibleFFI -> Just InterruptibleFFI
+  TH.JavaScriptFFI -> Just JavaScriptFFI
+  TH.KindSignatures -> Just KindSignatures
+  TH.LambdaCase -> Just LambdaCase
+  TH.LexicalNegation -> Just LexicalNegation
+  TH.LiberalTypeSynonyms -> Just LiberalTypeSynonyms
+  TH.LinearTypes -> Just LinearTypes
+  TH.MagicHash -> Just MagicHash
+  TH.MonadComprehensions -> Just MonadComprehensions
+  TH.MonoLocalBinds -> Just MonoLocalBinds
+  TH.MonomorphismRestriction -> Just MonomorphismRestriction
+  TH.MultiParamTypeClasses -> Just MultiParamTypeClasses
+  TH.MultiWayIf -> Just MultiWayIf
+  TH.NPlusKPatterns -> Just NPlusKPatterns
+  TH.NamedFieldPuns -> Just NamedFieldPuns
+  TH.NamedWildCards -> Just NamedWildCards
+  TH.NegativeLiterals -> Just NegativeLiterals
+  TH.NondecreasingIndentation -> Just NondecreasingIndentation
+  TH.NullaryTypeClasses -> Just NullaryTypeClasses
+  TH.NumDecimals -> Just NumDecimals
+  TH.NumericUnderscores -> Just NumericUnderscores
+  TH.OverlappingInstances -> Just OverlappingInstances
+  TH.OverloadedLabels -> Just OverloadedLabels
+  TH.OverloadedLists -> Just OverloadedLists
+  TH.OverloadedRecordDot -> Just OverloadedRecordDot
+  TH.OverloadedRecordUpdate -> Just OverloadedRecordUpdate
+  TH.OverloadedStrings -> Just OverloadedStrings
+  TH.PackageImports -> Just PackageImports
+  TH.ParallelArrays -> Just ParallelArrays
+  TH.ParallelListComp -> Just ParallelListComp
+  TH.PartialTypeSignatures -> Just PartialTypeSignatures
+  TH.PatternGuards -> Just PatternGuards
+  TH.PatternSynonyms -> Just PatternSynonyms
+  TH.PolyKinds -> Just PolyKinds
+  TH.PostfixOperators -> Just PostfixOperators
+  TH.QualifiedDo -> Just QualifiedDo
+  TH.QuantifiedConstraints -> Just QuantifiedConstraints
+  TH.QuasiQuotes -> Just QuasiQuotes
+  TH.RankNTypes -> Just RankNTypes
+  TH.RebindableSyntax -> Just RebindableSyntax
+  TH.RecordWildCards -> Just RecordWildCards
+  TH.RecursiveDo -> Just RecursiveDo
+  TH.RelaxedLayout -> Just RelaxedLayout
+  TH.RelaxedPolyRec -> Just RelaxedPolyRec
+  TH.RoleAnnotations -> Just RoleAnnotations
+  TH.ScopedTypeVariables -> Just ScopedTypeVariables
+  TH.StandaloneDeriving -> Just StandaloneDeriving
+  TH.StandaloneKindSignatures -> Just StandaloneKindSignatures
+  TH.StarIsType -> Just StarIsType
+  TH.StaticPointers -> Just StaticPointers
+  TH.Strict -> Just Strict
+  TH.StrictData -> Just StrictData
+  TH.TemplateHaskell -> Just TemplateHaskell
+  TH.TemplateHaskellQuotes -> Just TemplateHaskellQuotes
+  TH.TraditionalRecordSyntax -> Just TraditionalRecordSyntax
+  TH.TransformListComp -> Just TransformListComp
+  TH.TupleSections -> Just TupleSections
+  TH.TypeApplications -> Just TypeApplications
+  TH.TypeData -> Just TypeData
+  TH.TypeFamilies -> Just TypeFamilies
+  TH.TypeFamilyDependencies -> Just TypeFamilyDependencies
+  TH.TypeInType -> Just TypeInType
+  TH.TypeOperators -> Just TypeOperators
+  TH.TypeSynonymInstances -> Just TypeSynonymInstances
+  TH.UnboxedSums -> Just UnboxedSums
+  TH.UnboxedTuples -> Just UnboxedTuples
+  TH.UndecidableInstances -> Just UndecidableInstances
+  TH.UndecidableSuperClasses -> Just UndecidableSuperClasses
+  TH.UnicodeSyntax -> Just UnicodeSyntax
+  TH.UnliftedDatatypes -> Just UnliftedDatatypes
+  TH.UnliftedFFITypes -> Just UnliftedFFITypes
+  TH.UnliftedNewtypes -> Just UnliftedNewtypes
+  TH.ViewPatterns -> Just ViewPatterns
+#if MIN_VERSION_template_haskell(2,21,0)
+  TH.ExtendedLiterals -> Just ExtendedLiterals
+  TH.TypeAbstractions -> Just TypeAbstractions
+#endif
+#if MIN_VERSION_template_haskell(2,22,0)
+  TH.ListTuplePuns -> Just ListTuplePuns
+  TH.RequiredTypeArguments -> Just RequiredTypeArguments
+#endif
+#if MIN_VERSION_template_haskell(2,23,0)
+  TH.MultilineStrings -> Just MultilineStrings
+  TH.NamedDefaults -> Just NamedDefaults
+  TH.OrPatterns -> Just OrPatterns
+#endif
+  -- Why a catch-all here after going through all the work of listing
+  -- extensions above? Because of two conflicting goals:
+  -- 1 - Not allocate and parse strings, plus run a Map search during compilation (see algo below)
+  -- 2 - Support users compiling hpgsql with newer GHC versions
+  --
+  -- Goal 1 is arguably excessive over-refinement, and goal 2 is arguably
+  -- pointless since it seems like (from my extremely limited experience)
+  -- template-haskell and ghc-lib-parser will change with new releases
+  -- anyway, but not being the annoying library that fails to compile or run
+  -- with some user trying out a new GHC (after bumping version bounds themselves)
+  -- feels important.
+  -- So we achieve a little bit of both goals like this. This is also the reason
+  -- why we have -Wno-overlapping-patterns in this file.
+{- FOURMOLU_DISABLE -}
+  someNewThExtension -> Map.lookup (show someNewThExtension) allGhcLibParserExtensions
+{- FOURMOLU_ENABLE -}
+
+-- | This Map is only useful by assuming the `Show` representations of language extensions in both
+-- ghc-lib-parser and template-haskell match. That feels like a reasonable assumption.
+allGhcLibParserExtensions :: Map String Extension
+allGhcLibParserExtensions = Map.fromList $ map (\ex -> (show ex, ex)) [minBound .. maxBound]

hpgsql/src/Hpgsql/LanguageHaskell/GhcParserOpts.hs

@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -Wno-missing-fields #-}
+
+module Hpgsql.LanguageHaskell.GhcParserOpts (fakeSettings) where
+
+import GHC.Platform (genericPlatform)
+import GHC.Settings
+import GHC.Settings.Config (cProjectVersion)
+import GHC.Utils.Fingerprint (fingerprint0)
+
+-- | Fake GHC 'Settings' with only the fields the parser needs.
+-- All other fields are left undefined; this is why we suppress
+-- the missing-fields warning for this module only.
+fakeSettings :: Settings
+fakeSettings =
+  Settings
+    { sGhcNameVersion = GhcNameVersion "ghc" cProjectVersion,
+      sFileSettings = FileSettings {},
+      sTargetPlatform = genericPlatform,
+      sPlatformMisc = PlatformMisc {},
+      sToolSettings = ToolSettings {toolSettings_opt_P_fingerprint = fingerprint0}
+    }