From 83e6aeb31983dfd594355522faead2e08c480e2d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 28 Jul 2026 13:00:38 -0300 Subject: [PATCH 01/26] Claude written ghc-lib-parser usage --- hpgsql/hpgsql.cabal | 4 +- hpgsql/src/Hpgsql/GhcParseExp.hs | 151 +++++++++++++++++++++++++++ hpgsql/src/Hpgsql/GhcParserOpts.hs | 45 ++++++++ hpgsql/src/Hpgsql/ParsingInternal.hs | 8 +- hpgsql/src/Hpgsql/QueryInternal.hs | 2 +- 5 files changed, 204 insertions(+), 6 deletions(-) create mode 100644 hpgsql/src/Hpgsql/GhcParseExp.hs create mode 100644 hpgsql/src/Hpgsql/GhcParserOpts.hs diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index 87d0379..cd12eef 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -43,6 +43,8 @@ library Hpgsql.Types other-modules: Hpgsql.Base + Hpgsql.GhcParseExp + Hpgsql.GhcParserOpts Hpgsql.Internal Hpgsql.Locking Hpgsql.Msgs @@ -104,7 +106,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, network >= 3.2 && < 3.3, network-uri >= 2.6 && < 2.7, safe-exceptions >= 0.1 && < 0.2, diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs new file mode 100644 index 0000000..6666c69 --- /dev/null +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -0,0 +1,151 @@ +module Hpgsql.GhcParseExp (parseExp, canParseExp) where + +import Data.Char (isUpper) +import GHC.Data.FastString (mkFastString, unpackFS) +import GHC.Data.StringBuffer (stringToStringBuffer) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Hs +import GHC.Parser (parseExpression) +import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState) +import GHC.Parser.PostProcess (ECP (..), runPV) +import GHC.Types.Basic (Boxity (..)) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName (..)) +import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) +import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) +import Hpgsql.GhcParserOpts (parserDynFlags) +import qualified Language.Haskell.TH as TH + +-- | Parse a Haskell expression string into a Template Haskell Exp. +-- Drop-in replacement for Language.Haskell.Meta.Parse.parseExp. +parseExp :: String -> Either String TH.Exp +parseExp str = do + hsExpr <- ghcParse str + convertExpr hsExpr + +-- | Check if a string can be parsed as a Haskell expression. +-- This only checks parsing validity; it does not convert to TH. +canParseExp :: String -> Bool +canParseExp str = case ghcParse str of + Right _ -> True + Left _ -> False + +ghcParse :: String -> Either String (HsExpr GhcPs) +ghcParse str = + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (mkFastString "") 1 1 + opts = initParserOpts parserDynFlags + parseExprP = parseExpression >>= \ecp -> runPV (unECP ecp) + in case unP parseExprP (initParserState opts buf loc) of + POk _ (L _ expr) -> Right expr + PFailed _ -> Left "Failed to parse Haskell expression" + +-- GHC HsExpr to TH Exp conversion + +convertExpr :: HsExpr GhcPs -> Either String TH.Exp +convertExpr (HsVar _ (L _ rdr)) = Right (rdrToExp rdr) +convertExpr (HsApp _ (L _ f) (L _ x)) = TH.AppE <$> convertExpr f <*> convertExpr x +convertExpr (OpApp _ (L _ l) (L _ op) (L _ r)) = do + l' <- convertExpr l + op' <- convertExpr op + r' <- convertExpr r + Right (TH.UInfixE l' op' r') +convertExpr (NegApp _ (L _ e) _) = do + e' <- convertExpr e + Right (TH.AppE (TH.VarE (TH.mkName "negate")) e') +convertExpr (HsPar _ (L _ e)) = + TH.ParensE <$> convertExpr e +convertExpr (ExplicitList _ es) = TH.ListE <$> traverse (\(L _ e) -> convertExpr e) es +convertExpr (ExplicitTuple _ args boxity) = do + args' <- traverse convertTupArg args + Right + ( case boxity of + Boxed -> TH.TupE args' + Unboxed -> TH.UnboxedTupE args' + ) +convertExpr (SectionL _ (L _ e) (L _ op)) = do + e' <- convertExpr e + op' <- convertExpr op + Right (TH.InfixE (Just e') op' Nothing) +convertExpr (SectionR _ (L _ op) (L _ e)) = do + op' <- convertExpr op + e' <- convertExpr e + Right (TH.InfixE Nothing op' (Just e')) +convertExpr (HsIf _ (L _ c) (L _ t) (L _ f)) = do + c' <- convertExpr c + t' <- convertExpr t + f' <- convertExpr f + Right (TH.CondE c' t' f') +convertExpr (HsLit _ lit) = TH.LitE <$> convertHsLit lit +convertExpr (HsOverLit _ ol) = convertOverLit ol +convertExpr (ExprWithTySig _ (L _ e) sigWcTy) = do + e' <- convertExpr e + ty' <- convertSigWcType sigWcTy + Right (TH.SigE e' ty') +convertExpr _ = Left "Unsupported Haskell expression form in SQL quasi-quoter" + +-- Helper functions + +rdrToExp :: RdrName -> TH.Exp +rdrToExp rdr = + let name = rdrToName rdr + in if isConName name then TH.ConE name else TH.VarE name + +rdrToName :: RdrName -> TH.Name +rdrToName (Unqual occ) = TH.mkName (occNameString occ) +rdrToName (Qual modN occ) = TH.mkName (moduleNameString modN ++ "." ++ occNameString occ) +rdrToName _ = TH.mkName "" + +isConName :: TH.Name -> Bool +isConName n = case TH.nameBase n of + (c : _) -> isUpper c || c == ':' + _ -> False + +convertTupArg :: HsTupArg GhcPs -> Either String (Maybe TH.Exp) +convertTupArg (Present _ (L _ e)) = Just <$> convertExpr e +convertTupArg (Missing _) = Right Nothing + +convertHsLit :: HsLit GhcPs -> Either String TH.Lit +convertHsLit (HsChar _ c) = Right (TH.CharL c) +convertHsLit (HsString _ fs) = Right (TH.StringL (unpackFS fs)) +convertHsLit (HsInt _ il) = Right (TH.IntegerL (il_value il)) +convertHsLit (HsIntPrim _ i) = Right (TH.IntPrimL i) +convertHsLit (HsWordPrim _ w) = Right (TH.WordPrimL w) +convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl)) +convertHsLit (HsDoublePrim _ fl) = Right (TH.DoublePrimL (rationalFromFractionalLit fl)) +convertHsLit _ = Left "Unsupported literal type in SQL quasi-quoter" + +convertOverLit :: HsOverLit GhcPs -> Either String TH.Exp +convertOverLit ol = case ol_val ol of + HsIntegral il -> Right (TH.LitE (TH.IntegerL (il_value il))) + HsFractional fl -> Right (TH.LitE (TH.RationalL (rationalFromFractionalLit fl))) + HsIsString _ fs -> Right (TH.LitE (TH.StringL (unpackFS fs))) + +-- Type conversion (GHC HsType to TH Type) + +convertSigWcType :: LHsSigWcType GhcPs -> Either String TH.Type +convertSigWcType (HsWC _ (L _ (HsSig _ _ (L _ ty)))) = convertType ty + +convertType :: HsType GhcPs -> Either String TH.Type +convertType (HsTyVar _ promo (L _ rdr)) = + let name = rdrToName rdr + in Right $ case promo of + IsPromoted -> TH.PromotedT name + NotPromoted + | isConName name -> TH.ConT name + | otherwise -> TH.VarT name +convertType (HsAppTy _ (L _ t1) (L _ t2)) = + TH.AppT <$> convertType t1 <*> convertType t2 +convertType (HsListTy _ (L _ t)) = + TH.AppT TH.ListT <$> convertType t +convertType (HsTupleTy _ _ ts) = do + ts' <- traverse (\(L _ t) -> convertType t) ts + let n = length ts' + Right (foldl TH.AppT (TH.TupleT n) ts') +convertType (HsFunTy _ _ (L _ t1) (L _ t2)) = + TH.AppT . TH.AppT TH.ArrowT <$> convertType t1 <*> convertType t2 +convertType (HsParTy _ (L _ t)) = + convertType t +convertType (HsQualTy _ _ (L _ t)) = + convertType t +convertType _ = Left "Unsupported type in SQL quasi-quoter type signature" diff --git a/hpgsql/src/Hpgsql/GhcParserOpts.hs b/hpgsql/src/Hpgsql/GhcParserOpts.hs new file mode 100644 index 0000000..f37898a --- /dev/null +++ b/hpgsql/src/Hpgsql/GhcParserOpts.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -Wno-missing-fields #-} + +module Hpgsql.GhcParserOpts (parserDynFlags) where + +import GHC.Driver.Session (DynFlags, defaultDynFlags, xopt_set) +import GHC.LanguageExtensions.Type +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} + } + +parserDynFlags :: DynFlags +parserDynFlags = + foldl + xopt_set + (defaultDynFlags fakeSettings) + [ OverloadedStrings, + OverloadedRecordDot, + TupleSections, + LambdaCase, + MultiWayIf, + PostfixOperators, + QuasiQuotes, + UnicodeSyntax, + MagicHash, + ForeignFunctionInterface, + TemplateHaskell, + RankNTypes, + MultiParamTypeClasses, + RecursiveDo, + TypeApplications + ] diff --git a/hpgsql/src/Hpgsql/ParsingInternal.hs b/hpgsql/src/Hpgsql/ParsingInternal.hs index 232ec60..f38866d 100644 --- a/hpgsql/src/Hpgsql/ParsingInternal.hs +++ b/hpgsql/src/Hpgsql/ParsingInternal.hs @@ -36,7 +36,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text -import Language.Haskell.Meta.Parse (parseExp) +import Hpgsql.GhcParseExp (canParseExp) import Prelude hiding (takeWhile) data BlockOrNotBlock = StaticSql !Text | DollarNumberedArg !Int | QuestionMarkArg | QuasiQuoterExpression !QQExprKind !Text | SemiColon | CommentsOrWhitespace !Text @@ -165,9 +165,9 @@ quasiQuoterExpressionParser = do chunk <- takeWhile (/= '}') void $ char '}' let candidate = acc <> chunk - case parseExp (Text.unpack candidate) of - Right _ -> pure candidate - Left _ -> findExpressionEnd (candidate <> "}") + if canParseExp (Text.unpack candidate) + then pure candidate + else findExpressionEnd (candidate <> "}") dollarNumberedQueryArgParser :: Parser BlockOrNotBlock dollarNumberedQueryArgParser = do diff --git a/hpgsql/src/Hpgsql/QueryInternal.hs b/hpgsql/src/Hpgsql/QueryInternal.hs index b721c79..016d04f 100644 --- a/hpgsql/src/Hpgsql/QueryInternal.hs +++ b/hpgsql/src/Hpgsql/QueryInternal.hs @@ -22,7 +22,7 @@ import Hpgsql.Encoding (FieldEncoder (..), RowEncoder (..), ToPgField (..), ToPg import Hpgsql.InternalTypes (Query (..), SingleQuery (..), SingleQueryFragment (..), breakQueryIntoStatements, renumberParamsFrom) import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), QQExprKind (..), blockText, flattenBlocks, parseSql) import Hpgsql.TypeInfo (EncodingContext, Oid) -import Language.Haskell.Meta.Parse (parseExp) +import Hpgsql.GhcParseExp (parseExp) import Language.Haskell.TH import Language.Haskell.TH.Quote From d83d3084b3849018aa8fed406c88cf30a5dc35e0 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 28 Jul 2026 16:58:18 -0300 Subject: [PATCH 02/26] First round of hardening and self-review --- hpgsql-tests/SqlQuasiquoterSpec.hs | 11 +++++++---- hpgsql/src/Hpgsql/GhcParseExp.hs | 21 +++++++++++++++------ 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index 13ba3f8..cf78ef8 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -144,6 +144,10 @@ genMkQuery = pure (mkQuery "SELECT $1, $2, $3, $4, $5;" params, toComparableParams params) ] +data SomeRecord = SomeRecord {field1 :: Int, field2 :: Int} + +newtype SomeGenericRecord a = SomeGenericRecord {field1 :: a} + -- | Queries built with the sql quasiquoter and #{} interpolation. genInterpolatedQuery :: Gen (Query, [(Maybe Oid, BinaryField)]) genInterpolatedQuery = @@ -153,14 +157,13 @@ genInterpolatedQuery = x <- genInt pure ([sql|SELECT #{x};|], toComparableParams (Only x)), do - x <- genInt - y <- genInt - pure ([sql|SELECT #{x}, #{y};|], toComparableParams (x, y)), + x <- SomeRecord <$> genInt <*> genInt + pure ([sql|SELECT #{x.field1}, #{-(x.field2)};|], toComparableParams (x.field1, -(x.field2))), do x <- genInt y <- genInt z <- genInt - pure ([sql|SELECT #{x} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, y, z)) + pure ([sql|SELECT #{x} FROM t WHERE #{y} BETWEEN 0 AND #{(SomeGenericRecord { field1 = z }).field1};|], toComparableParams (x, y, z)) ] -- | Queries built with ^{} embedded queries, including reused placeholders. diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 6666c69..0b1e347 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -1,6 +1,7 @@ module Hpgsql.GhcParseExp (parseExp, canParseExp) where import Data.Char (isUpper) +import Data.Either (isRight) import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer (stringToStringBuffer) import GHC.Driver.Config.Parser (initParserOpts) @@ -14,6 +15,7 @@ import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) import Hpgsql.GhcParserOpts (parserDynFlags) +import Language.Haskell.Syntax.Basic (FieldLabelString (..)) import qualified Language.Haskell.TH as TH -- | Parse a Haskell expression string into a Template Haskell Exp. @@ -26,9 +28,7 @@ parseExp str = do -- | Check if a string can be parsed as a Haskell expression. -- This only checks parsing validity; it does not convert to TH. canParseExp :: String -> Bool -canParseExp str = case ghcParse str of - Right _ -> True - Left _ -> False +canParseExp = isRight . ghcParse ghcParse :: String -> Either String (HsExpr GhcPs) ghcParse str = @@ -52,7 +52,7 @@ convertExpr (OpApp _ (L _ l) (L _ op) (L _ r)) = do Right (TH.UInfixE l' op' r') convertExpr (NegApp _ (L _ e) _) = do e' <- convertExpr e - Right (TH.AppE (TH.VarE (TH.mkName "negate")) e') + Right (TH.AppE (TH.VarE 'negate) e') convertExpr (HsPar _ (L _ e)) = TH.ParensE <$> convertExpr e convertExpr (ExplicitList _ es) = TH.ListE <$> traverse (\(L _ e) -> convertExpr e) es @@ -82,7 +82,12 @@ convertExpr (ExprWithTySig _ (L _ e) sigWcTy) = do e' <- convertExpr e ty' <- convertSigWcType sigWcTy Right (TH.SigE e' ty') -convertExpr _ = Left "Unsupported Haskell expression form in SQL quasi-quoter" +convertExpr (HsGetField _ (L _ e) (L _ (DotFieldOcc _ (L _ fld)))) = do + e' <- convertExpr e + Right (TH.GetFieldE e' (fieldLabelToString fld)) +convertExpr (HsProjection _ flds) = + Right (TH.ProjectionE (fmap (\(DotFieldOcc _ (L _ fld)) -> fieldLabelToString fld) flds)) +convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" -- Helper functions @@ -98,9 +103,13 @@ rdrToName _ = TH.mkName "" isConName :: TH.Name -> Bool isConName n = case TH.nameBase n of + -- TODO: No module name check? (c : _) -> isUpper c || c == ':' _ -> False +fieldLabelToString :: FieldLabelString -> String +fieldLabelToString (FieldLabelString fs) = unpackFS fs + convertTupArg :: HsTupArg GhcPs -> Either String (Maybe TH.Exp) convertTupArg (Present _ (L _ e)) = Just <$> convertExpr e convertTupArg (Missing _) = Right Nothing @@ -111,7 +120,7 @@ convertHsLit (HsString _ fs) = Right (TH.StringL (unpackFS fs)) convertHsLit (HsInt _ il) = Right (TH.IntegerL (il_value il)) convertHsLit (HsIntPrim _ i) = Right (TH.IntPrimL i) convertHsLit (HsWordPrim _ w) = Right (TH.WordPrimL w) -convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl)) +convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl)) -- TODO Why rational? convertHsLit (HsDoublePrim _ fl) = Right (TH.DoublePrimL (rationalFromFractionalLit fl)) convertHsLit _ = Left "Unsupported literal type in SQL quasi-quoter" From 76d8afe1d7b4157dbfa348cf1f1c81391be4504a Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 29 Jul 2026 15:43:47 -0300 Subject: [PATCH 03/26] Another question and an `if` expression --- hpgsql-tests/SqlQuasiquoterSpec.hs | 6 +++--- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 ++ 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index cf78ef8..f7da82b 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -146,7 +146,7 @@ genMkQuery = data SomeRecord = SomeRecord {field1 :: Int, field2 :: Int} -newtype SomeGenericRecord a = SomeGenericRecord {field1 :: a} +-- newtype SomeGenericRecord a = SomeGenericRecord {field1 :: a} -- | Queries built with the sql quasiquoter and #{} interpolation. genInterpolatedQuery :: Gen (Query, [(Maybe Oid, BinaryField)]) @@ -155,7 +155,7 @@ genInterpolatedQuery = [ pure ([sql|SELECT 1, '#{x}', '^{y}';|], []), do x <- genInt - pure ([sql|SELECT #{x};|], toComparableParams (Only x)), + pure ([sql|SELECT #{if True then x else 0};|], toComparableParams (Only x)), do x <- SomeRecord <$> genInt <*> genInt pure ([sql|SELECT #{x.field1}, #{-(x.field2)};|], toComparableParams (x.field1, -(x.field2))), @@ -163,7 +163,7 @@ genInterpolatedQuery = x <- genInt y <- genInt z <- genInt - pure ([sql|SELECT #{x} FROM t WHERE #{y} BETWEEN 0 AND #{(SomeGenericRecord { field1 = z }).field1};|], toComparableParams (x, y, z)) + pure ([sql|SELECT #{x} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, y, z)) ] -- | Queries built with ^{} embedded queries, including reused placeholders. diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 0b1e347..6bf244d 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -18,6 +18,8 @@ import Hpgsql.GhcParserOpts (parserDynFlags) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) import qualified Language.Haskell.TH as TH +-- TODO: How about source locations/lines? Do we need them? + -- | Parse a Haskell expression string into a Template Haskell Exp. -- Drop-in replacement for Language.Haskell.Meta.Parse.parseExp. parseExp :: String -> Either String TH.Exp From 17675d950f0d8e0fa854eec52be237279e2b069d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 29 Jul 2026 15:46:33 -0300 Subject: [PATCH 04/26] Tighten version bounds --- hpgsql/hpgsql.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index cd12eef..18db3c8 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -106,7 +106,7 @@ library crypton >= 1.0.0 && < 1.1, memory >= 0.18.0 && < 0.19, hashable >= 1.5 && < 1.6, - ghc-lib-parser, + ghc-lib-parser >= 9.6 && < 9.14, network >= 3.2 && < 3.3, network-uri >= 2.6 && < 2.7, safe-exceptions >= 0.1 && < 0.2, From 50a95999a1518778e5f0c7476b52f7ad357ad1b1 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 29 Jul 2026 16:47:10 -0300 Subject: [PATCH 05/26] Support GHC 9.8 --- .hlint.yaml | 1 + hpgsql/src/Hpgsql/GhcParseExp.hs | 16 ++++++++++++++-- hpgsql/src/Hpgsql/QueryInternal.hs | 6 ++++-- 3 files changed, 19 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 76dc978..8328b00 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -4,6 +4,7 @@ - arguments: - "--cpp-define=MIN_VERSION_base(a,b,c)=1" + - "--cpp-define=MIN_VERSION_ghc_lib_parser(9,10,0)=1" - "-XQuasiQuotes" - "-XTemplateHaskell" - "-XOverloadedRecordDot" diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 6bf244d..8fd09ca 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} + module Hpgsql.GhcParseExp (parseExp, canParseExp) where import Data.Char (isUpper) @@ -16,7 +19,7 @@ import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) import Hpgsql.GhcParserOpts (parserDynFlags) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) -import qualified Language.Haskell.TH as TH +import qualified "template-haskell" Language.Haskell.TH as TH -- TODO: How about source locations/lines? Do we need them? @@ -54,8 +57,13 @@ convertExpr (OpApp _ (L _ l) (L _ op) (L _ r)) = do Right (TH.UInfixE l' op' r') convertExpr (NegApp _ (L _ e) _) = do e' <- convertExpr e - Right (TH.AppE (TH.VarE 'negate) e') + Right $ TH.AppE (TH.VarE 'negate) e' + +#if MIN_VERSION_ghc_lib_parser(9,10,0) convertExpr (HsPar _ (L _ e)) = +#elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertExpr (HsPar _ _ (L _ e) _) = +#endif TH.ParensE <$> convertExpr e convertExpr (ExplicitList _ es) = TH.ListE <$> traverse (\(L _ e) -> convertExpr e) es convertExpr (ExplicitTuple _ args boxity) = do @@ -88,7 +96,11 @@ convertExpr (HsGetField _ (L _ e) (L _ (DotFieldOcc _ (L _ fld)))) = do e' <- convertExpr e Right (TH.GetFieldE e' (fieldLabelToString fld)) convertExpr (HsProjection _ flds) = +#if MIN_VERSION_ghc_lib_parser(9,10,0) Right (TH.ProjectionE (fmap (\(DotFieldOcc _ (L _ fld)) -> fieldLabelToString fld) flds)) +#elif MIN_VERSION_ghc_lib_parser(9,8,0) + Right (TH.ProjectionE (fmap (\(L _ (DotFieldOcc _ (L _ fld))) -> fieldLabelToString fld) flds)) +#endif convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" -- Helper functions diff --git a/hpgsql/src/Hpgsql/QueryInternal.hs b/hpgsql/src/Hpgsql/QueryInternal.hs index 016d04f..b811692 100644 --- a/hpgsql/src/Hpgsql/QueryInternal.hs +++ b/hpgsql/src/Hpgsql/QueryInternal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + module Hpgsql.QueryInternal ( Query (..), SingleQuery (..), @@ -19,12 +21,12 @@ import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Hpgsql.Builder (BinaryField) import Hpgsql.Encoding (FieldEncoder (..), RowEncoder (..), ToPgField (..), ToPgRow (..)) +import Hpgsql.GhcParseExp (parseExp) import Hpgsql.InternalTypes (Query (..), SingleQuery (..), SingleQueryFragment (..), breakQueryIntoStatements, renumberParamsFrom) import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), QQExprKind (..), blockText, flattenBlocks, parseSql) import Hpgsql.TypeInfo (EncodingContext, Oid) -import Hpgsql.GhcParseExp (parseExp) -import Language.Haskell.TH import Language.Haskell.TH.Quote +import "template-haskell" Language.Haskell.TH -- | A useful representation for our quasiquoter parsing. data SqlFragment From 348810fd9e61c249018edb6e4d8bc25ae927aac7 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 29 Jul 2026 16:59:16 -0300 Subject: [PATCH 06/26] Keep only partial record in module with disabled warning, appease hlint --- hpgsql/src/Hpgsql/GhcParseExp.hs | 36 +++++++++++++++++++++++++----- hpgsql/src/Hpgsql/GhcParserOpts.hs | 26 +-------------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 8fd09ca..607413a 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -8,7 +8,9 @@ import Data.Either (isRight) import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer (stringToStringBuffer) import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Hs +import GHC.Driver.Session (DynFlags, defaultDynFlags, xopt_set) +import GHC.Hs hiding (UnicodeSyntax) +import GHC.LanguageExtensions (Extension (..)) import GHC.Parser (parseExpression) import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState) import GHC.Parser.PostProcess (ECP (..), runPV) @@ -17,7 +19,7 @@ import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) -import Hpgsql.GhcParserOpts (parserDynFlags) +import Hpgsql.GhcParserOpts (fakeSettings) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) import qualified "template-haskell" Language.Haskell.TH as TH @@ -44,6 +46,28 @@ ghcParse str = in case unP parseExprP (initParserState opts buf loc) of POk _ (L _ expr) -> Right expr PFailed _ -> Left "Failed to parse Haskell expression" + where + parserDynFlags :: DynFlags + parserDynFlags = + foldl + xopt_set + (defaultDynFlags fakeSettings) + [ OverloadedStrings, + OverloadedRecordDot, + TupleSections, + LambdaCase, + MultiWayIf, + PostfixOperators, + QuasiQuotes, + UnicodeSyntax, + MagicHash, + ForeignFunctionInterface, + TemplateHaskell, + RankNTypes, + MultiParamTypeClasses, + RecursiveDo, + TypeApplications + ] -- GHC HsExpr to TH Exp conversion @@ -60,11 +84,10 @@ convertExpr (NegApp _ (L _ e) _) = do Right $ TH.AppE (TH.VarE 'negate) e' #if MIN_VERSION_ghc_lib_parser(9,10,0) -convertExpr (HsPar _ (L _ e)) = +convertExpr (HsPar _ (L _ e)) = TH.ParensE <$> convertExpr e #elif MIN_VERSION_ghc_lib_parser(9,8,0) -convertExpr (HsPar _ _ (L _ e) _) = +convertExpr (HsPar _ _ (L _ e) _) = TH.ParensE <$> convertExpr e #endif - TH.ParensE <$> convertExpr e convertExpr (ExplicitList _ es) = TH.ListE <$> traverse (\(L _ e) -> convertExpr e) es convertExpr (ExplicitTuple _ args boxity) = do args' <- traverse convertTupArg args @@ -95,10 +118,11 @@ convertExpr (ExprWithTySig _ (L _ e) sigWcTy) = do convertExpr (HsGetField _ (L _ e) (L _ (DotFieldOcc _ (L _ fld)))) = do e' <- convertExpr e Right (TH.GetFieldE e' (fieldLabelToString fld)) -convertExpr (HsProjection _ flds) = #if MIN_VERSION_ghc_lib_parser(9,10,0) +convertExpr (HsProjection _ flds) = Right (TH.ProjectionE (fmap (\(DotFieldOcc _ (L _ fld)) -> fieldLabelToString fld) flds)) #elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertExpr (HsProjection _ flds) = Right (TH.ProjectionE (fmap (\(L _ (DotFieldOcc _ (L _ fld))) -> fieldLabelToString fld) flds)) #endif convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" diff --git a/hpgsql/src/Hpgsql/GhcParserOpts.hs b/hpgsql/src/Hpgsql/GhcParserOpts.hs index f37898a..90590e7 100644 --- a/hpgsql/src/Hpgsql/GhcParserOpts.hs +++ b/hpgsql/src/Hpgsql/GhcParserOpts.hs @@ -1,9 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-fields #-} -module Hpgsql.GhcParserOpts (parserDynFlags) where +module Hpgsql.GhcParserOpts (fakeSettings) where -import GHC.Driver.Session (DynFlags, defaultDynFlags, xopt_set) -import GHC.LanguageExtensions.Type import GHC.Platform (genericPlatform) import GHC.Settings import GHC.Settings.Config (cProjectVersion) @@ -21,25 +19,3 @@ fakeSettings = sPlatformMisc = PlatformMisc {}, sToolSettings = ToolSettings {toolSettings_opt_P_fingerprint = fingerprint0} } - -parserDynFlags :: DynFlags -parserDynFlags = - foldl - xopt_set - (defaultDynFlags fakeSettings) - [ OverloadedStrings, - OverloadedRecordDot, - TupleSections, - LambdaCase, - MultiWayIf, - PostfixOperators, - QuasiQuotes, - UnicodeSyntax, - MagicHash, - ForeignFunctionInterface, - TemplateHaskell, - RankNTypes, - MultiParamTypeClasses, - RecursiveDo, - TypeApplications - ] From ed16056828541e99935b0890daf9dc4766d13106 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 31 Jul 2026 17:21:52 -0300 Subject: [PATCH 07/26] Use caller's enabled extensions when parsing --- .hlint.yaml | 4 +- hpgsql-tests/ParsingSpec.hs | 8 +- hpgsql/hpgsql.cabal | 1 + hpgsql/src/Hpgsql/GhcParseExp.hs | 40 ++-- .../Hpgsql/LanguageHaskell/FromThExtension.hs | 171 ++++++++++++++++++ hpgsql/src/Hpgsql/ParsingInternal.hs | 15 +- hpgsql/src/Hpgsql/QueryInternal.hs | 25 ++- 7 files changed, 217 insertions(+), 47 deletions(-) create mode 100644 hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs diff --git a/.hlint.yaml b/.hlint.yaml index 8328b00..cf9b903 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -4,7 +4,9 @@ - arguments: - "--cpp-define=MIN_VERSION_base(a,b,c)=1" - - "--cpp-define=MIN_VERSION_ghc_lib_parser(9,10,0)=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" diff --git a/hpgsql-tests/ParsingSpec.hs b/hpgsql-tests/ParsingSpec.hs index 05f46d3..2f72d6d 100644 --- a/hpgsql-tests/ParsingSpec.hs +++ b/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")] diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index 18db3c8..3e7a56e 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -46,6 +46,7 @@ library Hpgsql.GhcParseExp Hpgsql.GhcParserOpts Hpgsql.Internal + Hpgsql.LanguageHaskell.FromThExtension Hpgsql.Locking Hpgsql.Msgs Hpgsql.Networking diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 607413a..aaa9992 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -5,12 +5,13 @@ module Hpgsql.GhcParseExp (parseExp, canParseExp) where import Data.Char (isUpper) import Data.Either (isRight) +import qualified Data.List as List +import Data.Maybe (mapMaybe) import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer (stringToStringBuffer) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Session (DynFlags, defaultDynFlags, xopt_set) import GHC.Hs hiding (UnicodeSyntax) -import GHC.LanguageExtensions (Extension (..)) import GHC.Parser (parseExpression) import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState) import GHC.Parser.PostProcess (ECP (..), runPV) @@ -20,25 +21,24 @@ import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) import Hpgsql.GhcParserOpts (fakeSettings) +import Hpgsql.LanguageHaskell.FromThExtension (fromThToGhcLibExtension) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) import qualified "template-haskell" Language.Haskell.TH as TH -- TODO: How about source locations/lines? Do we need them? -- | Parse a Haskell expression string into a Template Haskell Exp. --- Drop-in replacement for Language.Haskell.Meta.Parse.parseExp. -parseExp :: String -> Either String TH.Exp -parseExp str = do - hsExpr <- ghcParse str +parseExp :: [TH.Extension] -> String -> Either String TH.Exp +parseExp callerExtensions str = do + hsExpr <- ghcParse callerExtensions str convertExpr hsExpr -- | Check if a string can be parsed as a Haskell expression. --- This only checks parsing validity; it does not convert to TH. -canParseExp :: String -> Bool -canParseExp = isRight . ghcParse +canParseExp :: [TH.Extension] -> String -> Bool +canParseExp callerExtensions = isRight . ghcParse callerExtensions -ghcParse :: String -> Either String (HsExpr GhcPs) -ghcParse str = +ghcParse :: [TH.Extension] -> String -> Either String (HsExpr GhcPs) +ghcParse callerExtensions str = let buf = stringToStringBuffer str loc = mkRealSrcLoc (mkFastString "") 1 1 opts = initParserOpts parserDynFlags @@ -49,26 +49,12 @@ ghcParse str = where parserDynFlags :: DynFlags parserDynFlags = - foldl + List.foldl' xopt_set (defaultDynFlags fakeSettings) - [ OverloadedStrings, - OverloadedRecordDot, - TupleSections, - LambdaCase, - MultiWayIf, - PostfixOperators, - QuasiQuotes, - UnicodeSyntax, - MagicHash, - ForeignFunctionInterface, - TemplateHaskell, - RankNTypes, - MultiParamTypeClasses, - RecursiveDo, - TypeApplications - ] + (mapMaybe fromThToGhcLibExtension callerExtensions) +-- -- GHC HsExpr to TH Exp conversion convertExpr :: HsExpr GhcPs -> Either String TH.Exp diff --git a/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs new file mode 100644 index 0000000..981c1d8 --- /dev/null +++ b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +{- FOURMOLU_DISABLE -} +module Hpgsql.LanguageHaskell.FromThExtension where + +import qualified "template-haskell" Language.Haskell.TH as TH +import GHC.LanguageExtensions.Type (Extension (..)) +import Data.Map (Map) +import qualified Data.Map as Map + +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. + someNewThExtension -> Map.lookup (show someNewThExtension) allGhcLibParserExtensions + +allGhcLibParserExtensions :: Map String Extension +allGhcLibParserExtensions = Map.fromList $ map (\ex -> (show ex, ex)) [minBound..maxBound] + + diff --git a/hpgsql/src/Hpgsql/ParsingInternal.hs b/hpgsql/src/Hpgsql/ParsingInternal.hs index f38866d..6e47f5d 100644 --- a/hpgsql/src/Hpgsql/ParsingInternal.hs +++ b/hpgsql/src/Hpgsql/ParsingInternal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + -- | -- -- This module contains parsers that are helpful to separate SQL statements from each other by finding query boundaries: semi-colons, but not when inside a string or a parenthesised expression, for example. @@ -37,6 +39,7 @@ import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text import Hpgsql.GhcParseExp (canParseExp) +import "template-haskell" Language.Haskell.TH (Extension) import Prelude hiding (takeWhile) data BlockOrNotBlock = StaticSql !Text | DollarNumberedArg !Int | QuestionMarkArg | QuasiQuoterExpression !QQExprKind !Text | SemiColon | CommentsOrWhitespace !Text @@ -45,7 +48,7 @@ data BlockOrNotBlock = StaticSql !Text | DollarNumberedArg !Int | QuestionMarkAr data QQExprKind = QQInterpolation | QQEmbeddedQuery deriving stock (Eq, Show) -data ParsingOpts = AcceptQuestionMarksAsQueryArgs | AcceptOnlyDollarNumberedArgs | AcceptQuasiQuoterExpressions +data ParsingOpts = AcceptQuestionMarksAsQueryArgs | AcceptOnlyDollarNumberedArgs | AcceptQuasiQuoterExpressions [Extension] deriving stock (Show) -- | Parses one or more SQL statements (separated by semi-colons). @@ -106,7 +109,7 @@ blockParser popts = -- This seems fragile, but our tests will error out if changes make this unsupported. (: []) <$> ( case popts of - AcceptQuasiQuoterExpressions -> quasiQuoterExpressionParser + AcceptQuasiQuoterExpressions callerExtensions -> quasiQuoterExpressionParser callerExtensions _ -> fail "No quasiquoter expressions" ) <|> (: []) <$> parseStdConformingString @@ -148,12 +151,12 @@ isPossibleBlockStartingChar popts c = || c == '?' || ( case popts of - AcceptQuasiQuoterExpressions -> c == '#' || c == '^' + AcceptQuasiQuoterExpressions _ -> c == '#' || c == '^' _ -> False ) -quasiQuoterExpressionParser :: Parser BlockOrNotBlock -quasiQuoterExpressionParser = do +quasiQuoterExpressionParser :: [Extension] -> Parser BlockOrNotBlock +quasiQuoterExpressionParser callerExtensions = do prefix <- string "#{" <|> string "^{" let kind = if prefix == "#{" then QQInterpolation else QQEmbeddedQuery expr <- findExpressionEnd "" @@ -165,7 +168,7 @@ quasiQuoterExpressionParser = do chunk <- takeWhile (/= '}') void $ char '}' let candidate = acc <> chunk - if canParseExp (Text.unpack candidate) + if canParseExp callerExtensions (Text.unpack candidate) then pure candidate else findExpressionEnd (candidate <> "}") diff --git a/hpgsql/src/Hpgsql/QueryInternal.hs b/hpgsql/src/Hpgsql/QueryInternal.hs index b811692..a4a6477 100644 --- a/hpgsql/src/Hpgsql/QueryInternal.hs +++ b/hpgsql/src/Hpgsql/QueryInternal.hs @@ -26,7 +26,7 @@ import Hpgsql.InternalTypes (Query (..), SingleQuery (..), SingleQueryFragment ( import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), QQExprKind (..), blockText, flattenBlocks, parseSql) import Hpgsql.TypeInfo (EncodingContext, Oid) import Language.Haskell.TH.Quote -import "template-haskell" Language.Haskell.TH +import "template-haskell" Language.Haskell.TH (Exp (..), Q, extsEnabled, integerL, litE, stringL) -- | A useful representation for our quasiquoter parsing. data SqlFragment @@ -130,7 +130,9 @@ mkQueryInternal queryTemplate allParams = sql :: QuasiQuoter sql = QuasiQuoter - { quoteExp = liftQuery False . parseSql AcceptQuasiQuoterExpressions . Text.pack, + { quoteExp = \qqSqlString -> do + exts <- extsEnabled + liftQuery False $ parseSql (AcceptQuasiQuoterExpressions exts) $ Text.pack qqSqlString, quotePat = error "Hpgsql's sql quasiquoter does not implement quotePat", quoteType = error "Hpgsql's sql quasiquoter does not implement quoteType", quoteDec = error "Hpgsql's sql quasiquoter does not implement quoteDec" @@ -141,7 +143,9 @@ sql = sqlPrep :: QuasiQuoter sqlPrep = QuasiQuoter - { quoteExp = liftQuery True . parseSql AcceptQuasiQuoterExpressions . Text.pack, + { quoteExp = \qqSqlString -> do + exts <- extsEnabled + liftQuery True $ parseSql (AcceptQuasiQuoterExpressions exts) $ Text.pack qqSqlString, quotePat = error "Hpgsql's sql quasiquoter does not implement quotePat", quoteType = error "Hpgsql's sql quasiquoter does not implement quoteType", quoteDec = error "Hpgsql's sql quasiquoter does not implement quoteDec" @@ -176,16 +180,18 @@ liftQueryDynamic isPrepared allFragments = do fragmentToPartExp :: SqlFragment -> Q Exp fragmentToPartExp (NonInterpolatedSqlFragment t) = [|StaticSqlPart $(litE (stringL (Text.unpack t)))|] -fragmentToPartExp (InterpolatedHaskellExpr haskellExpr) = - case parseExp (Text.unpack haskellExpr) of +fragmentToPartExp (InterpolatedHaskellExpr haskellExpr) = do + exts <- extsEnabled + case parseExp exts (Text.unpack haskellExpr) of Left err -> error $ "Could not parse Haskell expression '" ++ Text.unpack haskellExpr ++ "': " ++ err Right expr -> [|ParamPart (encodeParam $(pure expr))|] fragmentToPartExp SemiColonFragment = [|SemiColonPart|] fragmentToPartExp (WhitespaceOrCommentsFragment t) = [|WhitespaceOrCommenstPart $(litE (stringL (Text.unpack t)))|] -fragmentToPartExp (EmbeddedQueryExpr haskellExpr) = - case parseExp (Text.unpack haskellExpr) of +fragmentToPartExp (EmbeddedQueryExpr haskellExpr) = do + exts <- extsEnabled + case parseExp exts (Text.unpack haskellExpr) of Left err -> error $ "Could not parse Haskell expression '" ++ Text.unpack haskellExpr ++ "': " ++ err Right expr -> [|EmbeddedQueryPart $(pure expr)|] @@ -251,8 +257,9 @@ parseBlockQuasiQuoter (QuasiQuoterExpression QQEmbeddedQuery expr) = [EmbeddedQu -- | Generate a parameter expression for a captured variable generateParamExp :: Text -> Q Exp -generateParamExp (Text.unpack -> haskellExpr) = - case parseExp haskellExpr of +generateParamExp (Text.unpack -> haskellExpr) = do + exts <- extsEnabled + case parseExp exts haskellExpr of Left err -> error $ "Could not parse Haskell expression '" ++ haskellExpr ++ "': " ++ err Right expr -> [|encodeParam $(pure expr)|] From ac17368fbed29fc3095a5767efc75324e87404ba Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 1 Aug 2026 09:45:34 -0300 Subject: [PATCH 08/26] Support at least one form of TypeApplications in quasiquoters --- hpgsql-tests/SqlQuasiquoterSpec.hs | 8 +++++++- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 ++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index f7da82b..ce73eb5 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -6,6 +6,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Char (isDigit) 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) @@ -148,14 +149,19 @@ data SomeRecord = SomeRecord {field1 :: Int, field2 :: Int} -- newtype SomeGenericRecord a = SomeGenericRecord {field1 :: a} +-- | This exists to test TypeApplications inside quasiquoters. +polyFunc42 :: Proxy a -> Int +polyFunc42 _ = 42 + -- | Queries built with the sql quasiquoter and #{} interpolation. +-- These test a variety of GHC extensions inside quasiquoters. genInterpolatedQuery :: Gen (Query, [(Maybe Oid, BinaryField)]) genInterpolatedQuery = Gen.choice [ pure ([sql|SELECT 1, '#{x}', '^{y}';|], []), do x <- genInt - pure ([sql|SELECT #{if True then x else 0};|], toComparableParams (Only x)), + pure ([sql|SELECT #{if True then x else 0}, #{polyFunc42 (Proxy @String)};|], toComparableParams (x, polyFunc42 (Proxy @String))), do x <- SomeRecord <$> genInt <*> genInt pure ([sql|SELECT #{x.field1}, #{-(x.field2)};|], toComparableParams (x.field1, -(x.field2))), diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index aaa9992..1d8fee7 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -111,6 +111,8 @@ convertExpr (HsProjection _ flds) = convertExpr (HsProjection _ flds) = Right (TH.ProjectionE (fmap (\(L _ (DotFieldOcc _ (L _ fld))) -> fieldLabelToString fld) flds)) #endif +convertExpr (HsAppType _ (L _ e) (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExpr e <*> convertType ty +-- convertExpr (HsAppType _ _ _) = Left "TypeApplications are still unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" -- Helper functions From 97c4516de216a13bc4259c50d1093790eca2b663 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 1 Aug 2026 10:07:30 -0300 Subject: [PATCH 09/26] Support TypeApplications --- hpgsql/src/Hpgsql/GhcParseExp.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 1d8fee7..7e23761 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -111,7 +111,11 @@ convertExpr (HsProjection _ flds) = convertExpr (HsProjection _ flds) = Right (TH.ProjectionE (fmap (\(L _ (DotFieldOcc _ (L _ fld))) -> fieldLabelToString fld) flds)) #endif +#if MIN_VERSION_ghc_lib_parser(9,10,0) convertExpr (HsAppType _ (L _ e) (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExpr e <*> convertType ty +#else +convertExpr (HsAppType _ (L _ e) _ (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExpr e <*> convertType ty +#endif -- convertExpr (HsAppType _ _ _) = Left "TypeApplications are still unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" From 8b7a34202dc56e5d18df03fa192097291b555baa Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 1 Aug 2026 16:33:07 -0300 Subject: [PATCH 10/26] Support record constructors in quasiquotes --- hpgsql-tests/SqlQuasiquoterSpec.hs | 28 +++++++++++++++++++++++----- hpgsql/src/Hpgsql/GhcParseExp.hs | 14 ++++++++++++++ 2 files changed, 37 insertions(+), 5 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index ce73eb5..c0efc2f 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -4,17 +4,20 @@ 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 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) @@ -147,14 +150,26 @@ genMkQuery = data SomeRecord = SomeRecord {field1 :: Int, field2 :: Int} --- newtype SomeGenericRecord a = SomeGenericRecord {field1 :: a} +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 -- | Queries built with the sql quasiquoter and #{} interpolation. --- These test a variety of GHC extensions inside quasiquoters. +-- These test a variety of GHC extensions and language syntax/features +-- inside quasiquoters. genInterpolatedQuery :: Gen (Query, [(Maybe Oid, BinaryField)]) genInterpolatedQuery = Gen.choice @@ -164,12 +179,15 @@ genInterpolatedQuery = pure ([sql|SELECT #{if True then x else 0}, #{polyFunc42 (Proxy @String)};|], toComparableParams (x, polyFunc42 (Proxy @String))), do x <- SomeRecord <$> genInt <*> genInt - pure ([sql|SELECT #{x.field1}, #{-(x.field2)};|], toComparableParams (x.field1, -(x.field2))), + y <- genInt + z <- Gen.bool + pure ([sql|SELECT #{x.field1}, #{-(x.field2)}, #{IntAndBool { ibInt = y, {- Some comment -} ibBool = z }};|], toComparableParams (x.field1, -(x.field2), IntAndBool y z)), 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 #{z};|], toComparableParams (x, e, y, z)) ] -- | Queries built with ^{} embedded queries, including reused placeholders. diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 7e23761..7151332 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -116,6 +116,15 @@ convertExpr (HsAppType _ (L _ e) (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExp #else convertExpr (HsAppType _ (L _ e) _ (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExpr e <*> convertType ty #endif +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertExpr (RecordCon _ (L _ conName) (HsRecFields _ flds _)) = do + flds' <- traverse convertRecField flds + Right $ TH.RecConE (rdrToName conName) flds' +#elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertExpr (RecordCon _ (L _ conName) (HsRecFields flds _)) = do + flds' <- traverse convertRecField flds + Right $ TH.RecConE (rdrToName conName) flds' +#endif -- convertExpr (HsAppType _ _ _) = Left "TypeApplications are still unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" @@ -140,6 +149,11 @@ isConName n = case TH.nameBase n of fieldLabelToString :: FieldLabelString -> String fieldLabelToString (FieldLabelString fs) = unpackFS fs +convertRecField :: LHsRecField GhcPs (LHsExpr GhcPs) -> Either String (TH.Name, TH.Exp) +convertRecField (L _ (HsFieldBind _ (L _ (FieldOcc _ (L _ rdr))) (L _ expr) _)) = do + expr' <- convertExpr expr + Right (rdrToName rdr, expr') + convertTupArg :: HsTupArg GhcPs -> Either String (Maybe TH.Exp) convertTupArg (Present _ (L _ e)) = Just <$> convertExpr e convertTupArg (Missing _) = Right Nothing From aa7e86f44d320691e80ff745ed654cb42e6c2a7b Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 1 Aug 2026 17:11:49 -0300 Subject: [PATCH 11/26] Support `case` expressions --- hpgsql-tests/SqlQuasiquoterSpec.hs | 18 ++++- hpgsql/src/Hpgsql/GhcParseExp.hs | 107 ++++++++++++++++++++++++++++- 2 files changed, 122 insertions(+), 3 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index c0efc2f..40dc412 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -187,7 +187,23 @@ genInterpolatedQuery = y <- genInt z <- genInt e :: SomeGenericEnum <- Gen.enum minBound maxBound - pure ([sql|SELECT #{x}, #{e} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, e, y, z)) + pure ([sql|SELECT #{x}, #{e} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, e, y, z)), + 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"};|], + toComparableParams + ( b, + case compare x 0 of + EQ -> "abc" :: Text + GT -> "cde" + LT -> "xyz" + ) + ) ] -- | Queries built with ^{} embedded queries, including reused placeholders. diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 7151332..42c78ae 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -125,8 +125,111 @@ convertExpr (RecordCon _ (L _ conName) (HsRecFields flds _)) = do flds' <- traverse convertRecField flds Right $ TH.RecConE (rdrToName conName) flds' #endif --- convertExpr (HsAppType _ _ _) = Left "TypeApplications are still unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's SQL quasi-quoter" +convertExpr (HsCase _ (L _ caseExpr) mg) = TH.CaseE <$> convertExpr caseExpr <*> convertMatchGroup mg +convertExpr (HsQual {}) = Left "HsQual is unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsFunArr {}) = Left "Function types are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsForAll {}) = Left "Forall-types are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsUnboundVar {}) = Left "Unbound variables/holes are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +-- convertExpr (HsRecSel {}) = Left "Record field selectors are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsOverLabel {}) = Left "Overloaded labels are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsIPVar {}) = Left "Implicit parameters are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsLam {}) = Left "Lambda expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (ExplicitSum {}) = Left "Unboxed sums are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsMultiIf {}) = Left "Multi-way if expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsLet {}) = Left "Let expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsDo {}) = Left "Do notation is unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (RecordUpd {}) = Left "Record updates are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (ArithSeq {}) = Left "Arithmetic sequences are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsTypedBracket {}) = Left "Typed Template Haskell brackets are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsUntypedBracket {}) = Left "Untyped Template Haskell brackets are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsTypedSplice {}) = Left "Typed Template Haskell splices are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsUntypedSplice {}) = Left "Untyped Template Haskell splices are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsProc {}) = Left "Arrow proc notation is unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsStatic {}) = Left "Static pointers are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsPragE {}) = Left "Pragma expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertExpr (HsEmbTy {}) = Left "Embedded type expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + +-- convertExpr (XExpr _) = Left "Unsupported expression form in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + +convertMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> Either String [TH.Match] +convertMatchGroup (MG _ (L _ matches)) = traverse convertMatch matches + +convertMatch :: LMatch GhcPs (LHsExpr GhcPs) -> Either String TH.Match +convertMatch (L _ (Match _ _ (L _ pats) grhss)) = do + pats' <- traverse (\(L _ p) -> convertPat p) pats + (body, decs) <- convertGRHSs grhss + case pats' of + [pat] -> Right (TH.Match pat body decs) + _ -> Left "Multi-pattern matches are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + +convertGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> Either String (TH.Body, [TH.Dec]) +convertGRHSs (GRHSs _ grhss localBinds) = do + decs <- convertLocalBinds localBinds + body <- case grhss of + [L _ (GRHS _ [] (L _ e))] -> TH.NormalB <$> convertExpr e + _ -> Left "Guarded case alternatives are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + Right (body, decs) + +convertLocalBinds :: HsLocalBinds GhcPs -> Either String [TH.Dec] +convertLocalBinds (EmptyLocalBinds _) = Right [] +convertLocalBinds _ = Left "Where clauses in case expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + +-- Pattern conversion (GHC Pat to TH Pat) + +convertPat :: Pat GhcPs -> Either String TH.Pat +convertPat (WildPat _) = Right TH.WildP +convertPat (VarPat _ (L _ rdr)) = Right (TH.VarP (rdrToName rdr)) +convertPat (LitPat _ lit) = TH.LitP <$> convertHsLit lit +convertPat (NPat _ (L _ ol) _ _) = do + e <- convertOverLit ol + case e of + TH.LitE lit -> Right (TH.LitP lit) + _ -> Left "Unsupported overloaded literal pattern in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertPat (ConPat _ (L _ con) details) = convertConPatDetails con details +#elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertPat (ConPat _ (L _ con) details) = convertConPatDetails con details +#endif +convertPat (TuplePat _ pats boxity) = do + pats' <- traverse (\(L _ p) -> convertPat p) pats + Right $ case boxity of + Boxed -> TH.TupP pats' + Unboxed -> TH.UnboxedTupP pats' +convertPat (ListPat _ pats) = TH.ListP <$> traverse (\(L _ p) -> convertPat p) pats +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertPat (ParPat _ (L _ p)) = TH.ParensP <$> convertPat p +convertPat (AsPat _ (L _ rdr) (L _ p)) = TH.AsP (rdrToName rdr) <$> convertPat p +#elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertPat (ParPat _ _ (L _ p) _) = TH.ParensP <$> convertPat p +convertPat (AsPat _ (L _ rdr) _ (L _ p)) = TH.AsP (rdrToName rdr) <$> convertPat p +#endif +convertPat (BangPat _ (L _ p)) = TH.BangP <$> convertPat p +convertPat _ = Left "Unsupported pattern form in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + +convertConPatDetails :: RdrName -> HsConPatDetails GhcPs -> Either String TH.Pat +convertConPatDetails con (PrefixCon tyArgs args) = do + args' <- traverse (\(L _ p) -> convertPat p) args + if null tyArgs + then Right (TH.ConP (rdrToName con) [] args') + else Left "Type applications in constructor patterns are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertConPatDetails con (InfixCon (L _ l) (L _ r)) = do + l' <- convertPat l + r' <- convertPat r + Right (TH.InfixP l' (rdrToName con) r') +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertConPatDetails con (RecCon (HsRecFields _ flds _)) = do + flds' <- traverse convertPatRecField flds + Right (TH.RecP (rdrToName con) flds') +#elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertConPatDetails con (RecCon (HsRecFields flds _)) = do + flds' <- traverse convertPatRecField flds + Right (TH.RecP (rdrToName con) flds') +#endif + +convertPatRecField :: LHsRecField GhcPs (LPat GhcPs) -> Either String TH.FieldPat +convertPatRecField (L _ (HsFieldBind _ (L _ (FieldOcc _ (L _ rdr))) (L _ pat) _)) = do + pat' <- convertPat pat + Right (rdrToName rdr, pat') -- Helper functions From 2ac5848136463813972676171926befa083f2113 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 1 Aug 2026 17:26:14 -0300 Subject: [PATCH 12/26] No more importing everything from GHC.Hs --- hpgsql/src/Hpgsql/GhcParseExp.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 42c78ae..206f408 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -11,7 +11,7 @@ import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer (stringToStringBuffer) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Session (DynFlags, defaultDynFlags, xopt_set) -import GHC.Hs hiding (UnicodeSyntax) +import GHC.Hs (GhcPs) import GHC.Parser (parseExpression) import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState) import GHC.Parser.PostProcess (ECP (..), runPV) @@ -22,7 +22,10 @@ import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) import Hpgsql.GhcParserOpts (fakeSettings) import Hpgsql.LanguageHaskell.FromThExtension (fromThToGhcLibExtension) +import Language.Haskell.Syntax (FieldOcc (..), GRHS (..), GRHSs (..), HsConDetails (..), HsConPatDetails, HsFieldBind (..), HsLit (..), HsLocalBinds, HsLocalBindsLR (..), HsOverLit (..), HsRecFields (..), HsSigType (..), HsTupArg (..), HsType (..), HsWildCardBndrs (..), LHsExpr, LHsRecField, LHsSigWcType, LMatch, LPat, Match (..), MatchGroup (..), OverLitVal (..), Pat (..), PromotionFlag (..)) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) +import Language.Haskell.Syntax.Expr (DotFieldOcc (..), HsExpr (..)) +import Language.Haskell.Syntax.Module.Name (moduleNameString) import qualified "template-haskell" Language.Haskell.TH as TH -- TODO: How about source locations/lines? Do we need them? From ea6c01572ea1d46c092a6d66277b3ba9a52f38ca Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 1 Aug 2026 17:39:30 -0300 Subject: [PATCH 13/26] Tidy up error messages --- hpgsql/src/Hpgsql/GhcParseExp.hs | 58 +++++++++++++++++++------------- 1 file changed, 35 insertions(+), 23 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 206f408..587c56c 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} +{- FOURMOLU_DISABLE -} module Hpgsql.GhcParseExp (parseExp, canParseExp) where @@ -129,36 +130,47 @@ convertExpr (RecordCon _ (L _ conName) (HsRecFields flds _)) = do Right $ TH.RecConE (rdrToName conName) flds' #endif convertExpr (HsCase _ (L _ caseExpr) mg) = TH.CaseE <$> convertExpr caseExpr <*> convertMatchGroup mg -convertExpr (HsQual {}) = Left "HsQual is unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsFunArr {}) = Left "Function types are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsForAll {}) = Left "Forall-types are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsUnboundVar {}) = Left "Unbound variables/holes are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." --- convertExpr (HsRecSel {}) = Left "Record field selectors are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsOverLabel {}) = Left "Overloaded labels are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsIPVar {}) = Left "Implicit parameters are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsLam {}) = Left "Lambda expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (ExplicitSum {}) = Left "Unboxed sums are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsMultiIf {}) = Left "Multi-way if expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsLet {}) = Left "Let expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsDo {}) = Left "Do notation is unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (RecordUpd {}) = Left "Record updates are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (ArithSeq {}) = Left "Arithmetic sequences are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsTypedBracket {}) = Left "Typed Template Haskell brackets are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsUntypedBracket {}) = Left "Untyped Template Haskell brackets are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsTypedSplice {}) = Left "Typed Template Haskell splices are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsUntypedSplice {}) = Left "Untyped Template Haskell splices are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsProc {}) = Left "Arrow proc notation is unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsStatic {}) = Left "Static pointers are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsPragE {}) = Left "Pragma expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." -convertExpr (HsEmbTy {}) = Left "Embedded type expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." --- convertExpr (XExpr _) = Left "Unsupported expression form in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +-- Now come our list of unsupported language features +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertExpr (HsEmbTy {}) = unsupportedLanguageFeatureMsg "Embedded type expressions are" +convertExpr (HsForAll {}) = unsupportedLanguageFeatureMsg "Forall-types are" +convertExpr (HsFunArr {}) = unsupportedLanguageFeatureMsg "Function types are" +convertExpr (HsQual {}) = unsupportedLanguageFeatureMsg "HsQual is" +#else +convertExpr (HsLamCase {}) = unsupportedLanguageFeatureMsg "Lambda expressions are" +convertExpr (HsRecSel {}) = unsupportedLanguageFeatureMsg "Record field selectors are" +#endif +convertExpr (HsUnboundVar {}) = unsupportedLanguageFeatureMsg "Unbound variables/holes are" +convertExpr (HsOverLabel {}) = unsupportedLanguageFeatureMsg "Overloaded labels are" +convertExpr (HsIPVar {}) = unsupportedLanguageFeatureMsg "Implicit parameters are" +convertExpr (HsLam {}) = unsupportedLanguageFeatureMsg "Lambda expressions are" +convertExpr (ExplicitSum {}) = unsupportedLanguageFeatureMsg "Unboxed sums are" +convertExpr (HsMultiIf {}) = unsupportedLanguageFeatureMsg "Multi-way if expressions are" +convertExpr (HsLet {}) = unsupportedLanguageFeatureMsg "Let expressions are" +convertExpr (HsDo {}) = unsupportedLanguageFeatureMsg "Do notation is" +convertExpr (RecordUpd {}) = unsupportedLanguageFeatureMsg "Record updates are" +convertExpr (ArithSeq {}) = unsupportedLanguageFeatureMsg "Arithmetic sequences are" +convertExpr (HsTypedBracket {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell brackets are" +convertExpr (HsUntypedBracket {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell brackets are" +convertExpr (HsTypedSplice {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell splices are" +convertExpr (HsUntypedSplice {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell splices are" +convertExpr (HsProc {}) = unsupportedLanguageFeatureMsg "Arrow proc notation is" +convertExpr (HsStatic {}) = unsupportedLanguageFeatureMsg "Static pointers are" +convertExpr (HsPragE {}) = unsupportedLanguageFeatureMsg "Pragma expressions are" + +unsupportedLanguageFeatureMsg :: String -> Either String a +unsupportedLanguageFeatureMsg feat = Left $ feat ++ " unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." convertMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> Either String [TH.Match] convertMatchGroup (MG _ (L _ matches)) = traverse convertMatch matches convertMatch :: LMatch GhcPs (LHsExpr GhcPs) -> Either String TH.Match +#if MIN_VERSION_ghc_lib_parser(9,10,0) convertMatch (L _ (Match _ _ (L _ pats) grhss)) = do +#else +convertMatch (L _ (Match _ _ pats grhss)) = do +#endif pats' <- traverse (\(L _ p) -> convertPat p) pats (body, decs) <- convertGRHSs grhss case pats' of From 8d147184aac260827fa93f6c9ad4f4a23f06aa77 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 2 Aug 2026 09:08:01 -0300 Subject: [PATCH 14/26] Document assumption on `Show` instances --- hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs index 981c1d8..c3fcf8a 100644 --- a/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs +++ b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs @@ -165,6 +165,8 @@ fromThToGhcLibExtension = \case -- why we have -Wno-overlapping-patterns in this file. someNewThExtension -> Map.lookup (show someNewThExtension) allGhcLibParserExtensions +-- | 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] From ef4a04312252abc06fb618fc533ba1acdfa88743 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 2 Aug 2026 09:13:44 -0300 Subject: [PATCH 15/26] Notes on fourmolu and CPP macros --- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 +- hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 587c56c..2c57dd4 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} -{- FOURMOLU_DISABLE -} +{- FOURMOLU_DISABLE -} -- CPP macros make fourmolu fail module Hpgsql.GhcParseExp (parseExp, canParseExp) where diff --git a/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs index c3fcf8a..ab658c2 100644 --- a/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs +++ b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-overlapping-patterns #-} -{- FOURMOLU_DISABLE -} + module Hpgsql.LanguageHaskell.FromThExtension where -import qualified "template-haskell" Language.Haskell.TH as TH -import GHC.LanguageExtensions.Type (Extension (..)) 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 @@ -163,11 +163,11 @@ fromThToGhcLibExtension = \case -- 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] - - +allGhcLibParserExtensions = Map.fromList $ map (\ex -> (show ex, ex)) [minBound .. maxBound] From bd0472d269c9bf89e580ddacc183a5e322e4b854 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 2 Aug 2026 09:23:39 -0300 Subject: [PATCH 16/26] "____ expressions" in error message --- hpgsql/src/Hpgsql/GhcParseExp.hs | 48 ++++++++++++++++---------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 2c57dd4..f192b66 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -133,34 +133,34 @@ convertExpr (HsCase _ (L _ caseExpr) mg) = TH.CaseE <$> convertExpr caseExpr <*> -- Now come our list of unsupported language features #if MIN_VERSION_ghc_lib_parser(9,10,0) -convertExpr (HsEmbTy {}) = unsupportedLanguageFeatureMsg "Embedded type expressions are" -convertExpr (HsForAll {}) = unsupportedLanguageFeatureMsg "Forall-types are" -convertExpr (HsFunArr {}) = unsupportedLanguageFeatureMsg "Function types are" -convertExpr (HsQual {}) = unsupportedLanguageFeatureMsg "HsQual is" +convertExpr (HsEmbTy {}) = unsupportedLanguageFeatureMsg "Embedded type" +convertExpr (HsForAll {}) = unsupportedLanguageFeatureMsg "Forall-types" +convertExpr (HsFunArr {}) = unsupportedLanguageFeatureMsg "Function types" +convertExpr (HsQual {}) = unsupportedLanguageFeatureMsg "HsQual" #else -convertExpr (HsLamCase {}) = unsupportedLanguageFeatureMsg "Lambda expressions are" -convertExpr (HsRecSel {}) = unsupportedLanguageFeatureMsg "Record field selectors are" +convertExpr (HsLamCase {}) = unsupportedLanguageFeatureMsg "LambdaCase" +convertExpr (HsRecSel {}) = unsupportedLanguageFeatureMsg "Record field selectors" #endif -convertExpr (HsUnboundVar {}) = unsupportedLanguageFeatureMsg "Unbound variables/holes are" -convertExpr (HsOverLabel {}) = unsupportedLanguageFeatureMsg "Overloaded labels are" -convertExpr (HsIPVar {}) = unsupportedLanguageFeatureMsg "Implicit parameters are" -convertExpr (HsLam {}) = unsupportedLanguageFeatureMsg "Lambda expressions are" -convertExpr (ExplicitSum {}) = unsupportedLanguageFeatureMsg "Unboxed sums are" -convertExpr (HsMultiIf {}) = unsupportedLanguageFeatureMsg "Multi-way if expressions are" -convertExpr (HsLet {}) = unsupportedLanguageFeatureMsg "Let expressions are" -convertExpr (HsDo {}) = unsupportedLanguageFeatureMsg "Do notation is" -convertExpr (RecordUpd {}) = unsupportedLanguageFeatureMsg "Record updates are" -convertExpr (ArithSeq {}) = unsupportedLanguageFeatureMsg "Arithmetic sequences are" -convertExpr (HsTypedBracket {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell brackets are" -convertExpr (HsUntypedBracket {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell brackets are" -convertExpr (HsTypedSplice {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell splices are" -convertExpr (HsUntypedSplice {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell splices are" -convertExpr (HsProc {}) = unsupportedLanguageFeatureMsg "Arrow proc notation is" -convertExpr (HsStatic {}) = unsupportedLanguageFeatureMsg "Static pointers are" -convertExpr (HsPragE {}) = unsupportedLanguageFeatureMsg "Pragma expressions are" +convertExpr (HsUnboundVar {}) = unsupportedLanguageFeatureMsg "Unbound variables/holes" +convertExpr (HsOverLabel {}) = unsupportedLanguageFeatureMsg "Overloaded labels" +convertExpr (HsIPVar {}) = unsupportedLanguageFeatureMsg "Implicit parameters" +convertExpr (HsLam {}) = unsupportedLanguageFeatureMsg "Lambda" +convertExpr (ExplicitSum {}) = unsupportedLanguageFeatureMsg "Unboxed sums" +convertExpr (HsMultiIf {}) = unsupportedLanguageFeatureMsg "Multi-way if" +convertExpr (HsLet {}) = unsupportedLanguageFeatureMsg "Let" +convertExpr (HsDo {}) = unsupportedLanguageFeatureMsg "Do notation" +convertExpr (RecordUpd {}) = unsupportedLanguageFeatureMsg "Record updates" +convertExpr (ArithSeq {}) = unsupportedLanguageFeatureMsg "Arithmetic sequences" +convertExpr (HsTypedBracket {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell brackets" +convertExpr (HsUntypedBracket {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell brackets" +convertExpr (HsTypedSplice {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell splices" +convertExpr (HsUntypedSplice {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell splices" +convertExpr (HsProc {}) = unsupportedLanguageFeatureMsg "Arrow proc notation" +convertExpr (HsStatic {}) = unsupportedLanguageFeatureMsg "Static pointers" +convertExpr (HsPragE {}) = unsupportedLanguageFeatureMsg "Pragma" unsupportedLanguageFeatureMsg :: String -> Either String a -unsupportedLanguageFeatureMsg feat = Left $ feat ++ " unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +unsupportedLanguageFeatureMsg feat = Left $ feat ++ " expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." convertMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> Either String [TH.Match] convertMatchGroup (MG _ (L _ matches)) = traverse convertMatch matches From f20437acff633caf90dc79ad1c6c724e47705aed Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 2 Aug 2026 09:44:05 -0300 Subject: [PATCH 17/26] Less wildcard pattern matching --- hpgsql-tests/SqlQuasiquoterSpec.hs | 19 +++++--- hpgsql/src/Hpgsql/GhcParseExp.hs | 73 +++++++++++++++++++++++------- 2 files changed, 69 insertions(+), 23 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index 40dc412..78040bf 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -12,6 +12,7 @@ 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 @@ -167,6 +168,9 @@ instance ToPgField IntAndBool where 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. @@ -176,30 +180,33 @@ genInterpolatedQuery = [ pure ([sql|SELECT 1, '#{x}', '^{y}';|], []), do x <- genInt - pure ([sql|SELECT #{if True then x else 0}, #{polyFunc42 (Proxy @String)};|], toComparableParams (x, polyFunc42 (Proxy @String))), + 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 <- SomeRecord <$> genInt <*> genInt y <- genInt z <- Gen.bool - pure ([sql|SELECT #{x.field1}, #{-(x.field2)}, #{IntAndBool { ibInt = y, {- Some comment -} ibBool = z }};|], toComparableParams (x.field1, -(x.field2), IntAndBool y z)), + 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 e :: SomeGenericEnum <- Gen.enum minBound maxBound - pure ([sql|SELECT #{x}, #{e} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, e, y, z)), + 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 + !EQ -> "abc"::Text GT -> "cde" - LT -> "xyz"};|], + LT -> "xyz" + _ -> error "Impossible"};|], toComparableParams ( b, case compare x 0 of - EQ -> "abc" :: Text + !EQ -> "abc" :: Text GT -> "cde" LT -> "xyz" ) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index f192b66..d2fb93e 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -17,6 +17,7 @@ import GHC.Parser (parseExpression) import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState) import GHC.Parser.PostProcess (ECP (..), runPV) import GHC.Types.Basic (Boxity (..)) +import GHC.Types.Name (nameOccName) import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) @@ -100,7 +101,7 @@ convertExpr (HsIf _ (L _ c) (L _ t) (L _ f)) = do f' <- convertExpr f Right (TH.CondE c' t' f') convertExpr (HsLit _ lit) = TH.LitE <$> convertHsLit lit -convertExpr (HsOverLit _ ol) = convertOverLit ol +convertExpr (HsOverLit _ ol) = TH.LitE <$> convertOverLit ol convertExpr (ExprWithTySig _ (L _ e) sigWcTy) = do e' <- convertExpr e ty' <- convertSigWcType sigWcTy @@ -175,19 +176,20 @@ convertMatch (L _ (Match _ _ pats grhss)) = do (body, decs) <- convertGRHSs grhss case pats' of [pat] -> Right (TH.Match pat body decs) - _ -> Left "Multi-pattern matches are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + _ -> unsupportedLanguageFeatureMsg "Multi-pattern matches" convertGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> Either String (TH.Body, [TH.Dec]) convertGRHSs (GRHSs _ grhss localBinds) = do decs <- convertLocalBinds localBinds body <- case grhss of [L _ (GRHS _ [] (L _ e))] -> TH.NormalB <$> convertExpr e - _ -> Left "Guarded case alternatives are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + _ -> unsupportedLanguageFeatureMsg "Guarded case alternative" Right (body, decs) convertLocalBinds :: HsLocalBinds GhcPs -> Either String [TH.Dec] convertLocalBinds (EmptyLocalBinds _) = Right [] -convertLocalBinds _ = Left "Where clauses in case expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertLocalBinds (HsValBinds {}) = unsupportedLanguageFeatureMsg "HsValBinds" +convertLocalBinds (HsIPBinds {}) = unsupportedLanguageFeatureMsg "HsIPBinds" -- Pattern conversion (GHC Pat to TH Pat) @@ -195,11 +197,7 @@ convertPat :: Pat GhcPs -> Either String TH.Pat convertPat (WildPat _) = Right TH.WildP convertPat (VarPat _ (L _ rdr)) = Right (TH.VarP (rdrToName rdr)) convertPat (LitPat _ lit) = TH.LitP <$> convertHsLit lit -convertPat (NPat _ (L _ ol) _ _) = do - e <- convertOverLit ol - case e of - TH.LitE lit -> Right (TH.LitP lit) - _ -> Left "Unsupported overloaded literal pattern in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +convertPat (NPat _ (L _ ol) _ _) = TH.LitP <$> convertOverLit ol #if MIN_VERSION_ghc_lib_parser(9,10,0) convertPat (ConPat _ (L _ con) details) = convertConPatDetails con details #elif MIN_VERSION_ghc_lib_parser(9,8,0) @@ -219,7 +217,18 @@ convertPat (ParPat _ _ (L _ p) _) = TH.ParensP <$> convertPat p convertPat (AsPat _ (L _ rdr) _ (L _ p)) = TH.AsP (rdrToName rdr) <$> convertPat p #endif convertPat (BangPat _ (L _ p)) = TH.BangP <$> convertPat p -convertPat _ = Left "Unsupported pattern form in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +-- Unsupported pattern matching expressions +convertPat (LazyPat{}) = unsupportedLanguageFeatureMsg "LazyPat in pattern matching" +convertPat (ViewPat{}) = unsupportedLanguageFeatureMsg "ViewPat in pattern matching" +convertPat (SumPat{}) = unsupportedLanguageFeatureMsg "SumPat in pattern matching" +convertPat (SplicePat{}) = unsupportedLanguageFeatureMsg "SplicePat in pattern matching" +convertPat (SigPat{}) = unsupportedLanguageFeatureMsg "SigPat in pattern matching" +convertPat (NPlusKPat{}) = unsupportedLanguageFeatureMsg "NPlusKPat in pattern matching" +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertPat (EmbTyPat{}) = unsupportedLanguageFeatureMsg "EmbTyPat in pattern matching" +convertPat (InvisPat{}) = unsupportedLanguageFeatureMsg "InvisPat in pattern matching" +convertPat (OrPat{}) = unsupportedLanguageFeatureMsg "OrPat in pattern matching" +#endif convertConPatDetails :: RdrName -> HsConPatDetails GhcPs -> Either String TH.Pat convertConPatDetails con (PrefixCon tyArgs args) = do @@ -256,7 +265,8 @@ rdrToExp rdr = rdrToName :: RdrName -> TH.Name rdrToName (Unqual occ) = TH.mkName (occNameString occ) rdrToName (Qual modN occ) = TH.mkName (moduleNameString modN ++ "." ++ occNameString occ) -rdrToName _ = TH.mkName "" +rdrToName (Orig _ occ) = TH.mkName (occNameString occ) +rdrToName (Exact name) = TH.mkName (occNameString (nameOccName name)) isConName :: TH.Name -> Bool isConName n = case TH.nameBase n of @@ -284,13 +294,27 @@ convertHsLit (HsIntPrim _ i) = Right (TH.IntPrimL i) convertHsLit (HsWordPrim _ w) = Right (TH.WordPrimL w) convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl)) -- TODO Why rational? convertHsLit (HsDoublePrim _ fl) = Right (TH.DoublePrimL (rationalFromFractionalLit fl)) -convertHsLit _ = Left "Unsupported literal type in SQL quasi-quoter" +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertHsLit (HsMultilineString _ fs) = Right (TH.StringL (unpackFS fs)) +#endif +convertHsLit (HsCharPrim {}) = unsupportedLanguageFeatureMsg "HsCharPrim literal" +convertHsLit (HsStringPrim {}) = unsupportedLanguageFeatureMsg "HsStringPrim literal" +convertHsLit (HsInt8Prim {}) = unsupportedLanguageFeatureMsg "HsInt8Prim literal" +convertHsLit (HsInt16Prim {}) = unsupportedLanguageFeatureMsg "HsInt16Prim literal" +convertHsLit (HsInt32Prim {}) = unsupportedLanguageFeatureMsg "HsInt32Prim literal" +convertHsLit (HsInt64Prim {}) = unsupportedLanguageFeatureMsg "HsInt64Prim literal" +convertHsLit (HsWord8Prim {}) = unsupportedLanguageFeatureMsg "HsWord8Prim literal" +convertHsLit (HsWord16Prim {}) = unsupportedLanguageFeatureMsg "HsWord16Prim literal" +convertHsLit (HsWord32Prim {}) = unsupportedLanguageFeatureMsg "HsWord32Prim literal" +convertHsLit (HsWord64Prim {}) = unsupportedLanguageFeatureMsg "HsWord64Prim literal" +convertHsLit (HsInteger {}) = unsupportedLanguageFeatureMsg "HsInteger literal" +convertHsLit (HsRat {}) = unsupportedLanguageFeatureMsg "HsRat literal" -convertOverLit :: HsOverLit GhcPs -> Either String TH.Exp +convertOverLit :: HsOverLit GhcPs -> Either String TH.Lit convertOverLit ol = case ol_val ol of - HsIntegral il -> Right (TH.LitE (TH.IntegerL (il_value il))) - HsFractional fl -> Right (TH.LitE (TH.RationalL (rationalFromFractionalLit fl))) - HsIsString _ fs -> Right (TH.LitE (TH.StringL (unpackFS fs))) + HsIntegral il -> Right (TH.IntegerL (il_value il)) + HsFractional fl -> Right (TH.RationalL (rationalFromFractionalLit fl)) + HsIsString _ fs -> Right (TH.StringL (unpackFS fs)) -- Type conversion (GHC HsType to TH Type) @@ -319,4 +343,19 @@ convertType (HsParTy _ (L _ t)) = convertType t convertType (HsQualTy _ _ (L _ t)) = convertType t -convertType _ = Left "Unsupported type in SQL quasi-quoter type signature" +convertType (HsForAllTy{}) = unsupportedLanguageFeatureMsg "HsForAllTy in a type" +convertType (HsAppKindTy{}) = unsupportedLanguageFeatureMsg "HsAppKindTy in a type" +convertType (HsOpTy{}) = unsupportedLanguageFeatureMsg "HsOpTy in a type" +convertType (HsSumTy{}) = unsupportedLanguageFeatureMsg "HsSumTy in a type" +convertType (HsIParamTy{}) = unsupportedLanguageFeatureMsg "HsIParamTy in a type" +convertType (HsStarTy{}) = unsupportedLanguageFeatureMsg "HsStarTy in a type" +convertType (HsKindSig{}) = unsupportedLanguageFeatureMsg "HsKindSig in a type" +convertType (HsSpliceTy{}) = unsupportedLanguageFeatureMsg "HsSpliceTy in a type" +convertType (HsDocTy{}) = unsupportedLanguageFeatureMsg "HsDocTy in a type" +convertType (HsBangTy{}) = unsupportedLanguageFeatureMsg "HsBangTy in a type" +convertType (HsRecTy{}) = unsupportedLanguageFeatureMsg "HsRecTy in a type" +convertType (HsExplicitListTy{}) = unsupportedLanguageFeatureMsg "HsExplicitListTy in a type" +convertType (HsExplicitTupleTy{}) = unsupportedLanguageFeatureMsg "HsExplicitTupleTy in a type" +convertType (HsTyLit{}) = unsupportedLanguageFeatureMsg "HsTyLit in a type" +convertType (HsWildCardTy{}) = unsupportedLanguageFeatureMsg "HsWildCardTy in a type" +convertType (XHsType{}) = unsupportedLanguageFeatureMsg "XHsType in a type" From e605c923a608d261a1b3f57e9b906e9d36a5c3e6 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 2 Aug 2026 10:14:06 -0300 Subject: [PATCH 18/26] Remove TODO on constructor name This is just Haskell syntax for data constructors checking the first character. I understand it now. --- hpgsql/src/Hpgsql/GhcParseExp.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index d2fb93e..7b61155 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -260,7 +260,7 @@ convertPatRecField (L _ (HsFieldBind _ (L _ (FieldOcc _ (L _ rdr))) (L _ pat) _) rdrToExp :: RdrName -> TH.Exp rdrToExp rdr = let name = rdrToName rdr - in if isConName name then TH.ConE name else TH.VarE name + in if isConstructorName name then TH.ConE name else TH.VarE name rdrToName :: RdrName -> TH.Name rdrToName (Unqual occ) = TH.mkName (occNameString occ) @@ -268,9 +268,8 @@ rdrToName (Qual modN occ) = TH.mkName (moduleNameString modN ++ "." ++ occNameSt rdrToName (Orig _ occ) = TH.mkName (occNameString occ) rdrToName (Exact name) = TH.mkName (occNameString (nameOccName name)) -isConName :: TH.Name -> Bool -isConName n = case TH.nameBase n of - -- TODO: No module name check? +isConstructorName :: TH.Name -> Bool +isConstructorName n = case TH.nameBase n of (c : _) -> isUpper c || c == ':' _ -> False @@ -327,7 +326,7 @@ convertType (HsTyVar _ promo (L _ rdr)) = in Right $ case promo of IsPromoted -> TH.PromotedT name NotPromoted - | isConName name -> TH.ConT name + | isConstructorName name -> TH.ConT name | otherwise -> TH.VarT name convertType (HsAppTy _ (L _ t1) (L _ t2)) = TH.AppT <$> convertType t1 <*> convertType t2 From 23a67bf3ed16898958777891e53798e572632cb7 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 4 Aug 2026 18:00:12 -0300 Subject: [PATCH 19/26] Improve error message for unsupported language features --- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 7b61155..89b8b52 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -161,7 +161,7 @@ convertExpr (HsStatic {}) = unsupportedLanguageFeatureMsg "Static pointers" convertExpr (HsPragE {}) = unsupportedLanguageFeatureMsg "Pragma" unsupportedLanguageFeatureMsg :: String -> Either String a -unsupportedLanguageFeatureMsg feat = Left $ feat ++ " expressions are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." +unsupportedLanguageFeatureMsg feat = Left $ feat ++ " expressions are unsupported in hpgsql's SQL quasi-quoter. You can usually assign your expression to a binding outside the quasi-quoter and keep only that binding inside, but do raise an issue at https://github.com/mzabani/hpgsql/issues if you want this to be supported." convertMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> Either String [TH.Match] convertMatchGroup (MG _ (L _ matches)) = traverse convertMatch matches From 18949b8942c8d00e3c9992f4feb48a7def478d28 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 4 Aug 2026 18:01:56 -0300 Subject: [PATCH 20/26] Remove TODO about rationals These are literal numbers, so they're numbers as per the source code, which of course are well described by rationals. --- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 89b8b52..85b7cc6 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -291,7 +291,7 @@ convertHsLit (HsString _ fs) = Right (TH.StringL (unpackFS fs)) convertHsLit (HsInt _ il) = Right (TH.IntegerL (il_value il)) convertHsLit (HsIntPrim _ i) = Right (TH.IntPrimL i) convertHsLit (HsWordPrim _ w) = Right (TH.WordPrimL w) -convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl)) -- TODO Why rational? +convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl)) convertHsLit (HsDoublePrim _ fl) = Right (TH.DoublePrimL (rationalFromFractionalLit fl)) #if MIN_VERSION_ghc_lib_parser(9,10,0) convertHsLit (HsMultilineString _ fs) = Right (TH.StringL (unpackFS fs)) From ebd982cdd45c65f34f690f9b73ed57a244943bec Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 6 Aug 2026 19:31:04 -0300 Subject: [PATCH 21/26] Dangerous example? Not so much This shows how the quasi-quoter, when unable to parse a Haskell expression, treats it like a fragment of SQL. This was scary at first, but is actually fine, as valid SQL will never have #{ or ^{ inside not a string or an identifier. It's not great that this happens, but I'm not sure there's anything we can do other than detecting invalid but reasonably-Haskell-looking expressions an err on them? Best not to do anything --- hpgsql-tests/SqlQuasiquoterSpec.hs | 9 +++++++-- hpgsql/src/Hpgsql/ParsingInternal.hs | 1 + 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index 78040bf..daf563f 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -198,13 +198,18 @@ genInterpolatedQuery = x <- genInt b <- Gen.bool pure - ( [sql|SELECT #{fst <$> Just (b, False)}, #{case compare x 0 of + ( [sql|SELECT 42+#{let y = x + 1 + z = y - 7 + in z*9}, #{fst <$> Just (b, False)}, #{case compare x 0 of !EQ -> "abc"::Text GT -> "cde" LT -> "xyz" _ -> error "Impossible"};|], toComparableParams - ( b, + ( let y = x + 1 + z = y - 7 + in z*9, + fst <$> Just (b, False), case compare x 0 of !EQ -> "abc" :: Text GT -> "cde" diff --git a/hpgsql/src/Hpgsql/ParsingInternal.hs b/hpgsql/src/Hpgsql/ParsingInternal.hs index 6e47f5d..3f66e8b 100644 --- a/hpgsql/src/Hpgsql/ParsingInternal.hs +++ b/hpgsql/src/Hpgsql/ParsingInternal.hs @@ -3,6 +3,7 @@ -- | -- -- This module contains parsers that are helpful to separate SQL statements from each other by finding query boundaries: semi-colons, but not when inside a string or a parenthesised expression, for example. +-- It also parses SQL inside quasi-quoters with the typical #{} and ^{} Haskell expressions. module Hpgsql.ParsingInternal ( parseSql, BlockOrNotBlock (..), From 6718de40294daf8a9df872e906b7b16d60e163d6 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 7 Aug 2026 17:00:54 -0300 Subject: [PATCH 22/26] Make an important distinction clear --- hpgsql-tests/SqlQuasiquoterSpec.hs | 8 ++------ hpgsql/src/Hpgsql/GhcParseExp.hs | 15 ++++++++++++--- hpgsql/src/Hpgsql/ParsingInternal.hs | 8 ++++---- 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/hpgsql-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index daf563f..763fd13 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -198,17 +198,13 @@ genInterpolatedQuery = x <- genInt b <- Gen.bool pure - ( [sql|SELECT 42+#{let y = x + 1 - z = y - 7 - in z*9}, #{fst <$> Just (b, False)}, #{case compare x 0 of + ( [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 - z = y - 7 - in z*9, + ( let y = x + 1 in y * 9, fst <$> Just (b, False), case compare x 0 of !EQ -> "abc" :: Text diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 85b7cc6..7e74cd6 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -2,7 +2,7 @@ {-# LANGUAGE PackageImports #-} {- FOURMOLU_DISABLE -} -- CPP macros make fourmolu fail -module Hpgsql.GhcParseExp (parseExp, canParseExp) where +module Hpgsql.GhcParseExp (parseExp, isValidHaskellExpression) where import Data.Char (isUpper) import Data.Either (isRight) @@ -39,8 +39,17 @@ parseExp callerExtensions str = do convertExpr hsExpr -- | Check if a string can be parsed as a Haskell expression. -canParseExp :: [TH.Extension] -> String -> Bool -canParseExp callerExtensions = isRight . ghcParse callerExtensions +isValidHaskellExpression :: [TH.Extension] -> String -> Bool +-- NOTE: This uses `ghcParse` instead of `parseExp` on purpose. +-- The reasoning is if we find a valid Haskell expression inside +-- a quasiquoter, we want to parse it as a Haskell expression. +-- If later on we don't support converting that to template-haskell, +-- that's hpgsql's limitation and we want a good error to be thrown +-- to the user, which `parseExp` will do. +-- And we don't want to mislead our quasiquoter parser into skipping +-- a valid Haskell expression inside #{} or ^{} just because hpgsql +-- can't convert it to TH: best to fail loud and clear. +isValidHaskellExpression callerExtensions = isRight . ghcParse callerExtensions ghcParse :: [TH.Extension] -> String -> Either String (HsExpr GhcPs) ghcParse callerExtensions str = diff --git a/hpgsql/src/Hpgsql/ParsingInternal.hs b/hpgsql/src/Hpgsql/ParsingInternal.hs index 3f66e8b..332dc50 100644 --- a/hpgsql/src/Hpgsql/ParsingInternal.hs +++ b/hpgsql/src/Hpgsql/ParsingInternal.hs @@ -39,7 +39,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text -import Hpgsql.GhcParseExp (canParseExp) +import Hpgsql.GhcParseExp (isValidHaskellExpression) import "template-haskell" Language.Haskell.TH (Extension) import Prelude hiding (takeWhile) @@ -163,13 +163,13 @@ quasiQuoterExpressionParser callerExtensions = do expr <- findExpressionEnd "" pure $ QuasiQuoterExpression kind expr where - -- Scan for '}' left-to-right, trying parseExp at each one. - -- The first '}' where parseExp succeeds is the expression boundary. + -- Scan for '}' left-to-right, trying isValidHaskellExpression at each one. + -- The first '}' where isValidHaskellExpression succeeds is the expression boundary. findExpressionEnd acc = do chunk <- takeWhile (/= '}') void $ char '}' let candidate = acc <> chunk - if canParseExp callerExtensions (Text.unpack candidate) + if isValidHaskellExpression callerExtensions (Text.unpack candidate) then pure candidate else findExpressionEnd (candidate <> "}") From 32688be8cf64e21a0bd9cb82cd023832bec33547 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 7 Aug 2026 17:46:21 -0300 Subject: [PATCH 23/26] Support `let` bindings --- hpgsql/src/Hpgsql/GhcParseExp.hs | 38 +++++++++++++++++++++++++++++--- 1 file changed, 35 insertions(+), 3 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 7e74cd6..f239a19 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -7,6 +7,7 @@ module Hpgsql.GhcParseExp (parseExp, isValidHaskellExpression) where import Data.Char (isUpper) import Data.Either (isRight) import qualified Data.List as List +import Data.Foldable (toList) import Data.Maybe (mapMaybe) import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer (stringToStringBuffer) @@ -24,7 +25,7 @@ import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) import Hpgsql.GhcParserOpts (fakeSettings) import Hpgsql.LanguageHaskell.FromThExtension (fromThToGhcLibExtension) -import Language.Haskell.Syntax (FieldOcc (..), GRHS (..), GRHSs (..), HsConDetails (..), HsConPatDetails, HsFieldBind (..), HsLit (..), HsLocalBinds, HsLocalBindsLR (..), HsOverLit (..), HsRecFields (..), HsSigType (..), HsTupArg (..), HsType (..), HsWildCardBndrs (..), LHsExpr, LHsRecField, LHsSigWcType, LMatch, LPat, Match (..), MatchGroup (..), OverLitVal (..), Pat (..), PromotionFlag (..)) +import Language.Haskell.Syntax (FieldOcc (..), GRHS (..), GRHSs (..), HsBindLR (..), HsConDetails (..), HsConPatDetails, HsFieldBind (..), HsLit (..), HsLocalBinds, HsLocalBindsLR (..), HsOverLit (..), HsRecFields (..), HsSigType (..), HsTupArg (..), HsType (..), HsValBindsLR (..), HsWildCardBndrs (..), LHsExpr, LHsRecField, LHsSigWcType, LMatch, LPat, Match (..), MatchGroup (..), OverLitVal (..), Pat (..), PromotionFlag (..)) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) import Language.Haskell.Syntax.Expr (DotFieldOcc (..), HsExpr (..)) import Language.Haskell.Syntax.Module.Name (moduleNameString) @@ -140,6 +141,14 @@ convertExpr (RecordCon _ (L _ conName) (HsRecFields flds _)) = do Right $ TH.RecConE (rdrToName conName) flds' #endif convertExpr (HsCase _ (L _ caseExpr) mg) = TH.CaseE <$> convertExpr caseExpr <*> convertMatchGroup mg +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertExpr (HsLet _ localBinds (L _ body)) = do +#else +convertExpr (HsLet _ _ localBinds _ (L _ body)) = do +#endif + decs <- convertLocalBinds localBinds + body' <- convertExpr body + Right (TH.LetE decs body') -- Now come our list of unsupported language features #if MIN_VERSION_ghc_lib_parser(9,10,0) @@ -157,7 +166,6 @@ convertExpr (HsIPVar {}) = unsupportedLanguageFeatureMsg "Implicit parameters" convertExpr (HsLam {}) = unsupportedLanguageFeatureMsg "Lambda" convertExpr (ExplicitSum {}) = unsupportedLanguageFeatureMsg "Unboxed sums" convertExpr (HsMultiIf {}) = unsupportedLanguageFeatureMsg "Multi-way if" -convertExpr (HsLet {}) = unsupportedLanguageFeatureMsg "Let" convertExpr (HsDo {}) = unsupportedLanguageFeatureMsg "Do notation" convertExpr (RecordUpd {}) = unsupportedLanguageFeatureMsg "Record updates" convertExpr (ArithSeq {}) = unsupportedLanguageFeatureMsg "Arithmetic sequences" @@ -197,9 +205,33 @@ convertGRHSs (GRHSs _ grhss localBinds) = do convertLocalBinds :: HsLocalBinds GhcPs -> Either String [TH.Dec] convertLocalBinds (EmptyLocalBinds _) = Right [] -convertLocalBinds (HsValBinds {}) = unsupportedLanguageFeatureMsg "HsValBinds" +convertLocalBinds (HsValBinds _ (ValBinds _ binds _sigs)) = + traverse (\(L _ b) -> convertBind b) (toList binds) +convertLocalBinds (HsValBinds _ (XValBindsLR {})) = + unsupportedLanguageFeatureMsg "XValBindsLR" convertLocalBinds (HsIPBinds {}) = unsupportedLanguageFeatureMsg "HsIPBinds" +convertBind :: HsBindLR GhcPs GhcPs -> Either String TH.Dec +convertBind FunBind { fun_id = L _ name, fun_matches = MG _ (L _ matches) } = do + clauses <- traverse convertClause matches + Right (TH.FunD (rdrToName name) clauses) +convertBind PatBind { pat_lhs = L _ pat, pat_rhs = grhss } = do + pat' <- convertPat pat + (body, decs) <- convertGRHSs grhss + Right (TH.ValD pat' body decs) +convertBind (VarBind{}) = unsupportedLanguageFeatureMsg "VarBind" +convertBind (PatSynBind{}) = unsupportedLanguageFeatureMsg "Pattern Synonyms bindings" + +convertClause :: LMatch GhcPs (LHsExpr GhcPs) -> Either String TH.Clause +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertClause (L _ (Match _ _ (L _ pats) grhss)) = do +#else +convertClause (L _ (Match _ _ pats grhss)) = do +#endif + pats' <- traverse (\(L _ p) -> convertPat p) pats + (body, decs) <- convertGRHSs grhss + Right (TH.Clause pats' body decs) + -- Pattern conversion (GHC Pat to TH Pat) convertPat :: Pat GhcPs -> Either String TH.Pat From aebd986c15dc4c7fdae12ded932f50a26e3af830 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 7 Aug 2026 17:48:53 -0300 Subject: [PATCH 24/26] No need to worry about source locations, the compile-time errors look good At least on GHC 9.10 they have source line information --- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index f239a19..9a02439 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -31,8 +31,6 @@ import Language.Haskell.Syntax.Expr (DotFieldOcc (..), HsExpr (..)) import Language.Haskell.Syntax.Module.Name (moduleNameString) import qualified "template-haskell" Language.Haskell.TH as TH --- TODO: How about source locations/lines? Do we need them? - -- | Parse a Haskell expression string into a Template Haskell Exp. parseExp :: [TH.Extension] -> String -> Either String TH.Exp parseExp callerExtensions str = do From 1b4dff069ba477893780b57c5b2aacb0717213e4 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 7 Aug 2026 20:48:46 -0300 Subject: [PATCH 25/26] One "Left" missing to replace with the default error message --- hpgsql/src/Hpgsql/GhcParseExp.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs index 9a02439..f6190d7 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -274,7 +274,7 @@ convertConPatDetails con (PrefixCon tyArgs args) = do args' <- traverse (\(L _ p) -> convertPat p) args if null tyArgs then Right (TH.ConP (rdrToName con) [] args') - else Left "Type applications in constructor patterns are unsupported in hpgsql's SQL quasi-quoter. Please file a bug report at https://github.com/mzabani/hpgsql/issues if you want this." + else unsupportedLanguageFeatureMsg "Type applications in constructor patterns" convertConPatDetails con (InfixCon (L _ l) (L _ r)) = do l' <- convertPat l r' <- convertPat r From e0328931b79b4bd099d71c72aad96c9557d9cee5 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 7 Aug 2026 20:53:44 -0300 Subject: [PATCH 26/26] Rename modules and functions --- hpgsql/hpgsql.cabal | 4 ++-- .../Hpgsql/{ => LanguageHaskell}/GhcParserOpts.hs | 2 +- .../ParseHaskellExpression.hs} | 12 ++++++------ hpgsql/src/Hpgsql/ParsingInternal.hs | 2 +- hpgsql/src/Hpgsql/QueryInternal.hs | 8 ++++---- 5 files changed, 14 insertions(+), 14 deletions(-) rename hpgsql/src/Hpgsql/{ => LanguageHaskell}/GhcParserOpts.hs (91%) rename hpgsql/src/Hpgsql/{GhcParseExp.hs => LanguageHaskell/ParseHaskellExpression.hs} (97%) diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index 3e7a56e..ec89502 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -43,10 +43,10 @@ library Hpgsql.Types other-modules: Hpgsql.Base - Hpgsql.GhcParseExp - Hpgsql.GhcParserOpts Hpgsql.Internal Hpgsql.LanguageHaskell.FromThExtension + Hpgsql.LanguageHaskell.GhcParserOpts + Hpgsql.LanguageHaskell.ParseHaskellExpression Hpgsql.Locking Hpgsql.Msgs Hpgsql.Networking diff --git a/hpgsql/src/Hpgsql/GhcParserOpts.hs b/hpgsql/src/Hpgsql/LanguageHaskell/GhcParserOpts.hs similarity index 91% rename from hpgsql/src/Hpgsql/GhcParserOpts.hs rename to hpgsql/src/Hpgsql/LanguageHaskell/GhcParserOpts.hs index 90590e7..31389cd 100644 --- a/hpgsql/src/Hpgsql/GhcParserOpts.hs +++ b/hpgsql/src/Hpgsql/LanguageHaskell/GhcParserOpts.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-missing-fields #-} -module Hpgsql.GhcParserOpts (fakeSettings) where +module Hpgsql.LanguageHaskell.GhcParserOpts (fakeSettings) where import GHC.Platform (genericPlatform) import GHC.Settings diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/LanguageHaskell/ParseHaskellExpression.hs similarity index 97% rename from hpgsql/src/Hpgsql/GhcParseExp.hs rename to hpgsql/src/Hpgsql/LanguageHaskell/ParseHaskellExpression.hs index f6190d7..4ea8819 100644 --- a/hpgsql/src/Hpgsql/GhcParseExp.hs +++ b/hpgsql/src/Hpgsql/LanguageHaskell/ParseHaskellExpression.hs @@ -2,7 +2,7 @@ {-# LANGUAGE PackageImports #-} {- FOURMOLU_DISABLE -} -- CPP macros make fourmolu fail -module Hpgsql.GhcParseExp (parseExp, isValidHaskellExpression) where +module Hpgsql.LanguageHaskell.ParseHaskellExpression (parseHaskellExpression, isValidHaskellExpression) where import Data.Char (isUpper) import Data.Either (isRight) @@ -23,7 +23,7 @@ import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit) import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc) -import Hpgsql.GhcParserOpts (fakeSettings) +import Hpgsql.LanguageHaskell.GhcParserOpts (fakeSettings) import Hpgsql.LanguageHaskell.FromThExtension (fromThToGhcLibExtension) import Language.Haskell.Syntax (FieldOcc (..), GRHS (..), GRHSs (..), HsBindLR (..), HsConDetails (..), HsConPatDetails, HsFieldBind (..), HsLit (..), HsLocalBinds, HsLocalBindsLR (..), HsOverLit (..), HsRecFields (..), HsSigType (..), HsTupArg (..), HsType (..), HsValBindsLR (..), HsWildCardBndrs (..), LHsExpr, LHsRecField, LHsSigWcType, LMatch, LPat, Match (..), MatchGroup (..), OverLitVal (..), Pat (..), PromotionFlag (..)) import Language.Haskell.Syntax.Basic (FieldLabelString (..)) @@ -32,19 +32,19 @@ import Language.Haskell.Syntax.Module.Name (moduleNameString) import qualified "template-haskell" Language.Haskell.TH as TH -- | Parse a Haskell expression string into a Template Haskell Exp. -parseExp :: [TH.Extension] -> String -> Either String TH.Exp -parseExp callerExtensions str = do +parseHaskellExpression :: [TH.Extension] -> String -> Either String TH.Exp +parseHaskellExpression callerExtensions str = do hsExpr <- ghcParse callerExtensions str convertExpr hsExpr -- | Check if a string can be parsed as a Haskell expression. isValidHaskellExpression :: [TH.Extension] -> String -> Bool --- NOTE: This uses `ghcParse` instead of `parseExp` on purpose. +-- NOTE: This uses `ghcParse` instead of `parseHaskellExpression` on purpose. -- The reasoning is if we find a valid Haskell expression inside -- a quasiquoter, we want to parse it as a Haskell expression. -- If later on we don't support converting that to template-haskell, -- that's hpgsql's limitation and we want a good error to be thrown --- to the user, which `parseExp` will do. +-- to the user, which `parseHaskellExpression` will do. -- And we don't want to mislead our quasiquoter parser into skipping -- a valid Haskell expression inside #{} or ^{} just because hpgsql -- can't convert it to TH: best to fail loud and clear. diff --git a/hpgsql/src/Hpgsql/ParsingInternal.hs b/hpgsql/src/Hpgsql/ParsingInternal.hs index 332dc50..486d4d7 100644 --- a/hpgsql/src/Hpgsql/ParsingInternal.hs +++ b/hpgsql/src/Hpgsql/ParsingInternal.hs @@ -39,7 +39,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text -import Hpgsql.GhcParseExp (isValidHaskellExpression) +import Hpgsql.LanguageHaskell.ParseHaskellExpression (isValidHaskellExpression) import "template-haskell" Language.Haskell.TH (Extension) import Prelude hiding (takeWhile) diff --git a/hpgsql/src/Hpgsql/QueryInternal.hs b/hpgsql/src/Hpgsql/QueryInternal.hs index a4a6477..e805375 100644 --- a/hpgsql/src/Hpgsql/QueryInternal.hs +++ b/hpgsql/src/Hpgsql/QueryInternal.hs @@ -21,8 +21,8 @@ import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Hpgsql.Builder (BinaryField) import Hpgsql.Encoding (FieldEncoder (..), RowEncoder (..), ToPgField (..), ToPgRow (..)) -import Hpgsql.GhcParseExp (parseExp) import Hpgsql.InternalTypes (Query (..), SingleQuery (..), SingleQueryFragment (..), breakQueryIntoStatements, renumberParamsFrom) +import Hpgsql.LanguageHaskell.ParseHaskellExpression (parseHaskellExpression) import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), QQExprKind (..), blockText, flattenBlocks, parseSql) import Hpgsql.TypeInfo (EncodingContext, Oid) import Language.Haskell.TH.Quote @@ -182,7 +182,7 @@ fragmentToPartExp (NonInterpolatedSqlFragment t) = [|StaticSqlPart $(litE (stringL (Text.unpack t)))|] fragmentToPartExp (InterpolatedHaskellExpr haskellExpr) = do exts <- extsEnabled - case parseExp exts (Text.unpack haskellExpr) of + case parseHaskellExpression exts (Text.unpack haskellExpr) of Left err -> error $ "Could not parse Haskell expression '" ++ Text.unpack haskellExpr ++ "': " ++ err Right expr -> [|ParamPart (encodeParam $(pure expr))|] fragmentToPartExp SemiColonFragment = @@ -191,7 +191,7 @@ fragmentToPartExp (WhitespaceOrCommentsFragment t) = [|WhitespaceOrCommenstPart $(litE (stringL (Text.unpack t)))|] fragmentToPartExp (EmbeddedQueryExpr haskellExpr) = do exts <- extsEnabled - case parseExp exts (Text.unpack haskellExpr) of + case parseHaskellExpression exts (Text.unpack haskellExpr) of Left err -> error $ "Could not parse Haskell expression '" ++ Text.unpack haskellExpr ++ "': " ++ err Right expr -> [|EmbeddedQueryPart $(pure expr)|] @@ -259,7 +259,7 @@ parseBlockQuasiQuoter (QuasiQuoterExpression QQEmbeddedQuery expr) = [EmbeddedQu generateParamExp :: Text -> Q Exp generateParamExp (Text.unpack -> haskellExpr) = do exts <- extsEnabled - case parseExp exts haskellExpr of + case parseHaskellExpression exts haskellExpr of Left err -> error $ "Could not parse Haskell expression '" ++ haskellExpr ++ "': " ++ err Right expr -> [|encodeParam $(pure expr)|]