From 69b26125f171df845de1f9d8029cd5a81da9592e Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Mon, 16 May 2022 16:30:24 +1000 Subject: porting to ghc9.2.2: fixing ghcutils --- haskell-code-explorer.cabal | 1 + src/HaskellCodeExplorer/GhcUtils.hs | 235 +++++++++++++++++++++--------------- 2 files changed, 141 insertions(+), 95 deletions(-) diff --git a/haskell-code-explorer.cabal b/haskell-code-explorer.cabal index ba96f89..06cb5c8 100644 --- a/haskell-code-explorer.cabal +++ b/haskell-code-explorer.cabal @@ -28,6 +28,7 @@ library , blaze-html , deepseq , bytestring + , Cabal , cabal-helper , cereal , containers diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 0f3ff1c..2a40213 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -57,8 +57,10 @@ module HaskellCodeExplorer.GhcUtils , hsDocsToDocH , subordinateNamesWithDocs ) where -import Bag (bagToList) -import ConLike (ConLike(..)) +-- import Bag (bagToList) +import GHC.Data.Bag (bagToList) +-- import ConLike (ConLike(..)) +import GHC.Core.ConLike (ConLike(..)) import qualified Data.ByteString as BS import Data.Hashable (Hashable,hash) import qualified Data.ByteString.Internal as BSI @@ -71,14 +73,17 @@ import qualified Data.HashMap.Strict as HM import qualified Data.List as L import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Text as T -import DataCon (dataConWorkId, flSelector) +-- import DataCon (dataConWorkId, flSelector) +import GHC.Core.DataCon (dataConWorkId, flSelector) import Documentation.Haddock.Parser (overIdentifier, parseParas) import Documentation.Haddock.Types (DocH(..), Header(..), _doc ) -import DynFlags () -import FastString (mkFastString, unpackFS) +-- import DynFlags () +import GHC.Driver.Session (DynFlags) +-- import FastString (mkFastString, unpackFS) +import GHC.Data.FastString (mkFastString, unpackFS) import GHC ( DynFlags #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) @@ -121,13 +126,13 @@ import GHC , tcdName , collectHsBindBinders , getLoc - , hsSigType +-- , hsSigType , getConNames #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) , NHsValBindsLR(..) - , getConArgs +-- , getConArgs , unpackHDS - , NoExt(..) +-- , NoExt(..) , extFieldOcc #else , getConDetails @@ -153,36 +158,47 @@ import GHC , srcSpanEndCol , isExternalName , moduleNameString - , recordPatSynSelectorId +-- , recordPatSynSelectorId , recordPatSynPatVar , isGoodSrcSpan , isLocalId , isDataFamilyDecl , tyFamInstDeclName , idType - , hsib_body +-- , hsib_body #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) #else , tfe_pats #endif , tfid_eqn #if MIN_VERSION_ghc(8,8,0) - , dL - , HasSrcSpan - , SrcSpanLess +-- , dL +-- , HasSrcSpan +-- , SrcSpanLess #endif ) import qualified HaskellCodeExplorer.Types as HCE -import HscTypes (TypeEnv, lookupTypeEnv) +-- import HscTypes (TypeEnv, lookupTypeEnv) +import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -import HsExtension (GhcRn,IdP) -#endif -import IdInfo (IdDetails(..)) -import InstEnv (ClsInst(..)) -import Lexer (ParseResult(POk), mkPState, unP) -import Module (Module(..)) -import Name +-- import HsExtension (GhcRn,IdP) +import GHC.Hs.Extension (GhcRn) +import Language.Haskell.Syntax.Extension (IdP) +#endif +-- import IdInfo (IdDetails(..)) +import GHC.Types.Id.Info (IdDetails(..)) +-- import InstEnv (ClsInst(..)) +import GHC.Core.InstEnv (ClsInst(..)) +-- import GHC.Parser.Lexer (ParseResult(POk), mkPState, unP) +import GHC.Parser.Lexer ( + ParseResult(POk) + , unP + ) +-- import Module (Module(..)) +import GHC.Unit.Types (Module(..)) +-- import Name +import GHC.Types.Name ( isDataConNameSpace , isDerivedOccName , isInternalName @@ -201,63 +217,84 @@ import Name , occNameString , wiredInNameTyThing_maybe ) -import OccName (OccName) -import Outputable (Outputable, ppr, showPpr, showSDoc) -import PackageConfig (packageVersion) -import Packages +-- import OccName (OccName) +import GHC.Types.Name.Occurrence (OccName) +-- import Outputable (Outputable, ppr, showPpr, showSDoc) +import GHC.Utils.Outputable (Outputable, ppr) +import GHC.Driver.Ppr (showPpr, showSDoc) +-- import PackageConfig (packageVersion) +-- import Packages +import Distribution.Package (packageVersion) +import GHC.Unit.State ( LookupResult(..) , lookupModuleWithSuggestions - , lookupPackage - , packageNameString +-- , lookupPackage +-- , packageNameString ) -import Pair (pSnd) -import Parser (parseIdentifier) -import PatSyn (PatSyn, patSynMatcher, patSynSig) +-- import Pair (pSnd) +import GHC.Data.Pair (pSnd) +-- import Parser (parseIdentifier) +import GHC.Parser (parseIdentifier) +-- import PatSyn (PatSyn, patSynMatcher, patSynSig) +import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig) import Prelude hiding (id, span) -import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName) -import RnEnv (dataTcOccs) -import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc) -import StringBuffer (StringBuffer(..), stringToStringBuffer) +-- import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName) +import GHC.Types.Name.Reader (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName) +-- import RnEnv (dataTcOccs) +import GHC.Rename.Env (dataTcOccs) +-- import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc) +import GHC.Types.SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc) +-- import StringBuffer (StringBuffer(..), stringToStringBuffer) +import GHC.Data.StringBuffer (StringBuffer(..), stringToStringBuffer) import System.FilePath (normalise) -import TcEvidence (HsWrapper(..), tcCoercionKind) -import TcType (evVarPred) -import TyCoRep (Type(..), -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - ArgFlag(..) -#else - VisibilityFlag(..) -#endif +-- import TcEvidence (HsWrapper(..), tcCoercionKind) +import GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind) +-- import TcType (evVarPred) +import GHC.Tc.Utils.TcType (evVarPred) +import GHC.Core.TyCo.Rep (Type(..), + + ArgFlag(..), mkVisFunTysMany + + + ) -import TyCon (tyConName) -import Type +-- import TyCon (tyConName) +import GHC.Core.TyCon (tyConName) +-- import Type +import GHC.Core.Type ( coreView , expandTypeSynonyms , mkForAllTy , mkFunTy - , mkFunTys - , mkInvForAllTys -#if !MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - , mkNamedBinder -#endif +-- , mkFunTys +-- , mkInvForAllTys + + + , piResultTy - , pprSigmaType , splitFunTy_maybe - , tidyOpenType + , tidyOpenType, mkVisForAllTys ) +import GHC.Core.TyCo.Ppr (pprSigmaType) #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -import ToIface -import IfaceType -#endif -import TysWiredIn (unitTy) -import UniqSet (emptyUniqSet, unionUniqSets, +import GHC.CoreToIface +-- import IfaceType +import GHC.Iface.Type +#endif +-- import TysWiredIn (unitTy) +import GHC.Builtin.Types (unitTy) +-- import UniqSet (emptyUniqSet, unionUniqSets, +import GHC.Types.Unique.Set (emptyUniqSet, unionUniqSets, #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) nonDetEltsUniqSet #else uniqSetToList #endif ) -import Unique (getKey) -import Var +-- import Unique (getKey) +import GHC.Types.Unique (getKey) +-- import Var +import GHC.Types.Var ( idDetails , isId , mkTyVar @@ -266,13 +303,16 @@ import Var , varType , varUnique ) -import VarEnv (TidyEnv) -import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet +-- import VarEnv (TidyEnv) +import GHC.Types.Var.Env (TidyEnv) +-- import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet +import GHC.Types.Var.Set (VarSet, emptyVarSet, unionVarSet, unitVarSet #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) #else ,varSetElems #endif ) +import GHC.Unit -------------------------------------------------------------------------------- -- Pretty-printing @@ -302,18 +342,18 @@ instanceDeclToText flags decl = T.append "instance " (toText flags cid_poly_ty) #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - DataFamInstD _ di -> - let args = - T.intercalate " " . map (toText flags) . feqn_pats . hsib_body . dfid_eqn $ di - in T.concat - ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args] - TyFamInstD _ ti -> - let args = - T.intercalate " " . - map (toText flags) . feqn_pats . hsib_body . tfid_eqn $ - ti - in T.concat - ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] + DataFamInstD _ di -> "" + -- let args = + -- T.intercalate " " . map (toText flags) . feqn_pats . hsib_body . dfid_eqn $ di + -- in T.concat + -- ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args] + -- TyFamInstD _ ti -> + -- let args = + -- T.intercalate " " . + -- map (toText flags) . feqn_pats . hsib_body . tfid_eqn $ + -- ti + -- in T.concat + -- ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] #elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) DataFamInstD di -> let args = @@ -464,9 +504,10 @@ hsPatSynDetails patDetails = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) case patDetails of InfixCon name1 name2 -> [name1, name2] - PrefixCon fields -> fields + PrefixCon _ fields -> fields RecCon fields -> concatMap - (\field -> [recordPatSynSelectorId field, recordPatSynPatVar field]) + (\field -> [-- recordPatSynSelectorId field, + recordPatSynPatVar field]) fields #else case patDetails of @@ -481,7 +522,7 @@ hsPatSynDetails patDetails = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) unwrapName :: LIEWrappedName a -> Located a -unwrapName = ieLWrappedName +unwrapName = undefined #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) unwrapName :: LIEWrappedName Name -> Located Name unwrapName = ieLWrappedName @@ -498,11 +539,10 @@ ieLocNames :: IE Name -> [Located Name] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) ieLocNames (XIE _) = [] -ieLocNames (IEVar _ n) = +ieLocNames (IEVar _ n) = [] #else -ieLocNames (IEVar n) = +ieLocNames (IEVar n) = [unwrapName n] #endif - [unwrapName n] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) ieLocNames (IEThingAbs _ n) = #else @@ -515,12 +555,16 @@ ieLocNames (IEThingAll _ n) = ieLocNames (IEThingAll n) = #endif [unwrapName n] -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,1,0) +ieLocNames (IEThingWith _ n _ ns) = + unwrapName n : (map unwrapName ns) +#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) ieLocNames (IEThingWith _ n _ ns labels) = + unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels) #else ieLocNames (IEThingWith n _ ns labels) = -#endif unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels) +#endif ieLocNames IEModuleContents {} = [] ieLocNames IEGroup {} = [] ieLocNames IEDoc {} = [] @@ -558,7 +602,7 @@ lookupNameModuleAndPackage flags currentPackageId name = then currentPackageId else HCE.PackageId (T.pack $ packageNameString packageConfig) - (PackageConfig.packageVersion packageConfig) + (packageVersion packageConfig) in Right ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName , packageId) @@ -606,13 +650,13 @@ moduleLocationInfo flags moduleNameMap currentPackageId compId moduleName = 1 _ -> case lookupModuleWithSuggestions flags moduleName Nothing of - LookupFound Module {moduleUnitId = unitId} _ -> + LookupFound Module {moduleUnit = unitId} _ -> case lookupPackage flags unitId of Just packInfo -> let packageId = HCE.PackageId (T.pack $ packageNameString packInfo) - (PackageConfig.packageVersion packInfo) + (packageVersion packInfo) in HCE.ApproximateLocation packageId (HCE.HaskellModuleName . T.pack . moduleNameString $ @@ -700,13 +744,13 @@ nameLocationInfo flags currentPackageId compId transformation fileMap defSiteMap realSrcSpan :: Name -> Maybe SrcSpan -> Maybe RealSrcSpan realSrcSpan n mbSpan = case nameSrcSpan n of - RealSrcSpan span -> Just span + RealSrcSpan span _ -> Just span _ | isWiredInName n -> case mbSpan of Just span -> case span of - RealSrcSpan s -> Just s + RealSrcSpan s _ -> Just s _ -> Nothing _ -> Nothing _ -> Nothing @@ -828,7 +872,7 @@ lookupNameDocumentation name defSiteMap = _ -> lookupDoc HCE.types srcSpanToFilePath :: SrcSpan -> Maybe HCE.HaskellFilePath -srcSpanToFilePath (RealSrcSpan s) = +srcSpanToFilePath (RealSrcSpan s _) = Just . HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s srcSpanToFilePath (UnhelpfulSpan _) = Nothing @@ -836,7 +880,7 @@ srcSpanToLineAndColNumbers :: HCE.SourceCodeTransformation -> SrcSpan -> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int)) -srcSpanToLineAndColNumbers transformation (RealSrcSpan s) = +srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) = let filePath = HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s eitherStart = @@ -880,9 +924,10 @@ patSynId patSyn = | otherwise = reqTheta -- required => provided => arg_1 -> ... -> arg_n -> res patSynTy = - mkInvForAllTys univTvs $ - mkFunTys reqTheta' $ - mkInvForAllTys exTvs $ mkFunTys provTheta $ mkFunTys argTys resTy + mkVisForAllTys univTvs $ + mkVisFunTysMany reqTheta' $ + mkVisForAllTys exTvs $ mkVisFunTysMany provTheta $ + mkVisFunTysMany argTys resTy in flip setVarType patSynTy . fst . patSynMatcher $ patSyn applyWrapper :: HsWrapper -> Type -> Type @@ -1408,10 +1453,10 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r isLegal '.' = True isLegal c = isAscii c && isAlphaNum c -#if MIN_VERSION_ghc(8,8,0) -ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) -ghcDL = GHC.dL -#else +-- #if MIN_VERSION_ghc(8,8,0) +-- ghcDL :: GHC.RealSrcSpan a => a -> GHC.Located (GHC.SrcSpan a) +-- ghcDL = GHC.dL +-- #else ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x -#endif +-- #endif -- cgit v1.2.3