Convert to ghc-9.2.1

ndmitchell · Nov 22, 2021 · 738c8c9 · 738c8c9
1 parent 8e10b51
commit 738c8c9
Show file tree

Hide file tree

Showing 42 changed files with 641 additions and 582 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -12,7 +12,7 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc: ['9.0', '8.10', '8.8']
+        ghc: ['9.2', '9.0', '8.10']
         include:
         - os: windows-latest
         - os: macOS-latest

diff --git a/hints.md b/hints.md
@@ -639,7 +639,7 @@ foo = bar (\x -> case x of Y z -> z)
 <br>
 Found:
 <code>
-\ x -> case x of { Y z -> z }
+\ x -> case x of Y z -> z
 </code>
 <br>
 Suggestion:
@@ -958,7 +958,7 @@ foo = case f v of _ -> x
 <br>
 Found:
 <code>
-case f v of { _ -> x }
+case f v of _ -> x
 </code>
 <br>
 Suggestion:

diff --git a/hlint.cabal b/hlint.cabal
@@ -76,16 +76,16 @@ library
         aeson >= 1.1.2.0,
         filepattern >= 0.1.1
 
-    if !flag(ghc-lib) && impl(ghc >= 9.0.0) && impl(ghc < 9.1.0)
+    if !flag(ghc-lib) && impl(ghc >= 9.2.0) && impl(ghc < 9.3.0)
       build-depends:
-        ghc == 9.0.*,
+        ghc == 9.2.*,
         ghc-boot-th,
         ghc-boot
     else
       build-depends:
-          ghc-lib-parser == 9.0.*
+          ghc-lib-parser == 9.2.*
     build-depends:
-        ghc-lib-parser-ex >= 9.0.0.4 && < 9.0.1
+        ghc-lib-parser-ex >= 9.2.0.1 && < 9.2.1
 
     if flag(gpl)
         build-depends: hscolour >= 1.21

diff --git a/src/Apply.hs b/src/Apply.hs
@@ -72,7 +72,7 @@ applyHintsReal settings hints_ ms = concat $
 removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea
 removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x}
     where
-        exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas $ ghcAnnotations m
+        exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas (comments (hsmodAnn (unLoc . ghcModule $ m)))
         keep (RequiresExtension x) = not $ x `Set.member` exts
         keep _ = True
 
@@ -90,10 +90,18 @@ parseModuleApply flags s file src = do
       Left (ParseError sl msg ctxt) ->
             pure $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error (adjustMessage msg) sl ctxt Nothing []
     where
+
         -- important the message has "Parse error:" as the prefix so "--ignore=Parse error" works
         -- try and tidy up things like "parse error (mismatched brackets)" to not look silly
         adjustMessage :: String -> String
-        adjustMessage x = "Parse error: " ++ dropBrackets (dropPrefix "parse error " x)
+        adjustMessage x =
+          "Parse error: " ++
+          dropBrackets (
+            case stripInfix "parse error " x of
+              Nothing -> x
+              Just (prefix, _) ->
+                dropPrefix (prefix ++ "parse error ") x
+          )
 
         dropBrackets ('(':xs) | Just (xs,')') <- unsnoc xs = xs
         dropBrackets xs = xs

diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs
@@ -43,7 +43,7 @@ renderSetting (Infix x) =
     ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)]
 renderSetting _ = []
 
-findSetting :: LHsDecl GhcPs -> [Setting]
+findSetting :: LocatedA (HsDecl GhcPs) -> [Setting]
 findSetting (L _ (ValD _ x)) = findBind x
 findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
     concatMap (findBind . unLoc) $ bagToList cid_binds
@@ -57,26 +57,26 @@ findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtF
 findBind _ = []
 
 findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
-findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]})
+findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
     = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
     where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats]
 findExp name vs HsLam{} = []
 findExp name vs HsVar{} = []
 findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
-    HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint"
+    HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint"
 
 findExp name vs bod = [SettingMatchExp $
         HintRule Warning defaultHintName []
         mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing]
     where
-        lhs = fromParen $ noLoc $ transform f bod
-        rhs = apps $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep
+        lhs = fromParen $ noLocA $ transform f bod
+        rhs = apps $ map noLocA $ HsVar noExtField (noLocA name) : map snd rep
 
         rep = zip vs $ map (mkVar . pure) ['a'..]
         f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y
-        f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y
+        f (OpApp _ x dol y) | isDol dol = HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed y
         f x = x
 
 
 mkVar :: String -> HsExpr GhcPs
-mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc
+mkVar = HsVar noExtField . noLocA . Unqual . mkVarOcc
diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs
@@ -37,6 +37,7 @@ readPragma (HsAnnotation _ _ provenance expr) = f expr
             TypeAnnProvenance (L _ x) -> occNameStr x
             ModuleAnnProvenance -> ""
 
+        f :: LocatedA (HsExpr GhcPs) -> Maybe Classify
         f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s =
                 case getSeverity a of
                     Nothing -> errorOn expr "bad classify pragma"
@@ -46,8 +47,8 @@ readPragma (HsAnnotation _ _ provenance expr) = f expr
         f (L _ (ExprWithTySig _ x _)) = f x
         f _ = Nothing
 
-readComment :: Located AnnotationComment -> [Classify]
-readComment c@(L pos AnnBlockComment{})
+readComment :: LEpaComment -> [Classify]
+readComment c@(L pos (EpaComment EpaBlockComment{} _))
     | (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x
     , x <- trim x
     , (hlint, x) <- word1 x
@@ -73,15 +74,15 @@ readComment c@(L pos AnnBlockComment{})
 readComment _ = []
 
 
-errorOn :: Outputable a => Located a -> String -> b
+errorOn :: Outputable a => LocatedA a -> String -> b
 errorOn (L pos val) msg = exitMessageImpure $
-    showSrcSpan pos ++
+    showSrcSpan (locA pos) ++
     ": Error while reading hint file, " ++ msg ++ "\n" ++
     unsafePrettyPrint val
 
-errorOnComment :: Located AnnotationComment -> String -> b
+errorOnComment :: LEpaComment -> String -> b
 errorOnComment c@(L s _) msg = exitMessageImpure $
     let isMultiline = isCommentMultiline c in
-    showSrcSpan s ++
+    showSrcSpan (RealSrcSpan (anchor s) Nothing) ++
     ": Error while reading hint file, " ++ msg ++ "\n" ++
     (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs
@@ -8,6 +8,8 @@ module Config.Yaml(
     settingsFromConfigYaml
     ) where
 
+import GHC.Driver.Ppr
+import GHC.Parser.Errors.Ppr
 import Config.Type
 import Data.Either
 import Data.Maybe
@@ -31,7 +33,6 @@ import Prelude
 import GHC.Data.Bag
 import GHC.Parser.Lexer
 import GHC.Utils.Error hiding (Severity)
-import GHC.Utils.Outputable
 import GHC.Hs
 import GHC.Types.SrcLoc
 import GHC.Types.Name.Reader
@@ -203,9 +204,8 @@ parseGHC parser v = do
     case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of
         POk _ x -> pure x
         PFailed ps ->
-          let (_, errs) = getMessages ps baseDynFlags
-              errMsg = head (bagToList errs)
-              msg = GHC.Utils.Outputable.showSDoc baseDynFlags $ GHC.Utils.Error.pprLocErrMsg errMsg
+          let errMsg = pprError . head . bagToList . snd $ getMessages ps
+              msg = showSDoc baseDynFlags $ pprLocMsgEnvelope errMsg
           in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
 
 ---------------------------------------------------------------------
@@ -383,8 +383,8 @@ settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f
             where
               scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports)
 
-asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope
-asScope' packages xs = scopeCreate (HsModule NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing)
+asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope
+asScope' packages xs = scopeCreate (HsModule EpAnnNotUsed NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing)
     where
         f (Right x) = [x]
         f (Left x) | Just pkg <- Map.lookup x packages = pkg

diff --git a/src/Extension.hs b/src/Extension.hs
@@ -17,6 +17,9 @@ badExtensions =
   , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break
   , {- DoRec , -} RecursiveDo -- breaks rec
   , LexicalNegation -- changes '-', see https://github.com/ndmitchell/hlint/issues/1230
+  -- These next two change syntax significantly and must be opt-in.
+  , OverloadedRecordDot
+  , OverloadedRecordUpdate
   ]
 
 reallyBadExtensions =

diff --git a/src/Fixity.hs b/src/Fixity.hs
@@ -11,8 +11,10 @@ import GHC.Hs.Binds
 import GHC.Hs.Extension
 import GHC.Types.Name.Occurrence
 import GHC.Types.Name.Reader
-import GHC.Types.SrcLoc
-import GHC.Types.Basic
+import GHC.Types.Fixity
+import GHC.Types.SourceText
+import GHC.Parser.Annotation
+import Language.Haskell.Syntax.Extension
 import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
 import Language.Haskell.GhclibParserEx.Fixity
 
@@ -50,7 +52,7 @@ fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)
       InfixN -> NotAssociative
 
 toFixitySig :: FixityInfo -> FixitySig GhcPs
-toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLoc $ mkRdrUnqual (mkVarOcc name)] x
+toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLocA $ mkRdrUnqual (mkVarOcc name)] x
 
 defaultFixities :: [FixityInfo]
 defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities

diff --git a/src/GHC/All.hs b/src/GHC/All.hs
@@ -5,32 +5,33 @@ module GHC.All(
     CppFlags(..), ParseFlags(..), defaultParseFlags,
     parseFlagsAddFixities, parseFlagsSetLanguage,
     ParseError(..), ModuleEx(..),
-    parseModuleEx, createModuleEx, ghcComments,
+    parseModuleEx, createModuleEx, ghcComments, modComments,
     parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
     ) where
 
+import GHC.Driver.Ppr
 import Control.Monad.Trans.Except
 import Control.Monad.IO.Class
 import Util
 import Data.Char
 import Data.List.Extra
 import Timing
 import Language.Preprocessor.Cpphs
-import qualified Data.Map as Map
 import System.IO.Extra
 import Fixity
 import Extension
 import GHC.Data.FastString
 
 import GHC.Hs
 import GHC.Types.SrcLoc
+import GHC.Types.Fixity
 import GHC.Utils.Error
-import GHC.Utils.Outputable
 import GHC.Parser.Lexer hiding (context)
 import GHC.LanguageExtensions.Type
-import GHC.Parser.Annotation
 import GHC.Driver.Session hiding (extensions)
+import GHC.Parser.Errors.Ppr
 import GHC.Data.Bag
+import Data.Generics.Uniplate.DataOnly
 
 import Language.Haskell.GhclibParserEx.GHC.Parser
 import Language.Haskell.GhclibParserEx.Fixity
@@ -83,43 +84,37 @@ data ParseError = ParseError
     }
 
 -- | Result of 'parseModuleEx', representing a parsed module.
-data ModuleEx = ModuleEx {
+newtype ModuleEx = ModuleEx {
     ghcModule :: Located HsModule
-  , ghcAnnotations :: ApiAnns
 }
 
--- | Extract a list of all of a parsed module's comments.
-ghcComments :: ModuleEx -> [Located AnnotationComment]
-ghcComments m =
-  map realToLoc $
-    concat (Map.elems $ apiAnnComments (ghcAnnotations m)) ++
-      apiAnnRogueComments (ghcAnnotations m)
-   where
-     -- TODO (2020-10-03, SF): This utility is repeated in
-     -- ApiAnnotation.hs. Consider doing something in
-     -- ghc-lib-parser-ex to clean this up.
-     realToLoc :: RealLocated a -> Located a
-     realToLoc (L r x) = L (RealSrcSpan r Nothing) x
+-- | Extract a complete list of all the comments in a module.
+ghcComments :: ModuleEx -> [LEpaComment]
+ghcComments = universeBi . ghcModule
+
+-- | Extract just the list of a modules' leading comments (pragmas).
+modComments :: ModuleEx -> EpAnnComments
+modComments = comments . hsmodAnn . unLoc . ghcModule
 
 -- | The error handler invoked when GHC parsing has failed.
 ghcFailOpParseModuleEx :: String
                        -> FilePath
                        -> String
-                       -> (SrcSpan, GHC.Utils.Error.MsgDoc)
+                       -> (SrcSpan, SDoc)
                        -> IO (Either ParseError ModuleEx)
 ghcFailOpParseModuleEx ppstr file str (loc, err) = do
    let pe = case loc of
             RealSrcSpan r _ -> context (srcSpanStartLine r) ppstr
             _ -> ""
-       msg = GHC.Utils.Outputable.showSDoc baseDynFlags err
+       msg = GHC.Driver.Ppr.showSDoc baseDynFlags err
    pure $ Left $ ParseError loc msg pe
 
 -- GHC extensions to enable/disable given HSE parse flags.
 ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
 ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)
 
 -- GHC fixities given HSE parse flags.
-ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]
+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Types.Fixity.Fixity)]
 ghcFixitiesFromParseFlags = map toFixity . fixities
 
 -- These next two functions get called frorm 'Config/Yaml.hs' for user
@@ -149,12 +144,12 @@ parseDeclGhcWithMode parseMode s =
     POk pst a -> POk pst $ applyFixities fixities a
     f@PFailed{} -> f
 
--- | Create a 'ModuleEx' from GHC annotations and module tree. It
--- is assumed the incoming parse module has not been adjusted to
--- account for operator fixities (it uses the HLint default fixities).
-createModuleEx :: ApiAnns -> Located HsModule -> ModuleEx
-createModuleEx anns ast =
-  ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns
+-- | Create a 'ModuleEx' from a GHC module. It is assumed the incoming
+-- parsed module has not been adjusted to account for operator
+-- fixities (it uses the HLint default fixities).
+createModuleEx :: Located HsModule -> ModuleEx
+createModuleEx ast =
+  ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast)
 
 -- | Parse a Haskell module. Applies the C pre processor, and uses
 -- best-guess fixity resolution if there are ambiguities.  The
@@ -185,20 +180,14 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
   -- Done with pragmas. Proceed to parsing.
   case fileToModule file str dynFlags of
     POk s a -> do
-      let errs = bagToList . snd $ getMessages s dynFlags
+      let errs = bagToList . snd $ getMessages s
       if not $ null errs then
         ExceptT $ parseFailureErr dynFlags str file str errs
       else do
-        let anns = ApiAnns {
-              apiAnnItems = Map.fromListWith (++) $ annotations s
-            , apiAnnEofPos = Nothing
-            , apiAnnComments = Map.fromListWith (++) $ annotations_comments s
-            , apiAnnRogueComments = comment_q s
-            }
         let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
-        pure $ ModuleEx (applyFixities fixes a) anns
+        pure $ ModuleEx (applyFixities fixes a)
     PFailed s ->
-      ExceptT $ parseFailureErr dynFlags str file str $  bagToList . snd $ getMessages s dynFlags
+      ExceptT $ parseFailureErr dynFlags str file str $  bagToList . snd $ getMessages s
   where
     -- If parsing pragmas fails, synthesize a parse error from the
     -- error message.
@@ -207,11 +196,9 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
       in ParseError (mkSrcSpan loc loc) msg src
 
     parseFailureErr dynFlags ppstr file str errs =
-      let errMsg = head errs
+      let errMsg = pprError (head errs)
           loc = errMsgSpan errMsg
-          style = mkErrStyle (errMsgContext errMsg)
-          ctx = initSDocContext dynFlags style
-          doc = formatErrDoc ctx (errMsgDoc errMsg)
+          doc = pprLocMsgEnvelope errMsg
       in ghcFailOpParseModuleEx ppstr file str (loc, doc)
 
 -- | Given a line number, and some source code, put bird ticks around the appropriate bit.