GHC 9.12 compat

Author: sol

.github/workflows/build.yml

@@ -28,9 +28,10 @@ jobs:
           - '9.6'
           - '9.8'
           - '9.10'
+          - 'latest'
         include:
           - os: macos-latest
-            ghc: '9.10'
+            ghc: system
     steps:
       - uses: actions/checkout@v4
       - uses: hspec/setup-haskell@v1
@@ -52,7 +53,7 @@ jobs:
           name: ${{ steps.archive.outputs.name }}
           path: ${{ steps.archive.outputs.name }}
           compression-level: 0
-        if: matrix.ghc == '9.10'
+        if: matrix.ghc == 'latest'
 
       - shell: bash
         run: |
@@ -61,7 +62,7 @@ jobs:
             ghcup install ghc $GHC --no-set
             SENSEI_GHC=ghc-$GHC $(cabal list-bin spec)
           done
-        if: matrix.ghc == '9.10'
+        if: matrix.ghc == 'latest'
 
   success:
     needs: build

src/GHC/Diagnostic.hs

@@ -11,13 +11,14 @@ module GHC.Diagnostic (
 , apply
 
 #ifdef TEST
+, analyzeHint
 , extractIdentifiers
 , qualifiedName
 , applyReplace
 #endif
 ) where
 
-import           Imports hiding (stripPrefix)
+import           Imports hiding (stripPrefix, takeExtensions)
 import           Builder (Builder, Color(..))
 import qualified Builder
 
@@ -75,8 +76,10 @@ analyzeHints = concat . mapMaybe analyzeHint
 
 analyzeHint :: Text -> Maybe [Solution]
 analyzeHint hint = asum [
-    prefix "Perhaps you intended to use " <&> return . EnableExtension
-  , prefix "Enable any of the following extensions: " <&> map EnableExtension . reverse . T.splitOn ", "
+    prefix "Perhaps you intended to use " <&> takeExtensions
+
+  , requiredFor GHC_910 $ prefix "Enable any of the following extensions: " <&>
+      map EnableExtension . reverse . T.splitOn ", "
 
   , prefix "Perhaps use `" <&> return . takeIdentifier
   , prefix "Perhaps use one of these:" <&> extractIdentifiers
@@ -85,6 +88,21 @@ analyzeHint hint = asum [
     prefix :: Text -> Maybe Text
     prefix p = stripPrefix p hint
 
+    takeExtensions :: Text -> [Solution]
+    takeExtensions input = fromMaybe takeExtensionGhc910 takeExtensionGhc912
+      where
+        takeExtensionGhc910 :: [Solution]
+        takeExtensionGhc910 = requiredFor GHC_910 [EnableExtension input]
+
+        takeExtensionGhc912 :: Maybe [Solution]
+        takeExtensionGhc912 = map EnableExtension <$> do
+          T.stripPrefix "the `" input <&> T.span (/= '\'') >>= \ case
+            (extension, "' extension") -> Just [extension]
+            (implied, impliedBy -> Just extension) -> Just [implied, extension]
+            _ -> Nothing
+          where
+            impliedBy = T.stripPrefix "' extension (implied by `" >=> T.stripSuffix "')"
+
     takeIdentifier :: Text -> Solution
     takeIdentifier = UseName . T.takeWhile (/= '\'')
 

src/GHC/Diagnostic/Type.hs

@@ -4,6 +4,7 @@ module GHC.Diagnostic.Type (
 , Span(..)
 , Location(..)
 , Severity(..)
+, Reason(..)
 , parse
 , format
 ) where
@@ -23,6 +24,7 @@ data Diagnostic = Diagnostic {
 , code :: Maybe Int
 , message :: [Text]
 , hints :: [Text]
+, reason :: Maybe Reason
 } deriving (Eq, Show, Generic, ToJSON, FromJSON)
 
 data Span = Span {
@@ -39,6 +41,27 @@ data Location = Location {
 data Severity = Warning | Error
   deriving (Eq, Show, Generic, ToJSON, FromJSON)
 
+data Reason = ReasonFlags Flags | ReasonCategory Category
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Reason where
+  toJSON = \ case
+    ReasonFlags value -> toJSON value
+    ReasonCategory value -> toJSON value
+
+instance FromJSON Reason where
+  parseJSON value =
+        ReasonFlags <$> parseJSON value
+    <|> ReasonCategory <$> parseJSON value
+
+data Flags = Flags {
+  flags :: [String]
+} deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+data Category = Category {
+  category :: String
+} deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
 parse :: ByteString -> Maybe Diagnostic
 parse = fmap removeGhciSpecificHints . decode . fromStrict
 
@@ -50,7 +73,7 @@ format diagnostic = render $ unlines [
   ]
   where
     header :: Doc
-    header = span <> colon <+> severity <> colon <+> code
+    header = span <> colon <+> severity <> colon <+> code <+> reason
 
     span :: Doc
     span = case diagnostic.span of
@@ -67,6 +90,24 @@ format diagnostic = render $ unlines [
       Nothing -> empty
       Just c -> brackets $ "GHC-" <> int c
 
+    reason :: Doc
+    reason = case diagnostic.reason of
+      Nothing -> empty
+      Just r -> bracketed . concatMap formatFlag $ case r of
+        ReasonFlags (Flags flags) -> flags
+        ReasonCategory (Category category) -> [category]
+        where
+          formatFlag :: String -> [Doc]
+          formatFlag (text -> flag) =
+            "-W" <> flag : case diagnostic.severity of
+              Warning -> []
+              Error -> [errorFlag <> flag]
+
+          errorFlag :: Doc
+          errorFlag = case r of
+            ReasonFlags {} -> "Werror="
+            ReasonCategory {} -> "-Werror="
+
     message :: Doc
     message = bulleted $ map verbatim diagnostic.message
 
@@ -91,6 +132,12 @@ format diagnostic = render $ unlines [
     unlines :: [Doc] -> Doc
     unlines = foldr ($+$) empty
 
+    bracketed :: [Doc] -> Doc
+    bracketed xs = "[" <> punctuateComma xs <> "]"
+
+    punctuateComma :: [Doc] -> Doc
+    punctuateComma = hcat . punctuate (text ", ")
+
 removeGhciSpecificHints :: Diagnostic -> Diagnostic
 removeGhciSpecificHints diagnostic = diagnostic { hints = map processHint diagnostic.hints }
   where

src/Imports.hs

@@ -132,3 +132,16 @@ that = \ case
 
 atomicReadIORef :: IORef a -> IO a
 atomicReadIORef ref = atomicModifyIORef' ref (id &&& id)
+
+data GHC =
+    ANY
+  | GHC_904
+  | GHC_906
+  | GHC_908
+  | GHC_910
+  | GHC_912
+  deriving (Eq, Ord, Bounded)
+
+requiredFor :: GHC -> a -> a
+requiredFor _ = id
+{-# INLINE requiredFor #-}

test/GHC/DiagnosticSpec.hs

@@ -17,11 +17,9 @@ import           Language.Haskell.GhciWrapper (lookupGhc)
 import           GHC.Diagnostic
 import           GHC.Diagnostic.Annotated
 
-data Requirement = NoRequirement | RequireGhc912
-
 test, ftest, xtest :: HasCallStack => FilePath -> [String] -> String -> Maybe Annotation -> [Solution] -> Spec
 
-test name = testWith name NoRequirement
+test name = testWith name minBound
 
 ftest name args code annotation = focus . test name args code annotation
 
@@ -33,20 +31,22 @@ _ignore = let _ = (ftest, xtest) in ()
 normalizeGhcVersion :: String -> String
 normalizeGhcVersion = T.unpack . T.replace __GLASGOW_HASKELL_FULL_VERSION__ "9.10.0" . T.pack
 
-testWith :: HasCallStack => FilePath -> Requirement -> [String] -> String -> Maybe Annotation -> [Solution] -> Spec
-testWith name requirement extraArgs (unindent -> code) annotation solutions = it name do
+testWith :: HasCallStack => FilePath -> GHC -> [String] -> String -> Maybe Annotation -> [Solution] -> Spec
+testWith name requiredVersion extraArgs (unindent -> code) annotation solutions = it name do
   unless (T.null code) do
     ensureFile src $ T.encodeUtf8 code
   err <- translate <$> ghc ["-fno-diagnostics-show-caret"]
   json <- ghc ["-fdiagnostics-as-json", "--interactive", "-ignore-dot-ghci"]
   ensureFile (dir </> "err.out") (encodeUtf8 err)
   ensureFile (dir </> "err.json") (encodeUtf8 $ normalizeGhcVersion json)
-  Hspec.annotate (separator <> err <> separator) do
-    Just annotated <- return . parseAnnotated availableImports $ encodeUtf8 json
-    when shouldRun do
-      format annotated.diagnostic `shouldBe` err
-    annotated.annotation `shouldBe` annotation
-    annotated.solutions `shouldBe` solutions
+  case parseAnnotated availableImports $ encodeUtf8 json of
+    Nothing -> do
+      expectationFailure $ "Parsing JSON failed:\n\n" <> json
+    Just annotated -> Hspec.annotate (separator <> err <> separator) do
+      whenGhc requiredVersion do
+        format annotated.diagnostic `shouldBe` err
+      annotated.annotation `shouldBe` annotation
+      annotated.solutions `shouldBe` solutions
   where
     separator :: String
     separator = replicate 30 '*' <> "\n"
@@ -59,7 +59,7 @@ testWith name requirement extraArgs (unindent -> code) annotation solutions = it
 
     ghc :: [String] -> IO String
     ghc args = do
-      requireGhc [9,10]
+      require GHC_910
       bin <- lookupGhc <$> getEnvironment
       let
         process :: CreateProcess
@@ -73,16 +73,6 @@ testWith name requirement extraArgs (unindent -> code) annotation solutions = it
       '’' -> '\''
       c -> c
 
-    shouldRun :: Bool
-    shouldRun = case requirement of
-      NoRequirement -> True
-      RequireGhc912 ->
-#if __GLASGOW_HASKELL__ < 912
-        False
-#else
-        True
-#endif
-
 availableImports :: AvailableImports
 availableImports = Map.fromList [
     ("c2w", ["Data.ByteString.Internal"])
@@ -147,11 +137,26 @@ spec = do
       foo = [|23|~]
       |] Nothing [EnableExtension "TemplateHaskellQuotes", EnableExtension "TemplateHaskell"]
 
-    testWith "redundant-import" RequireGhc912 ["-Wall", "-Werror"] [r|
+    testWith "redundant-import" GHC_912 ["-Wall"] [r|
       module Foo where
       import Data.Maybe
       |] redundantImport [RemoveImport]
 
+    testWith "redundant-import-error" GHC_912 ["-Wall", "-Werror"] [r|
+      module Foo where
+      import Data.Maybe
+      |] redundantImport [RemoveImport]
+
+    testWith "x-partial" GHC_912 [] [r|
+      module Foo where
+      foo = head
+      |] Nothing []
+
+    testWith "x-partial-error" GHC_912 ["-Werror"] [r|
+      module Foo where
+      foo = head
+      |] Nothing []
+
     test "non-existing" [] [r|
       |] Nothing []
 
@@ -173,6 +178,30 @@ spec = do
       foo = "foo" + 23
       |] Nothing []
 
+  describe "analyzeHint" do
+    it "detects missing extension" do
+      let
+        inputs :: [Text]
+        inputs = [
+            requiredFor GHC_910 "Perhaps you intended to use BlockArguments"
+          , requiredFor GHC_912 "Perhaps you intended to use the `BlockArguments' extension"
+          ]
+      for_ inputs \ input -> analyzeHint input `shouldBe` Just [
+          EnableExtension "BlockArguments"
+        ]
+
+    it "detects missing extensions" do
+      let
+        inputs :: [Text]
+        inputs = [
+            requiredFor GHC_910 "Enable any of the following extensions: TemplateHaskell, TemplateHaskellQuotes"
+          , requiredFor GHC_912 "Perhaps you intended to use the `TemplateHaskellQuotes' extension (implied by `TemplateHaskell')"
+          ]
+      for_ inputs \ input -> analyzeHint input `shouldBe` Just [
+          EnableExtension "TemplateHaskellQuotes"
+        , EnableExtension "TemplateHaskell"
+        ]
+
   describe "extractIdentifiers" do
     it "extracts identifiers" do
       extractIdentifiers ".. `foldl' ..., `foldr' .." `shouldBe` [UseName "foldl", UseName "foldr"]

test/Helper.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 module Helper (
   module Imports
@@ -26,11 +25,13 @@ module Helper (
 , Location(..)
 , Severity(..)
 , diagnostic
+, diagnosticForGhc
 
 , to_json
 
-, requireGhc
+, require
 , ifGhc
+, whenGhc
 
 , ensureFile
 ) where
@@ -140,22 +141,39 @@ failingSpec = unlines [
 diagnostic :: Diagnostic
 diagnostic = Diagnostic {
   version = "1.0"
-, ghcVersion = "ghc-" <> __GLASGOW_HASKELL_FULL_VERSION__
+, ghcVersion = "ghc-9.10.0"
 , span = Nothing
 , severity = Error
 , code = Nothing
 , message = []
 , hints = []
+, reason = Nothing
 }
 
+diagnosticForGhc :: IO Diagnostic
+diagnosticForGhc = do
+  ghc <- getGhcVersion
+  let
+    version :: String
+    version
+      | ghc <= makeVersion [9,12] = "1.0"
+      | otherwise = "1.1"
+  return diagnostic {
+    version
+  , ghcVersion = "ghc-" <> showVersion ghc
+  }
+
 to_json :: ToJSON a => a -> ByteString
 to_json = toStrict . encode
 
-requireGhc :: [Int] -> IO ()
-requireGhc = ifGhc >=> (`unless` pending)
+require :: GHC -> IO ()
+require = ifGhc >=> (`unless` pending)
+
+whenGhc :: GHC -> IO () -> IO ()
+whenGhc required action = ifGhc required >>= (`when` action)
 
-ifGhc :: [Int] -> IO Bool
-ifGhc (makeVersion -> required) = do
+ifGhc :: GHC -> IO Bool
+ifGhc (toVersion -> required) = do
   ghcVersion <- getGhcVersion
   return (ghcVersion >= required)
 
@@ -165,6 +183,15 @@ getGhcVersion = do
   let Just ghcVersion = lookupGhcVersion env >>= parseVersion
   return ghcVersion
 
+toVersion :: GHC -> Version
+toVersion = makeVersion . \ case
+  ANY -> [0]
+  GHC_904 -> [9,4]
+  GHC_906 -> [9,6]
+  GHC_908 -> [9,8]
+  GHC_910 -> [9,10]
+  GHC_912 -> [9,12]
+
 ensureFile :: FilePath -> ByteString -> IO ()
 ensureFile name new = do
   createDirectoryIfMissing True $ takeDirectory name