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-tests/SqlQuasiquoterSpec.hs b/hpgsql-tests/SqlQuasiquoterSpec.hs index 13ba3f8..f7da82b 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 = @@ -151,11 +155,10 @@ 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 <- 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 diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index 9d0343f..88bc79f 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 >= 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..607413a --- /dev/null +++ b/hpgsql/src/Hpgsql/GhcParseExp.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} + +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) +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) +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 (fakeSettings) +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 + 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 + +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" + 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 + +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) = 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 +convertExpr _ = Left "Unsupported Haskell expression form in hpgsql's 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 + -- 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 + +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)) +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..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/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..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 Language.Haskell.Meta.Parse (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