From 08cd4c8be065ab1cf2dd672409035e47199bb2e6 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Fri, 3 Jun 2022 18:39:41 +1000 Subject: fixing moduleinfo --- src/HaskellCodeExplorer/ModuleInfo.hs | 96 ++++++++++++++++++++--------------- 1 file changed, 54 insertions(+), 42 deletions(-) diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs index fd8f61a..8942e6f 100644 --- a/src/HaskellCodeExplorer/ModuleInfo.hs +++ b/src/HaskellCodeExplorer/ModuleInfo.hs @@ -25,17 +25,15 @@ import qualified Data.IntMap.Strict as IM import qualified Data.IntervalMap.Strict as IVM import qualified Data.List as L hiding (span) import Data.Maybe (fromMaybe, mapMaybe) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -import HsExtension (GhcRn) -#endif +import GHC.Hs.Extension (GhcRn) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Text.Lazy (toStrict) import Documentation.Haddock.Types (DocH) -import DynFlags(DynFlags) import GHC ( GenLocated(..) + , DynFlags , ModSummary , ModuleInfo , ModuleName @@ -55,18 +53,20 @@ import GHC , tm_internals_ , tm_typechecked_source , unLoc + , LHsDecl ) -import Type(expandTypeSynonyms) -import TyCon (isFamInstTyCon,tyConName) +import GHC.Parser.Annotation (sortLocatedA, getLocA) +import GHC.Core.Type(expandTypeSynonyms) +import GHC.Core.TyCon (isFamInstTyCon,tyConName) import HaskellCodeExplorer.AST.RenamedSource import HaskellCodeExplorer.AST.TypecheckedSource import HaskellCodeExplorer.GhcUtils import HaskellCodeExplorer.Preprocessor (createSourceCodeTransformation) import qualified HaskellCodeExplorer.Types as HCE #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -import HsBinds (HsBindLR) +import GHC.Hs.Binds (HsBindLR) #endif -import HsDecls +import GHC.Hs.Decls ( ForeignDecl(..) , HsDecl(..) , HsGroup(..) @@ -82,37 +82,45 @@ import HsDecls , hsGroupInstDecls #endif ) -import HsDoc(HsDocString) -import HsImpExp (IE(..), ImportDecl(..)) -import HsUtils(collectHsBindBinders) -import HscTypes +import GHC.Hs.Doc(HsDocString) +import GHC.Hs.ImpExp (IE(..), ImportDecl(..)) +import GHC.Hs.Utils(collectHsBindBinders) +import GHC.Unit.State (UnitState) +import GHC.Unit.Module.ModDetails + ( md_types + ) +import GHC.Unit.External ( ExternalPackageState - , HomePackageTable - , TypeEnv , eps_PTE , eps_inst_env + ) +import GHC.Unit.Home.ModInfo + ( HomePackageTable , hm_details - , md_types - , mkTypeEnv - , typeEnvElts ) -import InstEnv (InstEnvs(..), is_dfun) -import Module(Module(..)) -import Name (Name, OccName, getSrcSpan, nameOccName, nameSrcSpan, nameUnique) +import GHC.Core.InstEnv (InstEnvs(..), is_dfun) +import GHC.Unit.Module + ( Module(..) + ) +import GHC.Unit.Types + ( GenModule(..) + ) +import GHC.Types.Name (Name, OccName, getSrcSpan, nameOccName, nameSrcSpan, nameUnique) import Prelude hiding(id,span) -import RdrName(GlobalRdrEnv) -import SrcLoc (isOneLineSpan) -import TcRnTypes (tcVisibleOrphanMods, tcg_inst_env, tcg_rdr_env, tcg_type_env) +import GHC.Types.TypeEnv + ( TypeEnv + , typeEnvElts + , mkTypeEnv + ) +import GHC.Types.Name.Reader (GlobalRdrEnv) +import GHC.Types.SrcLoc (isOneLineSpan) +import GHC.Tc.Types (tcVisibleOrphanMods, tcg_inst_env, tcg_rdr_env, tcg_type_env) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -import UniqDFM (eltsUDFM) -#else -import UniqFM (eltsUFM) -#endif -import Unique (getKey) -import Var (varName, varType,Id) -import VarEnv (emptyTidyEnv) +import GHC.Types.Unique.DFM (eltsUDFM) +import GHC.Types.Unique (getKey) +import GHC.Types.Var (varName, varType,Id) +import GHC.Types.Var.Env (emptyTidyEnv) type ModuleDependencies = ( HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath @@ -121,6 +129,7 @@ type ModuleDependencies type ModuleGhcData = ( DynFlags + , UnitState , TypecheckedModule , HomePackageTable , ExternalPackageState @@ -134,7 +143,7 @@ createModuleInfo :: -> HCE.ComponentId -- ^ Current build component id -> (T.Text, HCE.SourceCodePreprocessing) -- ^ Source code -> (HCE.ModuleInfo, ModuleDependencies, [TypeError]) -createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, typecheckedModule, homePackageTable, externalPackageState, modSum) modulePath currentPackageId compId (originalSourceCode, sourceCodePreprocessing) = +createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, unitState, typecheckedModule, homePackageTable, externalPackageState, modSum) modulePath currentPackageId compId (originalSourceCode, sourceCodePreprocessing) = let globalRdrEnv = tcg_rdr_env . fst . tm_internals_ $ typecheckedModule modInfo = moduleInfo typecheckedModule (Just (hsGroup, _, _, _)) = renamedSource typecheckedModule @@ -179,6 +188,7 @@ createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, typecheckedModule, (defSites, allNames) = createDefinitionSiteMap flags + unitState currentPackageId compId defSiteMap @@ -201,6 +211,7 @@ createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, typecheckedModule, environment = Environment { envDynFlags = flags + , envUnitState = unitState , envInstEnv = instEnv , envTypeEnv = typeEnv , envTransformation = transformation @@ -308,6 +319,7 @@ prepareSourceCode sourceCodePreprocessing originalSourceCode modSum modulePath = createDefinitionSiteMap :: DynFlags + -> UnitState -> HCE.PackageId -> HCE.ComponentId -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap @@ -322,12 +334,10 @@ createDefinitionSiteMap :: -> HsGroup Name #endif -> (HCE.DefinitionSiteMap, [Name]) -createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup = +createDefinitionSiteMap flags unitState currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup = let -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - allDecls :: [GenLocated SrcSpan (HsDecl GhcRn)] -#endif - allDecls = L.sortOn getLoc . ungroup $ hsGroup + allDecls :: [LHsDecl GhcRn] + allDecls = sortLocatedA . ungroup $ hsGroup (instanceDeclsWithDocs, valueAndTypeDeclsWithDocs) = L.partition (\(L _ decl, _) -> @@ -355,7 +365,7 @@ createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalR nameLocation :: Maybe SrcSpan -> Name -> HCE.LocationInfo nameLocation = nameLocationInfo - flags + unitState currentPackageId compId transformation @@ -377,7 +387,7 @@ createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalR (\clsInst -> ( instanceToText flags clsInst , let location = - nameLocation Nothing (Var.varName . is_dfun $ clsInst) + nameLocation Nothing (varName . is_dfun $ clsInst) in case M.lookup (getSrcSpan clsInst) instanceDocMap of Just hsDocString -> HCE.DefinitionSite @@ -391,13 +401,15 @@ createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalR -------------------------------------------------------------------------------- mainDeclNamesWithDocumentation = concatMap - (\(L span decl, docs) -> map (, docs, span) $ getMainDeclBinder decl) + (\dec@(L _ decl, docs) -> + map (, docs, getLocA dec) $ getMainDeclBinder decl) valueAndTypeDeclsWithDocs dataFamTyConsWithoutDocs = map (\name -> (name, [], nameSrcSpan name)) dataFamTyCons allNamesWithDocumentation = mainDeclNamesWithDocumentation ++ - subordinateNamesWithDocs allDecls ++ dataFamTyConsWithoutDocs + subordinateNamesWithDocs allDecls ++ + dataFamTyConsWithoutDocs (valuesWithDocumentation, typesWithDocumentation) = L.partition (\(name, _doc, _srcSpan) -> @@ -687,7 +699,7 @@ addIdentifierToMaps environment idSrcSpanMap idMaps@(idInfoMap, idOccMap) nameOc Just (identifier, mbTypes) -> let name = fromMaybe - (Var.varName identifier) + (varName identifier) (unLoc $ locatedName nameOcc) identifierType = varType identifier identifierTypeExpanded = expandTypeSynonyms identifierType -- cgit v1.2.3