diff options
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 52 |
1 files changed, 24 insertions, 28 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 16e9e00..b408570 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -92,6 +92,7 @@ import GHC ( DynFlags , unXRec , UnXRec + , GhcPass , XRec , LConDeclField , recordPatSynField @@ -137,6 +138,7 @@ import GHC , tcdName , collectHsBindBinders , getLoc + , getLocA -- , hsSigType , getConNames #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) @@ -203,8 +205,9 @@ 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) +import GHC.Parser.Lexer + ( ParseResult(POk) + , initParserState , unP ) -- import Module (Module(..)) @@ -233,6 +236,7 @@ import GHC.Types.Name import GHC.Types.Name.Occurrence (OccName) -- import Outputable (Outputable, ppr, showPpr, showSDoc) import GHC.Utils.Outputable (Outputable, ppr) +import GHC.Driver.Config (initParserOpts) import GHC.Driver.Ppr (showPpr, showSDoc) -- import PackageConfig (packageVersion) -- import Packages @@ -498,19 +502,11 @@ mbIdDetails _ = Nothing -- Syntax transformation -------------------------------------------------------------------------------- -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)] -#else -hsGroupVals :: HsGroup Name -> [GenLocated SrcSpan (HsBindLR Name Name)] -#endif +hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)] hsGroupVals hsGroup = - filter (isGoodSrcSpan . getLoc) $ + filter (isGoodSrcSpan . getLocA) $ case hs_valds hsGroup of -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) XValBindsLR (NValBinds binds _) -> concatMap (bagToList . snd) binds -#else - ValBindsOut binds _ -> concatMap (bagToList . snd) binds -#endif _ -> [] hsPatSynDetails :: HsPatSynDetails GhcRn -> [Name] @@ -626,7 +622,7 @@ lookupNameModuleAndPackage state currentPackageId name = then currentPackageId else HCE.PackageId (T.pack $ unitPackageNameString unitInfo) - (packageVersion unitInfo) + (unitPackageVersion unitInfo) in Right ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName , packageId) @@ -674,14 +670,14 @@ moduleLocationInfo flags unitState moduleNameMap currentPackageId compId moduleN 1 1 _ -> - case lookupModuleWithSuggestions flags moduleName Nothing of + case lookupModuleWithSuggestions unitState moduleName Nothing of LookupFound Module {moduleUnit = unitId} _ -> - case lookupUnitId unitState unitId of + case lookupUnit unitState unitId of Just unitInfo -> let packageId = HCE.PackageId (T.pack $ unitPackageNameString unitInfo) - (packageVersion unitInfo) + (unitPackageVersion unitInfo) in HCE.ApproximateLocation packageId (HCE.HaskellModuleName . T.pack . moduleNameString $ @@ -705,7 +701,7 @@ isDefinedInCurrentModule transformation file = in HCE.getHaskellFilePath file == modPath || (file `elem` includedFiles) nameLocationInfo :: - DynFlags + UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation @@ -715,14 +711,14 @@ nameLocationInfo :: -> Maybe SrcSpan -- ^ Only for wired-in names -> Name -> HCE.LocationInfo -nameLocationInfo flags currentPackageId compId transformation fileMap defSiteMap mbInstanceHead mbSrcSpan name +nameLocationInfo unitState currentPackageId compId transformation fileMap defSiteMap mbInstanceHead mbSrcSpan name | Just srcSpan <- realSrcSpan name mbSrcSpan = let filePath = HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ srcSpan approximateLocation = mkApproximateLocation - flags + unitState currentPackageId compId mbInstanceHead @@ -743,7 +739,7 @@ nameLocationInfo flags currentPackageId compId transformation fileMap defSiteMap either (const $ HCE.HaskellModuleName "") fst - (lookupNameModuleAndPackage flags currentPackageId name) + (lookupNameModuleAndPackage unitState currentPackageId name) in HCE.ExactLocation { packageId = currentPackageId , modulePath = modulePath @@ -779,20 +775,20 @@ nameLocationInfo flags currentPackageId compId transformation fileMap defSiteMap _ -> Nothing _ -> Nothing _ -> Nothing -nameLocationInfo flags currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name = - mkApproximateLocation flags currentPackageId compId mbInstanceHead name +nameLocationInfo unitState currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name = + mkApproximateLocation unitState currentPackageId compId mbInstanceHead name mkApproximateLocation :: - DynFlags + UnitState -> HCE.PackageId -> HCE.ComponentId -> Maybe T.Text -> Name -> HCE.LocationInfo -mkApproximateLocation flags currentPackageId compId mbInstanceHead name = +mkApproximateLocation unitState currentPackageId compId mbInstanceHead name = let haddockAnchor = Just . T.pack . makeAnchorId . T.unpack . nameToText $ name - in case lookupNameModuleAndPackage flags currentPackageId name of + in case lookupNameModuleAndPackage unitState currentPackageId name of Right (moduleName, packageId) -> HCE.ApproximateLocation { moduleName = moduleName @@ -1297,8 +1293,8 @@ sigNameNoLoc (InlineSig _ n _) = [unXRec @p n] sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @p) ns sigNameNoLoc _ = [] -clsInstDeclSrcSpan :: ClsInstDecl a -> SrcSpan -clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLoc (hsSigType ty) +clsInstDeclSrcSpan :: ClsInstDecl (GhcPass p) -> SrcSpan +clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLocA ty #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan "XClsinstdecl" #endif @@ -1323,7 +1319,7 @@ parseIdent :: DynFlags -> String -> Maybe RdrName parseIdent dflags str0 = let buffer = stringToStringBuffer str0 realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0 - pstate = mkPState dflags buffer realSrcLc + pstate = initParserState (initParserOpts dflags) buffer realSrcLc in case unP parseIdentifier pstate of POk _ name -> Just (unLoc name) _ -> Nothing |