Update to ghc-8.10.0.1

ndmitchell · Mar 28, 2020 · 500f2f0 · 500f2f0
1 parent def8433
commit 500f2f0
Show file tree

Hide file tree

Showing 40 changed files with 416 additions and 386 deletions.
diff --git a/hlint.cabal b/hlint.cabal
@@ -65,16 +65,26 @@ library
         extra >= 1.7.1,
         refact >= 0.3,
         aeson >= 1.1.2.0,
-        filepattern >= 0.1.1,
-        ghc-lib-parser-ex >= 8.8.6.0 && < 8.8.7
-    if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)
-        build-depends:
-          ghc == 8.8.*,
-          ghc-boot-th,
-          ghc-boot
+        filepattern >= 0.1.1
+
+    -- We currently target the 8.10 parse tree.
+    if !flag(ghc-lib) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0)
+      build-depends:
+        -- Not explicitly instructed to link ghc-lib-parser and we are
+        -- compiling with an 8.10 compiler so we link native ghc libraries.
+        ghc == 8.10.*,
+        ghc-boot-th,
+        ghc-boot
     else
-        build-depends:
-          ghc-lib-parser == 8.8.*
+      build-depends:
+        -- Either explicitly instructed to link ghc-lib-parser or we
+        -- are compiling with a non-8.10 compiler.
+          ghc-lib-parser == 8.10.*
+    build-depends:
+        -- Note : ghc-lib-parser-ex supports the ghc-lib flag too. If
+        -- you set that flag for hlint, be sure to set it consistently
+        -- for ghc-lib-parser-ex also.
+        ghc-lib-parser-ex >= 8.10.0.1 && < 8.10.1
 
     if flag(gpl)
         build-depends: hscolour >= 1.21

diff --git a/src/Apply.hs b/src/Apply.hs
@@ -15,7 +15,7 @@ import Data.Maybe
 import Data.Ord
 import Config.Type
 import Config.Haskell
-import HsSyn
+import GHC.Hs
 import qualified SrcLoc as GHC
 import qualified Data.HashSet as Set
 import Prelude

diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs
@@ -9,7 +9,7 @@ import GHC.Util
 import Config.Type
 import Fixity
 import Data.Generics.Uniplate.Data
-import HsSyn hiding (Warning)
+import GHC.Hs hiding (Warning)
 import RdrName
 import Name
 import Bag
@@ -51,30 +51,30 @@ findSetting x = []
 
 findBind :: HsBind GhcPs -> [Setting]
 findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs
-findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam NoExt fun_matches
+findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches
 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 _)}}]})
     = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
-    where ps = [occNameString $ occName $ unLoc x | XPat (L _ (VarPat _ x)) <- m_pats]
+    where ps = [occNameString $ occName $ unLoc 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 NoExt x $ noLoc $ HsPar NoExt $ noLoc $ HsApp NoExt y $ noLoc $ mkVar "_hlint"
+    HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ 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 NoExt (noLoc name) : map snd rep
+        rhs = apps' $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep
 
         rep = zip vs $ map (mkVar . pure) ['a'..]
         f (HsVar _ x) | Just y <- lookup (occNameString $ occName $ unLoc x) rep = y
-        f (OpApp _ x dol y) | isDol dol = HsApp NoExt x $ noLoc $ HsPar NoExt y
+        f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y
         f x = x
 
 
 mkVar :: String -> HsExpr GhcPs
-mkVar = HsVar NoExt . noLoc . Unqual . mkVarOcc
+mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc
diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs
@@ -16,11 +16,11 @@ import Prelude
 import GHC.Util
 
 import SrcLoc as GHC
-import HsExtension
-import HsDecls hiding (SpliceDecl)
-import HsExpr hiding (Match)
+import GHC.Hs.Extension
+import GHC.Hs.Decls hiding (SpliceDecl)
+import GHC.Hs.Expr hiding (Match)
+import GHC.Hs.Lit
 import FastString
-import HsLit
 import ApiAnnotation
 import OccName
 import Outputable

diff --git a/src/Config/Type.hs b/src/Config/Type.hs
@@ -10,7 +10,7 @@ import Data.List.Extra
 import Prelude
 
 
-import qualified HsSyn
+import qualified GHC.Hs
 import Fixity
 import GHC.Util
 import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
@@ -98,9 +98,9 @@ data HintRule = HintRule
     ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.
     ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates (GHC parse tree).
     -- We wrap these GHC elements in 'HsExtendInstances' in order that we may derive 'Show'.
-    ,hintRuleLHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ LHS (GHC parse tree).
-    ,hintRuleRHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ RHS (GHC parse tree).
-    ,hintRuleSide :: Maybe (HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs))  -- ^ Side condition (GHC parse tree).
+    ,hintRuleLHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ LHS (GHC parse tree).
+    ,hintRuleRHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ RHS (GHC parse tree).
+    ,hintRuleSide :: Maybe (HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs))  -- ^ Side condition (GHC parse tree).
     }
     deriving Show
 

diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs
@@ -29,10 +29,11 @@ import Data.Semigroup
 import Timing
 import Prelude
 
+import Bag
 import qualified Lexer as GHC
 import qualified ErrUtils
 import qualified Outputable
-import qualified HsSyn
+import GHC.Hs
 import SrcLoc
 import qualified RdrName as GHC
 import qualified OccName as GHC
@@ -66,13 +67,13 @@ data ConfigItem
 
 data Package = Package
     {packageName :: String
-    ,packageModules :: [HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs)]
+    ,packageModules :: [HsExtendInstances (LImportDecl GhcPs)]
     } deriving Show
 
 data Group = Group
     {groupName :: String
     ,groupEnabled :: Bool
-    ,groupImports :: [Either String (HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs))]
+    ,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
     ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty
     } deriving Show
 
@@ -165,9 +166,10 @@ parseGHC parser v = do
     x <- parseString v
     case parser defaultParseFlags{extensions=configExtensions} x of
         GHC.POk _ x -> pure x
-        GHC.PFailed _ loc err ->
-          let msg = Outputable.showSDoc baseDynFlags $
-                ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err)
+        GHC.PFailed ps ->
+          let (_, errs) = GHC.getMessages ps baseDynFlags
+              errMsg = head (bagToList errs)
+              msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg
           in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
 
 ---------------------------------------------------------------------
@@ -203,7 +205,7 @@ parsePackage v = do
 parseFixity :: Val -> Parser [Setting]
 parseFixity v = parseArray v >>= concatMapM (parseGHC parseDeclGhcWithMode >=> f)
     where
-        f (L _ (HsSyn.SigD _ (HsSyn.FixSig _ x))) = pure $ map Infix $ fromFixitySig x
+        f (L _ (SigD _ (FixSig _ x))) = pure $ map Infix $ fromFixitySig x
         f _ = parseFail v "Expected fixity declaration"
 
 parseSmell :: Val -> Parser [Setting]
@@ -275,8 +277,8 @@ parseWithin :: Val -> Parser [(String, String)] -- (module, decl)
 parseWithin v = do
     x <- parseGHC parseExpGhcWithMode v
     case x of
-        L _ (HsSyn.HsVar _ (L _ (GHC.Unqual x))) -> pure $ f "" (GHC.occNameString x)
-        L _ (HsSyn.HsVar _ (L _ (GHC.Qual mod x))) -> pure $ f (moduleNameString mod) (GHC.occNameString x)
+        L _ (HsVar _ (L _ (GHC.Unqual x))) -> pure $ f "" (GHC.occNameString x)
+        L _ (HsVar _ (L _ (GHC.Qual mod x))) -> pure $ f (moduleNameString mod) (GHC.occNameString x)
         _ -> parseFail v "Bad classification rule"
     where
         f mod name@(c:_) | isUpper c = [(mod,name),(mod ++ ['.' | mod /= ""] ++ name, "")]
@@ -290,15 +292,15 @@ parseSeverityKey v = do
         _ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s
 
 
-guessName :: HsSyn.LHsExpr HsSyn.GhcPs -> HsSyn.LHsExpr HsSyn.GhcPs -> String
+guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String
 guessName lhs rhs
     | n:_ <- rs \\ ls = "Use " ++ n
     | n:_ <- ls \\ rs = "Redundant " ++ n
     | otherwise = defaultHintName
     where
         (ls, rs) = both f (lhs, rhs)
-        f :: HsSyn.LHsExpr HsSyn.GhcPs -> [String]
-        f x = [y | L _ (HsSyn.HsVar _ (L _ x)) <- universe x, let y = GHC.occNameString $ GHC.rdrNameOcc x, not $ isUnifyVar y, y /= "."]
+        f :: LHsExpr GhcPs -> [String]
+        f x = [y | L _ (HsVar _ (L _ x)) <- universe x, let y = GHC.occNameString $ GHC.rdrNameOcc x, not $ isUnifyVar y, y /= "."]
 
 
 asNote :: String -> Note
@@ -328,8 +330,8 @@ settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f
             where
               scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports)
 
-asScope' :: Map.HashMap String [HsSyn.LImportDecl HsSyn.GhcPs] -> [Either String (HsSyn.LImportDecl HsSyn.GhcPs)] -> Scope
-asScope' packages xs = scopeCreate (HsSyn.HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)
+asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope
+asScope' packages xs = scopeCreate (HsModule 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/Fixity.hs b/src/Fixity.hs
@@ -7,8 +7,8 @@ module Fixity(
     ) where
 
 import GHC.Generics(Associativity(..))
-import HsBinds
-import HsExtension
+import GHC.Hs.Binds
+import GHC.Hs.Extension
 import OccName
 import RdrName
 import SrcLoc
@@ -50,7 +50,7 @@ fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)
       InfixN -> NotAssociative
 
 toFixitySig :: FixityInfo -> FixitySig GhcPs
-toFixitySig (toFixity -> (name, x)) = FixitySig noExt [noLoc $ mkRdrUnqual (mkVarOcc name)] x
+toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLoc $ mkRdrUnqual (mkVarOcc name)] x
 
 defaultFixities :: [FixityInfo]
 defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities

diff --git a/src/GHC/Util.hs b/src/GHC/Util.hs
@@ -38,17 +38,22 @@ import GHC.Util.Unify
 import qualified Language.Haskell.GhclibParserEx.Parse as GhclibParserEx
 import Language.Haskell.GhclibParserEx.GHC.Driver.Session (parsePragmasIntoDynFlags)
 
-import HsSyn
+import GHC.Hs
 import Lexer
 import SrcLoc
 import DynFlags
 import FastString
+import RdrHsSyn
 
 import System.FilePath
 import Language.Preprocessor.Unlit
 
 parseExpGhcLib :: String -> DynFlags -> ParseResult (LHsExpr GhcPs)
-parseExpGhcLib = GhclibParserEx.parseExpression
+parseExpGhcLib s flags =
+  case GhclibParserEx.parseExpression s flags of
+    POk s e ->
+       unP (runECP_P e >>= \e -> return e) s :: ParseResult (LHsExpr GhcPs)
+    PFailed ps -> PFailed ps
 
 parseImportGhcLib :: String -> DynFlags -> ParseResult (LImportDecl GhcPs)
 parseImportGhcLib = GhclibParserEx.parseImport

diff --git a/src/GHC/Util/Brackets.hs b/src/GHC/Util/Brackets.hs
@@ -3,7 +3,7 @@
 
 module GHC.Util.Brackets (Brackets'(..), isApp,isOpApp,isAnyApp) where
 
-import HsSyn
+import GHC.Hs
 import SrcLoc
 import BasicTypes
 import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
@@ -29,7 +29,7 @@ instance Brackets' (LHsExpr GhcPs) where
   remParen' (L _ (HsPar _ x)) = Just x
   remParen' _ = Nothing
 
-  addParen' e = noLoc $ HsPar noExt e
+  addParen' e = noLoc $ HsPar noExtField e
 
   isAtom' (L _ x) = case x of
       HsVar{} -> True
@@ -86,12 +86,12 @@ instance Brackets' (LHsExpr GhcPs) where
      | L _ HsPar{} <- parent = False
      | otherwise = True
 
-instance Brackets' (Pat GhcPs) where
-  remParen' (LL _ (ParPat _ x)) = Just x
+instance Brackets' (Located (Pat GhcPs)) where
+  remParen' (L _ (ParPat _ x)) = Just x
   remParen' _ = Nothing
-  addParen' e = noLoc $ ParPat noExt e
+  addParen' e = noLoc $ ParPat noExtField e
 
-  isAtom' (LL _ x) = case x of
+  isAtom' (L _ x) = case x of
     ParPat{} -> True
     TuplePat{} -> True
     ListPat{} -> True
@@ -117,14 +117,14 @@ instance Brackets' (Pat GhcPs) where
 
   needBracket' _ parent child
     | isAtom' child = False
-    | LL _ TuplePat{} <- parent = False
-    | LL _ ListPat{} <- parent = False
+    | L _ TuplePat{} <- parent = False
+    | L _ ListPat{} <- parent = False
     | otherwise = True
 
 instance Brackets' (LHsType GhcPs) where
   remParen' (L _ (HsParTy _ x)) = Just x
   remParen' _ = Nothing
-  addParen' e = noLoc $ HsParTy noExt e
+  addParen' e = noLoc $ HsParTy noExtField e
 
   isAtom' (L _ x) = case x of
       HsParTy{} -> True