Use updated GHC to fix WarningTxt tests

alanz · Apr 6, 2024 · 597f2cb · 597f2cb
1 parent f0893b9
commit 597f2cb
Show file tree

Hide file tree

Showing 3 changed files with 42 additions and 24 deletions.
diff --git a/configure.sh b/configure.sh
@@ -208,4 +208,5 @@ rm -fr dist*
 # cabal configure -fdev  --enable-tests --with-compiler=/opt/ghc/9.11.20240325/bin/ghc --allow-newer
 # cabal configure -fdev  --enable-tests --with-compiler=/opt/ghc/9.11.20240327/bin/ghc --allow-newer
 # cabal configure -fdev  --enable-tests --with-compiler=/opt/ghc/9.11.20240329/bin/ghc --allow-newer
-cabal configure -fdev  --enable-tests --with-compiler=/opt/ghc/9.11.20240402/bin/ghc --allow-newer
+# cabal configure -fdev  --enable-tests --with-compiler=/opt/ghc/9.11.20240402/bin/ghc --allow-newer
+cabal configure -fdev  --enable-tests --with-compiler=/opt/ghc/9.11.20240405/bin/ghc --allow-newer
diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs
@@ -754,6 +754,11 @@ printStringAdvanceA str = printStringAtAA (EpaDelta (SameLine 0) []) str >> retu
 printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation
 printStringAtAA el str = printStringAtAAC CaptureComments el str
 
+printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation
+printStringAtNC el str = do
+    el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str
+    return (epaToNoCommentsLocation el')
+
 printStringAtAAL :: (Monad m, Monoid w)
   => a -> Lens a EpaLocation -> String -> EP w m a
 printStringAtAAL an l str = do
@@ -2167,10 +2172,11 @@ instance ExactPrint StringLiteral where
   getAnnotationEntry = const NoEntryVal
   setAnnotationAnchor a _ _ _ = a
 
-  exact l@(StringLiteral src fs mcomma) = do
+  exact (StringLiteral src fs mcomma) = do
     printSourceTextAA src (show (unpackFS fs))
-    mapM_ (\r -> printStringAtRs r ",") mcomma
-    return l
+    mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma
+    return (StringLiteral src fs mcomma')
+
 
 -- ---------------------------------------------------------------------
 
@@ -4818,23 +4824,30 @@ instance ExactPrint (Pat GhcPs) where
     tp' <- markAnnotated tp
     return (EmbTyPat toktype' tp')
 
+  exact (InvisPat tokat tp) = do
+    tokat' <- markEpToken tokat
+    tp' <- markAnnotated tp
+    pure (InvisPat tokat' tp')
+
 -- ---------------------------------------------------------------------
 
-instance ExactPrint (ArgPat GhcPs) where
-  getAnnotationEntry (VisPat _ pat) = getAnnotationEntry pat
-  getAnnotationEntry InvisPat{}     = NoEntryVal
+-- Note: Keep this section, for backport to GHC 9.10
 
-  setAnnotationAnchor (VisPat x pat) anc ts cs = VisPat x (setAnnotationAnchor pat anc ts cs)
-  setAnnotationAnchor a@(InvisPat _ _) _ _ _   = a
+-- instance ExactPrint (ArgPat GhcPs) where
+--   getAnnotationEntry (VisPat _ pat) = getAnnotationEntry pat
+--   getAnnotationEntry InvisPat{}     = NoEntryVal
 
-  exact (VisPat x pat) = do
-    pat' <- markAnnotated pat
-    pure (VisPat x pat')
+--   setAnnotationAnchor (VisPat x pat) anc ts cs = VisPat x (setAnnotationAnchor pat anc ts cs)
+--   setAnnotationAnchor a@(InvisPat _ _) _ _ _   = a
 
-  exact (InvisPat tokat tp) = do
-    tokat' <- markEpToken tokat
-    tp' <- markAnnotated tp
-    pure (InvisPat tokat' tp')
+--   exact (VisPat x pat) = do
+--     pat' <- markAnnotated pat
+--     pure (VisPat x pat')
+
+--   exact (InvisPat tokat tp) = do
+--     tokat' <- markEpToken tokat
+--     tp' <- markAnnotated tp
+--     pure (InvisPat tokat' tp')
 
 -- ---------------------------------------------------------------------
 

diff --git a/tests/Test.hs b/tests/Test.hs
@@ -144,14 +144,14 @@ mkTests = do
   -- prettyRoundTripTests <- findPrettyTests libdir
   return $ TestList [
                    --    internalTests,
-                      -- roundTripTests
+                   --    roundTripTests
                    -- ,
-                   --   (transformTests libdir)
+                     (transformTests libdir)
                    -- , (failingTests libdir)
                    -- ,
-                   --   roundTripBalanceCommentsTests
+                     -- roundTripBalanceCommentsTests
                    -- ,
-                     roundTripMakeDeltaTests
+                     -- roundTripMakeDeltaTests
                     ]
 
 -- Tests that are no longer needed
@@ -224,8 +224,8 @@ tt' = do
     -- mkParserTest libdir "ghc98" "T13343.hs"
     -- mkParserTestMD libdir "ghc98" "T13343.hs"
 
-    -- -- mkParserTest libdir "ghc710" "Arrows.hs"
-    -- mkParserTestMD libdir "ghc710" "Arrows.hs"
+    mkParserTest libdir "ghc710" "Warning.hs"
+    -- mkParserTestMD libdir "ghc710" "Warning.hs"
 
     -- mkParserTest libdir "ghc98" "MonoidsFD1.hs"
     -- mkParserTestBC libdir "ghc98" "MonoidsFD1.hs"
@@ -243,11 +243,15 @@ tt' = do
     -- mkParserTest libdir "ghc710" "DataFamilies.hs"
     -- mkParserTestMD libdir "ghc710" "DataFamilies.hs"
 
-    -- mkParserTest libdir "ghc710" "TypeBrackets.hs"
-    mkParserTestMD libdir "ghc710" "TypeBrackets.hs"
+    -- mkParserTest libdir "ghc80" "ForFree.hs"
+    -- mkParserTestMD libdir "ghc80" "ForFree.hs"
 
    -- Needs GHC changes
 
+    -- Epalocation needed in WarningTxt
+    -- mkParserTest libdir "ghc80" "DeprM.hs"
+    -- mkParserTestMD libdir "ghc80" "DeprM.hs"
+
 
     ]