disable qq warnings for megaparsec <9.5

Author: dtpowl

persistent/Database/Persist/Quasi/Internal.hs

@@ -21,7 +21,7 @@ module Database.Persist.Quasi.Internal
     , sourceLocFromTHLoc
     , parseFieldType
     , takeColsEx
-    , CumulativeParseResult (..)
+    , CumulativeParseResult
     , renderErrors
     , parserWarningMessage
 

persistent/Database/Persist/Quasi/Internal/ModelParser.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
 
 module Database.Persist.Quasi.Internal.ModelParser
     ( SourceLoc (..)
@@ -75,7 +76,11 @@ initialExtraState =
         , esLastDocumentablePosition = Nothing
         }
 
--- @since 2.16.0.0
+-- megaparsec <9.5 lacks a MonadWriter instance for ParsecT.
+-- We must continue supporting megaparsec <9.5 in order to support
+-- GHC <9, so we will work around this by disabling warning functionality
+-- on old megaparsecs.
+#if MIN_VERSION_megaparsec(9,5,0)
 newtype Parser a = Parser
     { unParser
         :: ReaderT
@@ -103,6 +108,31 @@ newtype Parser a = Parser
         , MonadParsec Void String
         , MonadWriter (Set ParserWarning)
         )
+#else
+newtype Parser a = Parser
+    { unParser
+        :: ReaderT
+            PersistSettings
+            ( StateT
+                ExtraState
+                ( Parsec
+                    Void
+                    String
+                )
+            )
+            a
+    }
+    deriving newtype
+        ( Functor
+        , Applicative
+        , Monad
+        , Alternative
+        , MonadPlus
+        , MonadState ExtraState
+        , MonadReader PersistSettings
+        , MonadParsec Void String
+        )
+#endif
 
 type EntityParseError = ParseErrorBundle String Void
 
@@ -139,10 +169,16 @@ runConfiguredParser
     -> InternalParseResult a
 runConfiguredParser ps acc parser fp s = (warnings, either)
   where
+#if MIN_VERSION_megaparsec(9,5,0)
     sm = runReaderT (unParser parser) ps
     pm = runStateT sm acc
     wm = runParserT' pm initialInternalState
     ((_is, either), warnings) = runWriter wm
+#else
+    sm = runReaderT (unParser parser) ps
+    pm = runStateT sm acc
+    ((_is, either), warnings) = (runParser' pm initialInternalState, mempty)
+#endif
 
     initialSourcePos =
         SourcePos
@@ -186,23 +222,25 @@ tryOrWarn msg p l r = do
     parserState <- getParserState
     withRecovery (warnAndRetry $ statePosState parserState) l
   where
-    warnAndRetry posState err = do
-        if p err
-            then do
-                let
-                    (pairs, _) = attachSourcePos errorOffset [err] posState
-                tell . Set.fromList $
-                    map
-                        ( \(e, _pos) ->
-                            ParserWarning
-                                { parserWarningExtraMessage = msg <> "\n"
-                                , parserWarningUnderlyingError = e
-                                , parserWarningPosState = posState
-                                }
-                        )
-                        pairs
-                r
-            else parseError err
+    warnAndRetry posState err =
+        if not (p err)
+        then parseError err
+        else do
+#if MIN_VERSION_megaparsec(9,5,0)
+            let
+              (pairs, _) = attachSourcePos errorOffset [err] posState
+            tell . Set.fromList $
+                map
+                    ( \(e, _pos) ->
+                        ParserWarning
+                            { parserWarningExtraMessage = msg <> "\n"
+                            , parserWarningUnderlyingError = e
+                            , parserWarningPosState = posState
+                            }
+                    )
+                    pairs
+#endif
+            r
 
 -- | Attempts to parse with a provided parser. If it fails with an error matching
 -- the provided predicate, it registers a delayed error with the provided message and falls

persistent/Database/Persist/Quasi/PersistSettings.hs

@@ -5,6 +5,7 @@ module Database.Persist.Quasi.PersistSettings
     , lowerCaseSettings
     , ParserErrorLevel (..)
     , ParserWarning
+    , unableToReportConfiguredWarnings
     , warningPos
     , parserWarningMessage
 

persistent/Database/Persist/Quasi/PersistSettings/Internal.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Database.Persist.Quasi.PersistSettings.Internal where
 
 import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)
@@ -98,6 +100,13 @@ parserWarningMessage pw =
                     }
            )
 
+unableToReportConfiguredWarnings :: PersistSettings -> Bool
+#if MIN_VERSION_megaparsec(9,5,0)
+unableToReportConfiguredWarnings _ps = False
+#else
+unableToReportConfiguredWarnings = (Just LevelWarning ==) . psTabErrorLevel
+#endif
+
 toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text
 toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) =
     entName <> inf <> conName

persistent/Database/Persist/TH/Internal.hs

@@ -285,7 +285,15 @@ embedEntityDefsMap existingEnts rawEnts =
 parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp
 parseReferences ps s = do
   let (warnings, res) = parse ps s
-  traverse_ (reportWarning . parserWarningMessage) $ warnings
+  if unableToReportConfiguredWarnings ps
+  then
+      reportWarning $ unlines
+                [ "At least one quasiquoter warning has been enabled, but these warnings cannot be reported."
+                , "Please upgrade to megaparsec >= 9.5 to enable warning reports."
+                , "Support for megaparsec < 9.5 will eventually be removed."
+                ]
+  else
+      traverse_ (reportWarning . parserWarningMessage) $ warnings
   case res of
     Left errs -> fail $ renderErrors errs
     Right r -> lift r

persistent/test/Database/Persist/QuasiSpec.hs

@@ -303,11 +303,13 @@ spec = describe "Quasi" $ do
         it "permits tab indentation" $
           getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
 
+#if MIN_VERSION_megaparsec(9,5,0)
         it "generates warnings" $
           Set.map parserWarningMessage warnings
           `shouldBe` [ "use spaces instead of tabs\n2:1:\n  |\n2 |  Id Text\n  | ^\nunexpected tab\nexpecting valid whitespace\n"
                      , "use spaces instead of tabs\n3:1:\n  |\n3 |  name String\n  | ^\nunexpected tab\nexpecting valid whitespace\n"
                      ]
+#endif
 
       describe "when configured to disallow tabs" $ do
         let