diff --git a/.hlint.yaml b/.hlint.yaml index 76dc978..cf9b903 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -4,6 +4,9 @@ - arguments: - "--cpp-define=MIN_VERSION_base(a,b,c)=1" + - "--cpp-define=MIN_VERSION_template_haskell(2,21,0)=1" + - "--cpp-define=MIN_VERSION_template_haskell(2,22,0)=1" + - "--cpp-define=MIN_VERSION_template_haskell(2,23,0)=0" - "-XQuasiQuotes" - "-XTemplateHaskell" - "-XOverloadedRecordDot" 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-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index 13ba3f8..78040bf 100644 --- a/hpgsql-tests/SqlQuasiquoterSpec.hs +++ b/hpgsql-tests/SqlQuasiquoterSpec.hs @@ -4,16 +4,21 @@ import Control.Monad (forM_) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS import Data.Char (isDigit) +import Data.Functor.Contravariant (contramap) +import Data.Int (Int32) import qualified Data.List as List import qualified Data.List.NonEmpty as NE +import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Vector as Vector +import GHC.Generics (Generic) import Hedgehog (Gen, PropertyT, annotateShow, forAll, (===)) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Hpgsql.Builder (BinaryField (..)) -import Hpgsql.Encoding (RowEncoder (..), ToPgRow (..)) +import Hpgsql.Encoding (FromPgField, LowerCasedPgEnum (..), RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeEncoder, typeFieldEncoder, typeOidWithName) import Hpgsql.InternalTypes (Query (..), SingleQuery (..)) import Hpgsql.ParsingInternal (ParsingOpts (..), parseSql) import Hpgsql.Query (breakQueryIntoStatements, mkQuery, sql) @@ -144,23 +149,68 @@ genMkQuery = pure (mkQuery "SELECT $1, $2, $3, $4, $5;" params, toComparableParams params) ] +data SomeRecord = SomeRecord {field1 :: Int, field2 :: Int} + +data SomeGenericEnum = EVal1 | EVal2 | EVal3 + deriving stock (Bounded, Enum, Eq, Generic, Show) + deriving (ToPgField) via (LowerCasedPgEnum SomeGenericEnum) + +data IntAndBool = IntAndBool {ibInt :: Int, ibBool :: Bool} + deriving stock (Eq, Show) + +instance ToPgField IntAndBool where + fieldEncoder = + typeFieldEncoder (typeOidWithName "int_and_bool") $ + compositeTypeEncoder $ + contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder + +-- | This exists to test TypeApplications inside quasiquoters. +polyFunc42 :: Proxy a -> Int +polyFunc42 _ = 42 + +infixFunc :: Char -> String -> String +infixFunc c s = c : s + -- | Queries built with the sql quasiquoter and #{} interpolation. +-- These test a variety of GHC extensions and language syntax/features +-- inside quasiquoters. genInterpolatedQuery :: Gen (Query, [(Maybe Oid, BinaryField)]) genInterpolatedQuery = Gen.choice [ pure ([sql|SELECT 1, '#{x}', '^{y}';|], []), do x <- genInt - pure ([sql|SELECT #{x};|], toComparableParams (Only x)), + y <- genInt + c <- genChar + pure ([sql|SELECT #{c `infixFunc` "abc"} #{if True then x else 0}, #{polyFunc42 (Proxy @String)}, #{Vector.fromList $ 37 : [45, y]};|], toComparableParams (c `infixFunc` "abc", x, polyFunc42 (Proxy @String), Vector.fromList [37, 45, y])), do - x <- genInt + x <- SomeRecord <$> genInt <*> genInt y <- genInt - pure ([sql|SELECT #{x}, #{y};|], toComparableParams (x, y)), + z <- Gen.bool + pure ([sql|SELECT #{x.field1}, #{-(x.field2)}, #{IntAndBool { ibInt = y, {- Some comment -} ibBool = z }}, #{'a'};|], toComparableParams (x.field1, -(x.field2), IntAndBool y z, 'a')), do x <- genInt y <- genInt z <- genInt - pure ([sql|SELECT #{x} FROM t WHERE #{y} BETWEEN 0 AND #{z};|], toComparableParams (x, y, z)) + e :: SomeGenericEnum <- Gen.enum minBound maxBound + pure ([sql|SELECT #{x}, #{e} FROM t WHERE #{y} BETWEEN 0 AND #{fromIntegral z + 1.421::Float};|], toComparableParams (x, e, y, fromIntegral z + 1.421 :: Float)), + do + x <- genInt + b <- Gen.bool + pure + ( [sql|SELECT #{fst <$> Just (b, False)}, #{case compare x 0 of + !EQ -> "abc"::Text + GT -> "cde" + LT -> "xyz" + _ -> error "Impossible"};|], + toComparableParams + ( b, + case compare x 0 of + !EQ -> "abc" :: Text + GT -> "cde" + LT -> "xyz" + ) + ) ] -- | Queries built with ^{} embedded queries, including reused placeholders. diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index 87d0379..3e7a56e 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -43,7 +43,10 @@ library Hpgsql.Types other-modules: Hpgsql.Base + Hpgsql.GhcParseExp + Hpgsql.GhcParserOpts Hpgsql.Internal + Hpgsql.LanguageHaskell.FromThExtension Hpgsql.Locking Hpgsql.Msgs Hpgsql.Networking @@ -104,7 +107,7 @@ library crypton >= 1.0.0 && < 1.1, memory >= 0.18.0 && < 0.19, hashable >= 1.5 && < 1.6, - haskell-src-meta >= 0.8 && < 0.9, + ghc-lib-parser >= 9.6 && < 9.14, network >= 3.2 && < 3.3, network-uri >= 2.6 && < 2.7, safe-exceptions >= 0.1 && < 0.2, diff --git a/hpgsql/src/Hpgsql/GhcParseExp.hs b/hpgsql/src/Hpgsql/GhcParseExp.hs new file mode 100644 index 0000000..7b61155 --- /dev/null +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +{- FOURMOLU_DISABLE -} -- CPP macros make fourmolu fail + +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 (GhcPs) +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) +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? + +-- | Parse a Haskell expression string into a Template Haskell Exp. +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. +canParseExp :: [TH.Extension] -> String -> Bool +canParseExp callerExtensions = isRight . ghcParse callerExtensions + +ghcParse :: [TH.Extension] -> String -> Either String (HsExpr GhcPs) +ghcParse callerExtensions 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" + where + parserDynFlags :: DynFlags + parserDynFlags = + List.foldl' + xopt_set + (defaultDynFlags fakeSettings) + (mapMaybe fromThToGhcLibExtension callerExtensions) + +-- +-- 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 'negate) e' + +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertExpr (HsPar _ (L _ e)) = TH.ParensE <$> convertExpr e +#elif MIN_VERSION_ghc_lib_parser(9,8,0) +convertExpr (HsPar _ _ (L _ e) _) = TH.ParensE <$> convertExpr e +#endif +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) = TH.LitE <$> convertOverLit ol +convertExpr (ExprWithTySig _ (L _ e) sigWcTy) = do + e' <- convertExpr e + ty' <- convertSigWcType sigWcTy + Right (TH.SigE e' ty') +convertExpr (HsGetField _ (L _ e) (L _ (DotFieldOcc _ (L _ fld)))) = do + e' <- convertExpr e + Right (TH.GetFieldE e' (fieldLabelToString fld)) +#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 +#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 +#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 (HsCase _ (L _ caseExpr) mg) = TH.CaseE <$> convertExpr caseExpr <*> convertMatchGroup mg + +-- Now come our list of unsupported language features +#if MIN_VERSION_ghc_lib_parser(9,10,0) +convertExpr (HsEmbTy {}) = unsupportedLanguageFeatureMsg "Embedded type" +convertExpr (HsForAll {}) = unsupportedLanguageFeatureMsg "Forall-types" +convertExpr (HsFunArr {}) = unsupportedLanguageFeatureMsg "Function types" +convertExpr (HsQual {}) = unsupportedLanguageFeatureMsg "HsQual" +#else +convertExpr (HsLamCase {}) = unsupportedLanguageFeatureMsg "LambdaCase" +convertExpr (HsRecSel {}) = unsupportedLanguageFeatureMsg "Record field selectors" +#endif +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 ++ " 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 + +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 + [pat] -> Right (TH.Match pat body decs) + _ -> 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 + _ -> unsupportedLanguageFeatureMsg "Guarded case alternative" + Right (body, decs) + +convertLocalBinds :: HsLocalBinds GhcPs -> Either String [TH.Dec] +convertLocalBinds (EmptyLocalBinds _) = Right [] +convertLocalBinds (HsValBinds {}) = unsupportedLanguageFeatureMsg "HsValBinds" +convertLocalBinds (HsIPBinds {}) = unsupportedLanguageFeatureMsg "HsIPBinds" + +-- 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) _ _) = 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) +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 +-- 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 + 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 + +rdrToExp :: RdrName -> TH.Exp +rdrToExp rdr = + let name = rdrToName rdr + in if isConstructorName 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 (Orig _ occ) = TH.mkName (occNameString occ) +rdrToName (Exact name) = TH.mkName (occNameString (nameOccName name)) + +isConstructorName :: TH.Name -> Bool +isConstructorName n = case TH.nameBase n of + (c : _) -> isUpper c || c == ':' + _ -> False + +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 + +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)) -- TODO Why rational? +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)) +#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.Lit +convertOverLit ol = case ol_val ol of + 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) + +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 + | isConstructorName 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 (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" diff --git a/hpgsql/src/Hpgsql/GhcParserOpts.hs b/hpgsql/src/Hpgsql/GhcParserOpts.hs new file mode 100644 index 0000000..90590e7 --- /dev/null +++ b/hpgsql/src/Hpgsql/GhcParserOpts.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -Wno-missing-fields #-} + +module Hpgsql.GhcParserOpts (fakeSettings) where + +import GHC.Platform (genericPlatform) +import GHC.Settings +import GHC.Settings.Config (cProjectVersion) +import GHC.Utils.Fingerprint (fingerprint0) + +-- | Fake GHC 'Settings' with only the fields the parser needs. +-- All other fields are left undefined; this is why we suppress +-- the missing-fields warning for this module only. +fakeSettings :: Settings +fakeSettings = + Settings + { sGhcNameVersion = GhcNameVersion "ghc" cProjectVersion, + sFileSettings = FileSettings {}, + sTargetPlatform = genericPlatform, + sPlatformMisc = PlatformMisc {}, + sToolSettings = ToolSettings {toolSettings_opt_P_fingerprint = fingerprint0} + } diff --git a/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs new file mode 100644 index 0000000..ab658c2 --- /dev/null +++ b/hpgsql/src/Hpgsql/LanguageHaskell/FromThExtension.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} + +module Hpgsql.LanguageHaskell.FromThExtension where + +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.LanguageExtensions.Type (Extension (..)) +import qualified "template-haskell" Language.Haskell.TH as TH + +fromThToGhcLibExtension :: TH.Extension -> Maybe Extension +fromThToGhcLibExtension = \case + TH.AllowAmbiguousTypes -> Just AllowAmbiguousTypes + TH.AlternativeLayoutRule -> Just AlternativeLayoutRule + TH.AlternativeLayoutRuleTransitional -> Just AlternativeLayoutRuleTransitional + TH.ApplicativeDo -> Just ApplicativeDo + TH.Arrows -> Just Arrows + TH.AutoDeriveTypeable -> Just AutoDeriveTypeable + TH.BangPatterns -> Just BangPatterns + TH.BinaryLiterals -> Just BinaryLiterals + TH.BlockArguments -> Just BlockArguments + TH.CApiFFI -> Just CApiFFI + TH.CUSKs -> Just CUSKs + TH.ConstrainedClassMethods -> Just ConstrainedClassMethods + TH.ConstraintKinds -> Just ConstraintKinds + TH.Cpp -> Just Cpp + TH.DataKinds -> Just DataKinds + TH.DatatypeContexts -> Just DatatypeContexts + TH.DeepSubsumption -> Just DeepSubsumption + TH.DefaultSignatures -> Just DefaultSignatures + TH.DeriveAnyClass -> Just DeriveAnyClass + TH.DeriveDataTypeable -> Just DeriveDataTypeable + TH.DeriveFoldable -> Just DeriveFoldable + TH.DeriveFunctor -> Just DeriveFunctor + TH.DeriveGeneric -> Just DeriveGeneric + TH.DeriveLift -> Just DeriveLift + TH.DeriveTraversable -> Just DeriveTraversable + TH.DerivingStrategies -> Just DerivingStrategies + TH.DerivingVia -> Just DerivingVia + TH.DisambiguateRecordFields -> Just DisambiguateRecordFields + TH.DoAndIfThenElse -> Just DoAndIfThenElse + TH.DuplicateRecordFields -> Just DuplicateRecordFields + TH.EmptyCase -> Just EmptyCase + TH.EmptyDataDecls -> Just EmptyDataDecls + TH.EmptyDataDeriving -> Just EmptyDataDeriving + TH.ExistentialQuantification -> Just ExistentialQuantification + TH.ExplicitForAll -> Just ExplicitForAll + TH.ExplicitNamespaces -> Just ExplicitNamespaces + TH.ExtendedDefaultRules -> Just ExtendedDefaultRules + TH.FieldSelectors -> Just FieldSelectors + TH.FlexibleContexts -> Just FlexibleContexts + TH.FlexibleInstances -> Just FlexibleInstances + TH.ForeignFunctionInterface -> Just ForeignFunctionInterface + TH.FunctionalDependencies -> Just FunctionalDependencies + TH.GADTSyntax -> Just GADTSyntax + TH.GADTs -> Just GADTs + TH.GHCForeignImportPrim -> Just GHCForeignImportPrim + TH.GeneralizedNewtypeDeriving -> Just GeneralizedNewtypeDeriving + TH.HexFloatLiterals -> Just HexFloatLiterals + TH.ImplicitParams -> Just ImplicitParams + TH.ImplicitPrelude -> Just ImplicitPrelude + TH.ImportQualifiedPost -> Just ImportQualifiedPost + TH.ImpredicativeTypes -> Just ImpredicativeTypes + TH.IncoherentInstances -> Just IncoherentInstances + TH.InstanceSigs -> Just InstanceSigs + TH.InterruptibleFFI -> Just InterruptibleFFI + TH.JavaScriptFFI -> Just JavaScriptFFI + TH.KindSignatures -> Just KindSignatures + TH.LambdaCase -> Just LambdaCase + TH.LexicalNegation -> Just LexicalNegation + TH.LiberalTypeSynonyms -> Just LiberalTypeSynonyms + TH.LinearTypes -> Just LinearTypes + TH.MagicHash -> Just MagicHash + TH.MonadComprehensions -> Just MonadComprehensions + TH.MonoLocalBinds -> Just MonoLocalBinds + TH.MonomorphismRestriction -> Just MonomorphismRestriction + TH.MultiParamTypeClasses -> Just MultiParamTypeClasses + TH.MultiWayIf -> Just MultiWayIf + TH.NPlusKPatterns -> Just NPlusKPatterns + TH.NamedFieldPuns -> Just NamedFieldPuns + TH.NamedWildCards -> Just NamedWildCards + TH.NegativeLiterals -> Just NegativeLiterals + TH.NondecreasingIndentation -> Just NondecreasingIndentation + TH.NullaryTypeClasses -> Just NullaryTypeClasses + TH.NumDecimals -> Just NumDecimals + TH.NumericUnderscores -> Just NumericUnderscores + TH.OverlappingInstances -> Just OverlappingInstances + TH.OverloadedLabels -> Just OverloadedLabels + TH.OverloadedLists -> Just OverloadedLists + TH.OverloadedRecordDot -> Just OverloadedRecordDot + TH.OverloadedRecordUpdate -> Just OverloadedRecordUpdate + TH.OverloadedStrings -> Just OverloadedStrings + TH.PackageImports -> Just PackageImports + TH.ParallelArrays -> Just ParallelArrays + TH.ParallelListComp -> Just ParallelListComp + TH.PartialTypeSignatures -> Just PartialTypeSignatures + TH.PatternGuards -> Just PatternGuards + TH.PatternSynonyms -> Just PatternSynonyms + TH.PolyKinds -> Just PolyKinds + TH.PostfixOperators -> Just PostfixOperators + TH.QualifiedDo -> Just QualifiedDo + TH.QuantifiedConstraints -> Just QuantifiedConstraints + TH.QuasiQuotes -> Just QuasiQuotes + TH.RankNTypes -> Just RankNTypes + TH.RebindableSyntax -> Just RebindableSyntax + TH.RecordWildCards -> Just RecordWildCards + TH.RecursiveDo -> Just RecursiveDo + TH.RelaxedLayout -> Just RelaxedLayout + TH.RelaxedPolyRec -> Just RelaxedPolyRec + TH.RoleAnnotations -> Just RoleAnnotations + TH.ScopedTypeVariables -> Just ScopedTypeVariables + TH.StandaloneDeriving -> Just StandaloneDeriving + TH.StandaloneKindSignatures -> Just StandaloneKindSignatures + TH.StarIsType -> Just StarIsType + TH.StaticPointers -> Just StaticPointers + TH.Strict -> Just Strict + TH.StrictData -> Just StrictData + TH.TemplateHaskell -> Just TemplateHaskell + TH.TemplateHaskellQuotes -> Just TemplateHaskellQuotes + TH.TraditionalRecordSyntax -> Just TraditionalRecordSyntax + TH.TransformListComp -> Just TransformListComp + TH.TupleSections -> Just TupleSections + TH.TypeApplications -> Just TypeApplications + TH.TypeData -> Just TypeData + TH.TypeFamilies -> Just TypeFamilies + TH.TypeFamilyDependencies -> Just TypeFamilyDependencies + TH.TypeInType -> Just TypeInType + TH.TypeOperators -> Just TypeOperators + TH.TypeSynonymInstances -> Just TypeSynonymInstances + TH.UnboxedSums -> Just UnboxedSums + TH.UnboxedTuples -> Just UnboxedTuples + TH.UndecidableInstances -> Just UndecidableInstances + TH.UndecidableSuperClasses -> Just UndecidableSuperClasses + TH.UnicodeSyntax -> Just UnicodeSyntax + TH.UnliftedDatatypes -> Just UnliftedDatatypes + TH.UnliftedFFITypes -> Just UnliftedFFITypes + TH.UnliftedNewtypes -> Just UnliftedNewtypes + TH.ViewPatterns -> Just ViewPatterns +#if MIN_VERSION_template_haskell(2,21,0) + TH.ExtendedLiterals -> Just ExtendedLiterals + TH.TypeAbstractions -> Just TypeAbstractions +#endif +#if MIN_VERSION_template_haskell(2,22,0) + TH.ListTuplePuns -> Just ListTuplePuns + TH.RequiredTypeArguments -> Just RequiredTypeArguments +#endif +#if MIN_VERSION_template_haskell(2,23,0) + TH.MultilineStrings -> Just MultilineStrings + TH.NamedDefaults -> Just NamedDefaults + TH.OrPatterns -> Just OrPatterns +#endif + -- Why a catch-all here after going through all the work of listing + -- extensions above? Because of two conflicting goals: + -- 1 - Not allocate and parse strings, plus run a Map search during compilation (see algo below) + -- 2 - Support users compiling hpgsql with newer GHC versions + -- + -- Goal 1 is arguably excessive over-refinement, and goal 2 is arguably + -- pointless since it seems like (from my extremely limited experience) + -- template-haskell and ghc-lib-parser will change with new releases + -- anyway, but not being the annoying library that fails to compile or run + -- with some user trying out a new GHC (after bumping version bounds themselves) + -- feels important. + -- So we achieve a little bit of both goals like this. This is also the reason + -- why we have -Wno-overlapping-patterns in this file. +{- FOURMOLU_DISABLE -} + someNewThExtension -> Map.lookup (show someNewThExtension) allGhcLibParserExtensions +{- FOURMOLU_ENABLE -} + +-- | This Map is only useful by assuming the `Show` representations of language extensions in both +-- ghc-lib-parser and template-haskell match. That feels like a reasonable assumption. +allGhcLibParserExtensions :: Map String Extension +allGhcLibParserExtensions = Map.fromList $ map (\ex -> (show ex, ex)) [minBound .. maxBound] diff --git a/hpgsql/src/Hpgsql/ParsingInternal.hs b/hpgsql/src/Hpgsql/ParsingInternal.hs index 232ec60..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. @@ -36,7 +38,8 @@ 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 "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,9 +168,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 callerExtensions (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..a4a6477 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 Language.Haskell.Meta.Parse (parseExp) -import Language.Haskell.TH import Language.Haskell.TH.Quote +import "template-haskell" Language.Haskell.TH (Exp (..), Q, extsEnabled, integerL, litE, stringL) -- | A useful representation for our quasiquoter parsing. data SqlFragment @@ -128,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" @@ -139,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" @@ -174,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)|] @@ -249,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)|]