Add support for NumericUnderscores extensions from CLI/config

Closes #1434

Author: friedbrice

.hlint.yaml

@@ -76,3 +76,6 @@
 - ignore: {name: Use const, within: Config.Yaml}
 # TEMPORARY: this lint is deleted on HEAD
 - ignore: {name: Use String}
+# We don't use NumericUnderscores, but hints aren't aware of which extensions
+# are restricted.
+- ignore: {name: Use underscore}

src/GHC/All.hs

@@ -6,7 +6,9 @@ module GHC.All(
     CppFlags(..), ParseFlags(..), defaultParseFlags,
     parseFlagsAddFixities, parseFlagsSetLanguage,
     ParseError(..), ModuleEx(..),
-    parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, firstDeclComments,
+    parseModuleEx, createModuleEx, createModuleExWithFixities,
+    createModuleExWithFixitiesAndExtensions, ghcComments, modComments,
+    firstDeclComments,
     parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
     ) where
 
@@ -89,8 +91,9 @@ data ParseError = ParseError
     }
 
 -- | Result of 'parseModuleEx', representing a parsed module.
-newtype ModuleEx = ModuleEx {
-    ghcModule :: Located (HsModule GhcPs)
+data ModuleEx = ModuleEx {
+    ghcModule :: Located (HsModule GhcPs),
+    configuredExtensions :: [Extension]
 }
 
 -- | Extract a complete list of all the comments in a module.
@@ -163,8 +166,14 @@ createModuleEx :: Located (HsModule GhcPs) -> ModuleEx
 createModuleEx = createModuleExWithFixities (map toFixity defaultFixities)
 
 createModuleExWithFixities :: [(String, Fixity)] -> Located (HsModule GhcPs) -> ModuleEx
-createModuleExWithFixities fixities ast =
-  ModuleEx (applyFixities (fixitiesFromModule ast ++ fixities) ast)
+createModuleExWithFixities = createModuleExWithFixitiesAndExtensions []
+
+-- | Create a 'ModuleEx' from a GHC module. Provide a list of custom operator
+-- fixities and a list of GHC extensions that should be used when parsing the module
+-- (if there are any extensions required other than those explicitly enabled in the module).
+createModuleExWithFixitiesAndExtensions :: [Extension] -> [(String, Fixity)] -> Located (HsModule GhcPs) -> ModuleEx
+createModuleExWithFixitiesAndExtensions extensions fixities ast =
+  ModuleEx (applyFixities (fixitiesFromModule ast ++ fixities) ast) extensions
 
 impliedEnables :: Extension -> [Extension]
 impliedEnables ext = case Data.List.lookup ext extensionImplications of
@@ -214,7 +223,7 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
         ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList errs
       else do
         let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
-        pure $ ModuleEx (applyFixities fixes a)
+        pure $ ModuleEx (applyFixities fixes a) (enabledExtensions flags)
     PFailed s ->
       ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList . bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)
   where

src/Hint/Duplicate.hs

@@ -57,7 +57,7 @@ duplicateHint ms =
          ]
     where
       ds = [(modName m, fromMaybe "" (declName d), unLoc d)
-           | ModuleEx m <- map snd ms
+           | ModuleEx m _ <- map snd ms
            , d <- hsmodDecls (unLoc m)]
 
 dupes :: (Outputable e, Data e) => [(String, String, [LocatedA e])] -> [Idea]

src/Hint/Export.hs

@@ -21,7 +21,7 @@ import GHC.Types.Name.Occurrence
 import GHC.Types.Name.Reader
 
 exportHint :: ModuHint
-exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) )
+exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)
   | Nothing <- exports =
       let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents (Nothing, noAnn) name)] )} in
       [(ignore "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]

src/Hint/NumLiteral.hs

@@ -2,7 +2,7 @@
     Suggest the usage of underscore when NumericUnderscores is enabled.
 
 <TEST>
-123456
+123456 -- @Suggestion 123_456 @NoRefactor
 {-# LANGUAGE NumericUnderscores #-} \
 1234
 {-# LANGUAGE NumericUnderscores #-} \
@@ -21,43 +21,58 @@
 
 module Hint.NumLiteral (numLiteralHint) where
 
+import GHC.All (configuredExtensions)
 import GHC.Hs
 import GHC.Data.FastString
 import GHC.LanguageExtensions.Type (Extension (..))
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
 import GHC.Util.ApiAnnotation (extensions)
 import Data.Char (isDigit, isOctDigit, isHexDigit)
+import Data.Foldable (toList)
 import Data.List (intercalate)
 import Data.Set (union)
 import Data.Generics.Uniplate.DataOnly (universeBi)
 import Refact.Types
 
 import Hint.Type (DeclHint, toSSA, modComments, firstDeclComments)
-import Idea (Idea, suggest)
+import Idea (Idea(..), Note(..), suggest)
 
 numLiteralHint :: DeclHint
 numLiteralHint _ modu =
-  -- Comments appearing without an empty line before the first
-  -- declaration in a module are now associated with the declaration
-  -- not the module so to be safe, look also at `firstDeclComments
-  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
-  let exts = union (extensions (modComments modu)) (extensions (firstDeclComments modu)) in
-  if NumericUnderscores `elem` exts then
+  -- TODO: there's a subtle bug when the module disables `NumericUnderscores`.
+  -- This seems pathological, though, because who would enable it for their
+  -- project but disable it in specific files?
+  if NumericUnderscores `elem` activeExtensions then
      concatMap suggestUnderscore . universeBi
   else
      const []
+  where
+    -- Comments appearing without an empty line before the first
+    -- declaration in a module are now associated with the declaration
+    -- not the module so to be safe, look also at `firstDeclComments
+    -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
+    moduleExtensions = extensions (modComments modu) `union` extensions (firstDeclComments modu)
+    activeExtensions = configuredExtensions modu <> toList moduleExtensions
 
 suggestUnderscore :: LHsExpr GhcPs -> [Idea]
 suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _))))) =
-  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ]
+  [ (suggest "Use underscore" (reLoc x) (reLoc y) [r])
+      { ideaNote = [ RequiresExtension "NumericUnderscores" ]
+      }
+  | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt
+  ]
   where
     underscoredSrcTxt = addUnderscore (unpackFS srcTxt)
     y :: LocatedAn NoEpAnns (HsExpr GhcPs)
     y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}}
     r = Replace Expr (toSSA x) [("a", toSSA y)] "a"
 suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _))))) =
-  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ]
+  [ (suggest "Use underscore" (reLoc x) (reLoc y) [r])
+      { ideaNote = [ RequiresExtension "NumericUnderscores" ]
+      }
+  | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt
+  ]
   where
     underscoredSrcTxt = addUnderscore (unpackFS srcTxt)
     y :: LocatedAn NoEpAnns (HsExpr GhcPs)

src/Hint/Unsafe.hs

@@ -46,7 +46,7 @@ import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
 -- @
 -- is. We advise that such constants should have a @NOINLINE@ pragma.
 unsafeHint :: DeclHint
-unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) ->
+unsafeHint _ (ModuleEx (L _ m) _) = \ld@(L loc d) ->
   [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" (locA loc)
          (unsafePrettyPrint d)
          (Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)

src/Language/Haskell/HLint.hs

@@ -24,7 +24,7 @@ module Language.Haskell.HLint(
     -- * Hints
     Hint,
     -- * Modules
-    ModuleEx, parseModuleEx, createModuleEx, createModuleExWithFixities, ParseError(..),
+    ModuleEx, parseModuleEx, createModuleEx, createModuleExWithFixities, createModuleExWithFixitiesAndExtensions, ParseError(..),
     -- * Parse flags
     defaultParseFlags,
     ParseFlags(..), CppFlags(..), FixityInfo,