diff options
Diffstat (limited to 'src/HaskellCodeExplorer/ModuleInfo.hs')
| -rw-r--r-- | src/HaskellCodeExplorer/ModuleInfo.hs | 1307 |
1 files changed, 665 insertions, 642 deletions
diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs index 6f5c9b5..5aeb6bd 100644 --- a/src/HaskellCodeExplorer/ModuleInfo.hs +++ b/src/HaskellCodeExplorer/ModuleInfo.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -14,306 +13,344 @@ module HaskellCodeExplorer.ModuleInfo , ModuleDependencies ) where -import qualified Data.Generics.Uniplate.Data as U -import Control.Monad.State.Strict (execState,evalState,get,put,State) -import qualified Data.Aeson as Aeson -import Data.Aeson.Text(encodeToLazyText) -import qualified Data.Vector as V -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as M -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) -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 GHC - ( GenLocated(..) - , DynFlags - , LHsBindLR - , ModSummary - , ModuleInfo - , ModuleName - , SrcSpan - , TyThing(..) - , Type - , TypecheckedModule - , getLoc - , isGoodSrcSpan - , modInfoExportsWithSelectors - , modInfoInstances - , moduleInfo - , moduleNameString - , ms_hspp_buf - , ms_mod - , renamedSource - , tm_internals_ - , tm_typechecked_source - , unLoc - , LHsDecl - ) -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 -import GHC.Hs.Decls - ( ForeignDecl(..) - , HsDecl(..) - , HsGroup(..) - , LInstDecl - , LForeignDecl - , LTyClDecl - , InstDecl(..) - , group_tyclds - , tyClDeclLName - , tcdName - , hsGroupInstDecls - ) -import GHC.Hs.Doc(HsDocString) -import GHC.Hs.ImpExp (IE(..), ImportDecl(..)) -import GHC.Hs.Utils - ( collectHsBindBinders - , CollectFlag(..) - ) -import GHC.Unit.State (UnitState) -import GHC.Unit.Module.ModDetails - ( md_types - ) -import GHC.Unit.External - ( ExternalPackageState - , eps_PTE - , eps_inst_env - ) -import GHC.Unit.Home.ModInfo - ( HomePackageTable - , hm_details - ) -import GHC.Core.InstEnv (InstEnvs(..), is_dfun) -import GHC.Unit.Types - ( GenModule(..) - ) -import GHC.Types.Name (Name, OccName, getSrcSpan, nameOccName, nameSrcSpan, nameUnique) -import Prelude hiding(id,span) -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 -import GHC.Types.Unique.DFM (eltsUDFM) -import GHC.Types.Unique (getKey) -import GHC.Types.Var (varName, varType,Id) -import GHC.Types.Var.Env (emptyTidyEnv) +import Control.Monad.State.Strict ( State + , evalState + , execState + , get + , put + ) +import qualified Data.Aeson as Aeson +import Data.Aeson.Text ( encodeToLazyText ) +import qualified Data.Generics.Uniplate.Data as U +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap.Strict as IM +import qualified Data.IntervalMap.Strict as IVM +import qualified Data.List as L + hiding ( span ) +import qualified Data.Map.Strict as M +import Data.Maybe ( fromMaybe + , mapMaybe + ) +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 qualified Data.Vector as V +import Documentation.Haddock.Types ( DocH ) +import GHC ( DynFlags + , GenLocated(..) + , LHsBindLR + , LHsDecl + , ModSummary + , ModuleInfo + , ModuleName + , SrcSpan + , TyThing(..) + , Type + , TypecheckedModule + , getLoc + , isGoodSrcSpan + , modInfoExportsWithSelectors + , modInfoInstances + , moduleInfo + , moduleNameString + , ms_hspp_buf + , ms_mod + , renamedSource + , tm_internals_ + , tm_typechecked_source + , unLoc + ) +import GHC.Core.InstEnv ( InstEnvs(..) + , is_dfun + ) +import GHC.Core.TyCon ( isFamInstTyCon + , tyConName + ) +import GHC.Core.Type ( expandTypeSynonyms ) +import GHC.Hs.Decls ( ForeignDecl(..) + , HsDecl(..) + , HsGroup(..) + , InstDecl(..) + , LForeignDecl + , LInstDecl + , LTyClDecl + , group_tyclds + , hsGroupInstDecls + , tcdName + , tyClDeclLName + ) +import GHC.Hs.Doc ( HsDocString ) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Hs.ImpExp ( IE(..) + , ImportDecl(..) + ) +import GHC.Hs.Utils ( CollectFlag(..) + , collectHsBindBinders + ) +import GHC.Parser.Annotation ( getLocA + , sortLocatedA + ) +import GHC.Tc.Types ( tcVisibleOrphanMods + , tcg_inst_env + , tcg_rdr_env + , tcg_type_env + ) +import GHC.Types.Name ( Name + , OccName + , getSrcSpan + , nameOccName + , nameSrcSpan + , nameUnique + ) +import GHC.Types.Name.Reader ( GlobalRdrEnv ) +import GHC.Types.SrcLoc ( isOneLineSpan ) +import GHC.Types.TypeEnv ( TypeEnv + , mkTypeEnv + , typeEnvElts + ) +import GHC.Types.Unique ( getKey ) +import GHC.Types.Unique.DFM ( eltsUDFM ) +import GHC.Types.Var ( Id + , varName + , varType + ) +import GHC.Types.Var.Env ( emptyTidyEnv ) +import GHC.Unit.External ( ExternalPackageState + , eps_PTE + , eps_inst_env + ) +import GHC.Unit.Home.ModInfo ( HomePackageTable + , hm_details + ) +import GHC.Unit.Module.ModDetails ( md_types ) +import GHC.Unit.State ( UnitState ) +import GHC.Unit.Types ( GenModule(..) ) +import HaskellCodeExplorer.AST.RenamedSource +import HaskellCodeExplorer.AST.TypecheckedSource +import HaskellCodeExplorer.GhcUtils +import HaskellCodeExplorer.Preprocessor + ( createSourceCodeTransformation + ) +import qualified HaskellCodeExplorer.Types as HCE +import Prelude hiding ( id + , span + ) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A type ModuleDependencies - = ( HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath - , HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap - , HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)) + = ( HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath + , HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap + , HM.HashMap + HCE.HaskellModuleName + (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) + ) type ModuleGhcData - = ( DynFlags - , UnitState - , TypecheckedModule - , HomePackageTable - , ExternalPackageState - , ModSummary) + = ( DynFlags + , UnitState + , TypecheckedModule + , HomePackageTable + , ExternalPackageState + , ModSummary + ) -createModuleInfo :: - ModuleDependencies -- ^ Modules that have already been indexed +createModuleInfo + :: ModuleDependencies -- ^ Modules that have already been indexed -> ModuleGhcData -- ^ Data types from GHC -> HCE.HaskellModulePath -- ^ Current module path -> HCE.PackageId -- ^ Current package id -> HCE.ComponentId -- ^ Current build component id -> (T.Text, HCE.SourceCodePreprocessing) -- ^ Source code -> (HCE.ModuleInfo, ModuleDependencies, [TypeError]) -createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, unitState, typecheckedModule, homePackageTable, externalPackageState, modSum) modulePath currentPackageId compId (originalSourceCode, sourceCodePreprocessing) = - let globalRdrEnv = tcg_rdr_env . fst . tm_internals_ $ typecheckedModule +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 exportedNamesSet = S.fromList $ modInfoExportsWithSelectors modInfo -------------------------------------------------------------------------------- -- Preprocessed source -------------------------------------------------------------------------------- - (transformation, sourceCode') = - prepareSourceCode - sourceCodePreprocessing - originalSourceCode - modSum - modulePath - includedFiles = HM.keys $ HCE.fileIndex transformation + (transformation, sourceCode') = prepareSourceCode + sourceCodePreprocessing + originalSourceCode + modSum + modulePath + includedFiles = HM.keys $ HCE.fileIndex transformation -------------------------------------------------------------------------------- -- Type environment -------------------------------------------------------------------------------- - (tcGblEnv, _) = tm_internals_ typecheckedModule + (tcGblEnv, _) = tm_internals_ typecheckedModule currentModuleTyThings = typeEnvElts $ tcg_type_env tcGblEnv - homePackageTyThings = - concatMap (typeEnvElts . md_types . hm_details) $ -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - eltsUDFM homePackageTable -#else - eltsUFM homePackageTable -#endif + homePackageTyThings = concatMap (typeEnvElts . md_types . hm_details) + $ eltsUDFM homePackageTable externalPackagesTyThings = typeEnvElts $ eps_PTE externalPackageState - typeEnv = - mkTypeEnv - (currentModuleTyThings ++ - homePackageTyThings ++ externalPackagesTyThings) + typeEnv = mkTypeEnv + ( currentModuleTyThings + ++ homePackageTyThings + ++ externalPackagesTyThings + ) -------------------------------------------------------------------------------- -- Exported entities -------------------------------------------------------------------------------- - dataFamTyCons = - mapMaybe - (\case - ATyCon tc - | isFamInstTyCon tc -> Just $ tyConName tc - _ -> Nothing) - currentModuleTyThings - (defSites, allNames) = - createDefinitionSiteMap - flags - unitState - currentPackageId - compId - defSiteMap - fileMap - globalRdrEnv - transformation - modInfo - dataFamTyCons - hsGroup + dataFamTyCons = mapMaybe + (\case + ATyCon tc | isFamInstTyCon tc -> Just $ tyConName tc + _ -> Nothing + ) + currentModuleTyThings + (defSites, allNames) = createDefinitionSiteMap flags + unitState + currentPackageId + compId + defSiteMap + fileMap + globalRdrEnv + transformation + modInfo + dataFamTyCons + hsGroup -------------------------------------------------------------------------------- -- Instance environment -------------------------------------------------------------------------------- - homeInstEnv = tcg_inst_env tcGblEnv + homeInstEnv = tcg_inst_env tcGblEnv visOrphanModules = tcVisibleOrphanMods tcGblEnv - packageInstEnv = eps_inst_env externalPackageState - instEnv = InstEnvs packageInstEnv homeInstEnv visOrphanModules + packageInstEnv = eps_inst_env externalPackageState + instEnv = InstEnvs packageInstEnv homeInstEnv visOrphanModules -------------------------------------------------------------------------------- - declarations = - createDeclarations flags hsGroup typeEnv exportedNamesSet transformation - environment = - Environment - { envDynFlags = flags - , envUnitState = unitState - , envInstEnv = instEnv - , envTypeEnv = typeEnv - , envTransformation = transformation - , envCurrentModuleDefSites = defSites - , envFileMap = fileMap - , envDefSiteMap = defSiteMap - , envModuleNameMap = moduleNameMap - , envPackageId = currentPackageId - , envComponentId = compId - , envExportedNames = exportedNamesSet - } - externalIds = - L.foldl' - (\acc name -> - maybe - acc - (\id -> (HCE.ExternalIdentifierInfo $ mkIdentifierInfo environment id (Just name)) : acc) - (lookupIdInTypeEnv typeEnv name)) - [] - allNames + declarations = createDeclarations flags + hsGroup + typeEnv + exportedNamesSet + transformation + environment = Environment { envDynFlags = flags + , envUnitState = unitState + , envInstEnv = instEnv + , envTypeEnv = typeEnv + , envTransformation = transformation + , envCurrentModuleDefSites = defSites + , envFileMap = fileMap + , envDefSiteMap = defSiteMap + , envModuleNameMap = moduleNameMap + , envPackageId = currentPackageId + , envComponentId = compId + , envExportedNames = exportedNamesSet + } + externalIds = L.foldl' + (\acc name -> maybe + acc + (\id -> + ( HCE.ExternalIdentifierInfo + $ mkIdentifierInfo environment id (Just name) + ) + : acc + ) + (lookupIdInTypeEnv typeEnv name) + ) + [] + allNames currentModuleName = (\(Module _ name) -> - HCE.HaskellModuleName . T.pack . moduleNameString $ name) . - ms_mod $ - modSum + HCE.HaskellModuleName . T.pack . moduleNameString $ name + ) + . ms_mod + $ modSum SourceInfo {..} = foldAST environment typecheckedModule - in (tidyInternalIds HCE.ModuleInfo - { id = modulePath - , transformation = transformation - , name = currentModuleName - , declarations = declarations - , exprInfoMap = sourceInfoExprMap - , idInfoMap = sourceInfoIdMap - , idOccMap = sourceInfoIdOccMap - , definitionSiteMap = defSites - , source = V.fromList . T.splitOn "\n" $ sourceCode' - , externalIds = externalIds - } + in + ( tidyInternalIds HCE.ModuleInfo + { id = modulePath + , transformation = transformation + , name = currentModuleName + , declarations = declarations + , exprInfoMap = sourceInfoExprMap + , idInfoMap = sourceInfoIdMap + , idOccMap = sourceInfoIdOccMap + , definitionSiteMap = defSites + , source = V.fromList . T.splitOn "\n" $ sourceCode' + , externalIds = externalIds + } , if not $ isHsBoot modulePath - then (HM.union - (HM.fromList . - (( HCE.HaskellFilePath $ HCE.getHaskellModulePath modulePath - , modulePath) :) . - map (, modulePath) $ - includedFiles) - fileMap - , HM.union (HM.singleton modulePath defSites) defSiteMap - , HM.insertWith HM.union currentModuleName - (HM.singleton compId modulePath) moduleNameMap) - else (fileMap, defSiteMap, moduleNameMap) - , sourceInfoTypeErrors) + then + ( HM.union + ( HM.fromList + . (( HCE.HaskellFilePath $ HCE.getHaskellModulePath modulePath + , modulePath + ) : + ) + . map (, modulePath) + $ includedFiles + ) + fileMap + , HM.union (HM.singleton modulePath defSites) defSiteMap + , HM.insertWith HM.union + currentModuleName + (HM.singleton compId modulePath) + moduleNameMap + ) + else (fileMap, defSiteMap, moduleNameMap) + , sourceInfoTypeErrors + ) data SourceInfo = SourceInfo - { sourceInfoExprMap :: HCE.ExpressionInfoMap - , sourceInfoIdMap :: HCE.IdentifierInfoMap - , sourceInfoIdOccMap :: HCE.IdentifierOccurrenceMap + { sourceInfoExprMap :: HCE.ExpressionInfoMap + , sourceInfoIdMap :: HCE.IdentifierInfoMap + , sourceInfoIdOccMap :: HCE.IdentifierOccurrenceMap , sourceInfoTypeErrors :: [TypeError] - } deriving (Show, Eq) + } + deriving (Show, Eq) tidyInternalIds :: HCE.ModuleInfo -> HCE.ModuleInfo tidyInternalIds modInfo = evalState (U.transformBiM tidy modInfo) (HM.empty, 0) - where - tidy :: - HCE.InternalId -> State (HM.HashMap T.Text T.Text, Int) HCE.InternalId - tidy (HCE.InternalId text) = do - (hmap, number) <- get - case HM.lookup text hmap of - Just val -> return $ HCE.InternalId val - Nothing -> do - let nextInternalId = T.pack . show $ number - put (HM.insert text nextInternalId hmap, number + 1) - return $ HCE.InternalId nextInternalId + where + tidy + :: HCE.InternalId -> State (HM.HashMap T.Text T.Text, Int) HCE.InternalId + tidy (HCE.InternalId text) = do + (hmap, number) <- get + case HM.lookup text hmap of + Just val -> return $ HCE.InternalId val + Nothing -> do + let nextInternalId = T.pack . show $ number + put (HM.insert text nextInternalId hmap, number + 1) + return $ HCE.InternalId nextInternalId -prepareSourceCode :: - HCE.SourceCodePreprocessing +prepareSourceCode + :: HCE.SourceCodePreprocessing -> T.Text -> ModSummary -> HCE.HaskellModulePath -> (HCE.SourceCodeTransformation, T.Text) -prepareSourceCode sourceCodePreprocessing originalSourceCode modSum modulePath = - let sourceCodeAfterPreprocessing = - case TE.decodeUtf8' $ - maybe - (error "ms_hspp_buf is Nothing") - stringBufferToByteString - (ms_hspp_buf modSum) of - Right text -> T.replace "\t" " " text - Left err -> - error $ - "decodeUtf8' : " ++ show err ++ " , file : " ++ show modulePath - in case sourceCodePreprocessing of - HCE.BeforePreprocessing -> - let sourceCodeLines = T.splitOn "\n" originalSourceCode - in ( HCE.SourceCodeTransformation - (length sourceCodeLines) - modulePath - S.empty - HM.empty - , originalSourceCode) - HCE.AfterPreprocessing -> - createSourceCodeTransformation +prepareSourceCode sourceCodePreprocessing originalSourceCode modSum modulePath + = let sourceCodeAfterPreprocessing = + case + TE.decodeUtf8' $ maybe (error "ms_hspp_buf is Nothing") + stringBufferToByteString + (ms_hspp_buf modSum) + of + Right text -> T.replace "\t" " " text + Left err -> + error + $ "decodeUtf8' : " + ++ show err + ++ " , file : " + ++ show modulePath + in case sourceCodePreprocessing of + HCE.BeforePreprocessing -> + let sourceCodeLines = T.splitOn "\n" originalSourceCode + in ( HCE.SourceCodeTransformation (length sourceCodeLines) + modulePath + S.empty + HM.empty + , originalSourceCode + ) + HCE.AfterPreprocessing -> createSourceCodeTransformation modulePath originalSourceCode sourceCodeAfterPreprocessing -createDefinitionSiteMap :: - DynFlags +createDefinitionSiteMap + :: DynFlags -> UnitState -> HCE.PackageId -> HCE.ComponentId @@ -323,137 +360,143 @@ createDefinitionSiteMap :: -> HCE.SourceCodeTransformation -> ModuleInfo -> [Name] -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -> HsGroup GhcRn -#else - -> HsGroup Name -#endif -> (HCE.DefinitionSiteMap, [Name]) -createDefinitionSiteMap flags unitState currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup = - let +createDefinitionSiteMap flags unitState currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup + = let allDecls :: [LHsDecl GhcRn] allDecls = sortLocatedA . ungroup $ hsGroup (instanceDeclsWithDocs, valueAndTypeDeclsWithDocs) = L.partition - (\(L _ decl, _) -> - case decl of - InstD {} -> True - _ -> False) $ - collectDocs allDecls + (\(L _ decl, _) -> case decl of + InstD{} -> True + _ -> False + ) + $ collectDocs allDecls -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- -- No type instances or data instances here for now instanceDocMap :: M.Map SrcSpan [HsDocString] instanceDocMap = - M.fromList . - mapMaybe - (\(L _n decl, docs) -> - case decl of -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - InstD _ (ClsInstD _ inst) -> Just (clsInstDeclSrcSpan inst, docs) -#else - InstD (ClsInstD inst) -> Just (clsInstDeclSrcSpan inst, docs) -#endif - _ -> Nothing) $ - instanceDeclsWithDocs + M.fromList + . mapMaybe + (\(L _n decl, docs) -> case decl of + InstD _ (ClsInstD _ inst) -> + Just (clsInstDeclSrcSpan inst, docs) + _ -> Nothing + ) + $ instanceDeclsWithDocs nameLocation :: Maybe SrcSpan -> Name -> HCE.LocationInfo - nameLocation = - nameLocationInfo - unitState - currentPackageId - compId - transformation - fileMap - defSiteMap - Nothing + nameLocation = nameLocationInfo unitState + currentPackageId + compId + transformation + fileMap + defSiteMap + Nothing docHToHtml :: DocH (ModuleName, OccName) Name -> HCE.HTML - docHToHtml = - docWithNamesToHtml - flags - unitState - currentPackageId - compId - transformation - fileMap - defSiteMap + docHToHtml = docWithNamesToHtml flags + unitState + currentPackageId + compId + transformation + fileMap + defSiteMap instancesWithDocumentation = - HM.fromList . - map - (\clsInst -> - ( instanceToText flags clsInst - , let location = - nameLocation Nothing (varName . is_dfun $ clsInst) - in case M.lookup (getSrcSpan clsInst) instanceDocMap of - Just hsDocString -> - HCE.DefinitionSite - location - (Just . docHToHtml . hsDocsToDocH flags globalRdrEnv $ - hsDocString) - Nothing -> HCE.DefinitionSite location Nothing)) $ - modInfoInstances modInfo -- all instances (including derived) + HM.fromList + . map + (\clsInst -> + ( instanceToText flags clsInst + , let location = + nameLocation Nothing (varName . is_dfun $ clsInst) + in case M.lookup (getSrcSpan clsInst) instanceDocMap of + Just hsDocString -> HCE.DefinitionSite + location + ( Just + . docHToHtml + . hsDocsToDocH flags globalRdrEnv + $ hsDocString + ) + Nothing -> HCE.DefinitionSite location Nothing + ) + ) + $ modInfoInstances modInfo -- all instances (including derived) -------------------------------------------------------------------------------- -- Values and types -------------------------------------------------------------------------------- - mainDeclNamesWithDocumentation = - concatMap - (\(dec@(L _ decl), docs) -> - map (, docs, getLocA dec) $ getMainDeclBinder decl) - valueAndTypeDeclsWithDocs + mainDeclNamesWithDocumentation = concatMap + (\(dec@(L _ decl), docs) -> + map (, docs, getLocA dec) $ getMainDeclBinder decl + ) + valueAndTypeDeclsWithDocs dataFamTyConsWithoutDocs = map (\name -> (name, [], nameSrcSpan name)) dataFamTyCons allNamesWithDocumentation = - mainDeclNamesWithDocumentation ++ - subordinateNamesWithDocs allDecls ++ - dataFamTyConsWithoutDocs - (valuesWithDocumentation, typesWithDocumentation) = - L.partition - (\(name, _doc, _srcSpan) -> - case occNameNameSpace . nameOccName $ name of - HCE.VarName -> True - HCE.DataName -> True - _ -> False) - allNamesWithDocumentation - toHashMap :: - [(Name, [HsDocString], SrcSpan)] + mainDeclNamesWithDocumentation + ++ subordinateNamesWithDocs allDecls + ++ dataFamTyConsWithoutDocs + (valuesWithDocumentation, typesWithDocumentation) = L.partition + (\(name, _doc, _srcSpan) -> + case occNameNameSpace . nameOccName $ name of + HCE.VarName -> True + HCE.DataName -> True + _ -> False + ) + allNamesWithDocumentation + toHashMap + :: [(Name, [HsDocString], SrcSpan)] -> HM.HashMap HCE.OccName HCE.DefinitionSite toHashMap = HM.fromListWith - (\(HCE.DefinitionSite loc newDoc) (HCE.DefinitionSite _ oldDoc) -> - (HCE.DefinitionSite loc $ mappend newDoc oldDoc)) . - map - (\(name, docs, srcSpan) -> - let location = nameLocation (Just srcSpan) name - htmlDoc = - if not . null $ docs - then Just . docHToHtml . hsDocsToDocH flags globalRdrEnv $ - docs - else Nothing - in (HCE.OccName $ toText flags name, HCE.DefinitionSite location htmlDoc)) - -------------------------------------------------------------------------------- - in ( HCE.DefinitionSiteMap - { HCE.values = toHashMap valuesWithDocumentation - , HCE.types = - toHashMap $ typesWithDocumentation ++ dataFamTyConsWithoutDocs - , HCE.instances = instancesWithDocumentation - } - , map (\(n, _, _) -> n) allNamesWithDocumentation) + (\(HCE.DefinitionSite loc newDoc) (HCE.DefinitionSite _ oldDoc) -> + (HCE.DefinitionSite loc $ mappend newDoc oldDoc) + ) + . map + (\(name, docs, srcSpan) -> + let location = nameLocation (Just srcSpan) name + htmlDoc = if not . null $ docs + then + Just + . docHToHtml + . hsDocsToDocH flags globalRdrEnv + $ docs + else Nothing + in ( HCE.OccName $ toText flags name + , HCE.DefinitionSite location htmlDoc + ) + ) + -------------------------------------------------------------------------------- + in + ( HCE.DefinitionSiteMap + { HCE.values = toHashMap valuesWithDocumentation + , HCE.types = toHashMap + $ typesWithDocumentation + ++ dataFamTyConsWithoutDocs + , HCE.instances = instancesWithDocumentation + } + , map (\(n, _, _) -> n) allNamesWithDocumentation + ) -occNameToHtml :: - DynFlags +occNameToHtml + :: DynFlags -> HCE.PackageId -> HCE.ComponentId -> (ModuleName, OccName) -> H.Html occNameToHtml flags packageId compId (modName, occName) = let location = - H.textValue . toStrict . encodeToLazyText . Aeson.toJSON $ - occNameLocationInfo flags packageId compId (modName, occName) - in (H.span H.! H.dataAttribute "location" location) H.! A.class_ "link" $ - H.toHtml (toText flags occName) + H.textValue + . toStrict + . encodeToLazyText + . Aeson.toJSON + $ occNameLocationInfo flags packageId compId (modName, occName) + in (H.span H.! H.dataAttribute "location" location) + H.! A.class_ "link" + $ H.toHtml (toText flags occName) -nameToHtml :: - UnitState +nameToHtml + :: UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation @@ -463,22 +506,26 @@ nameToHtml :: -> H.Html nameToHtml unitState packageId compId transformation files defSiteMap name = let location = - H.textValue . toStrict . encodeToLazyText . Aeson.toJSON $ - nameLocationInfo - unitState - packageId - compId - transformation - files - defSiteMap - Nothing - Nothing - name - in H.span H.! H.dataAttribute "location" location H.! A.class_ "link" $ - H.toHtml (nameToText name) + H.textValue + . toStrict + . encodeToLazyText + . Aeson.toJSON + $ nameLocationInfo unitState + packageId + compId + transformation + files + defSiteMap + Nothing + Nothing + name + in H.span + H.! H.dataAttribute "location" location + H.! A.class_ "link" + $ H.toHtml (nameToText name) -docWithNamesToHtml :: - DynFlags +docWithNamesToHtml + :: DynFlags -> UnitState -> HCE.PackageId -> HCE.ComponentId @@ -487,18 +534,14 @@ docWithNamesToHtml :: -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> DocH (ModuleName, OccName) Name -> HCE.HTML -docWithNamesToHtml flags unitState packageId compId transformation fileMap defSiteMap = - HCE.docToHtml +docWithNamesToHtml flags unitState packageId compId transformation fileMap defSiteMap + = HCE.docToHtml (occNameToHtml flags packageId compId) (nameToHtml unitState packageId compId transformation fileMap defSiteMap) -createDeclarations :: - DynFlags -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +createDeclarations + :: DynFlags -> HsGroup GhcRn -#else - -> HsGroup Name -#endif -> TypeEnv -> S.Set Name -> HCE.SourceCodeTransformation @@ -507,227 +550,211 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = let lineNumber :: SrcSpan -> Int lineNumber srcSpan = case srcSpanToLineAndColNumbers transformation srcSpan of - Just (_file,(lineNum, _), (_, _)) -> lineNum - Nothing -> 1 + Just (_file, (lineNum, _), (_, _)) -> lineNum + Nothing -> 1 nameType :: Name -> Maybe HCE.Type - nameType n = - case lookupIdInTypeEnv typeEnv n of - Just i -> Just . mkType flags . varType $ i - Nothing -> Nothing + nameType n = case lookupIdInTypeEnv typeEnv n of + Just i -> Just . mkType flags . varType $ i + Nothing -> Nothing -- | Top-level functions -------------------------------------------------------------------------------- valToDeclarations :: LHsBindLR GhcRn GhcRn -> [HCE.Declaration] valToDeclarations lb@(L _ bind) = map - (\name -> - HCE.Declaration - HCE.ValD - (toText flags name) - (nameType name) - (S.member name exportedSet) - (lineNumber (getLocA lb))) $ - collectHsBindBinders CollNoDictBinders bind + (\name -> HCE.Declaration HCE.ValD + (toText flags name) + (nameType name) + (S.member name exportedSet) + (lineNumber (getLocA lb)) + ) + $ collectHsBindBinders CollNoDictBinders bind vals = concatMap valToDeclarations $ hsGroupVals hsGroup -- | Data, newtype, type, type family, data family or class declaration -------------------------------------------------------------------------------- tyClToDeclaration :: LTyClDecl GhcRn -> HCE.Declaration - tyClToDeclaration lt@(L _ tyClDecl) = - HCE.Declaration - HCE.TyClD - (T.append (tyClDeclPrefix tyClDecl) (toText flags $ tcdName tyClDecl)) - (nameType $ tcdName tyClDecl) - (S.member (unLoc $ tyClDeclLName tyClDecl) exportedSet) - (lineNumber (getLocA lt)) + tyClToDeclaration lt@(L _ tyClDecl) = HCE.Declaration + HCE.TyClD + (T.append (tyClDeclPrefix tyClDecl) (toText flags $ tcdName tyClDecl)) + (nameType $ tcdName tyClDecl) + (S.member (unLoc $ tyClDeclLName tyClDecl) exportedSet) + (lineNumber (getLocA lt)) tyclds = - map tyClToDeclaration . - filter (isGoodSrcSpan . getLocA) . concatMap group_tyclds . hs_tyclds $ - hsGroup + map tyClToDeclaration + . filter (isGoodSrcSpan . getLocA) + . concatMap group_tyclds + . hs_tyclds + $ hsGroup -- | Instances -------------------------------------------------------------------------------- -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) instToDeclaration :: LInstDecl GhcRn -> HCE.Declaration -#endif - instToDeclaration li@(L _ inst) = - HCE.Declaration - HCE.InstD - (instanceDeclToText flags inst) - Nothing - True - (lineNumber (getLocA li)) + instToDeclaration li@(L _ inst) = HCE.Declaration + HCE.InstD + (instanceDeclToText flags inst) + Nothing + True + (lineNumber (getLocA li)) insts = - map instToDeclaration . filter (isGoodSrcSpan . getLocA) . hsGroupInstDecls $ - hsGroup + map instToDeclaration + . filter (isGoodSrcSpan . getLocA) + . hsGroupInstDecls + $ hsGroup -- | Foreign functions -------------------------------------------------------------------------------- foreignFunToDeclaration :: LForeignDecl GhcRn -> HCE.Declaration foreignFunToDeclaration lf@(L _ fd) = let name = unLoc $ fd_name fd - in HCE.Declaration - HCE.ForD - (toText flags name) - (nameType name) - True - (lineNumber (getLocA lf)) + in HCE.Declaration HCE.ForD + (toText flags name) + (nameType name) + True + (lineNumber (getLocA lf)) fords = map foreignFunToDeclaration $ hs_fords hsGroup -------------------------------------------------------------------------------- - in L.sortOn HCE.lineNumber $ vals ++ tyclds ++ insts ++ fords + in L.sortOn HCE.lineNumber $ vals ++ tyclds ++ insts ++ fords foldAST :: Environment -> TypecheckedModule -> SourceInfo foldAST environment typecheckedModule = - let (Just renamed@(_, importDecls, mbExported, _)) = - renamedSource typecheckedModule - emptyASTState = - ASTState IVM.empty IM.empty M.empty emptyTidyEnv Nothing environment [] - ASTState {..} = - execState - (foldTypecheckedSource $ tm_typechecked_source typecheckedModule) - emptyASTState - -- A few things that are not in the output of the typechecker: - -- - the export list - -- - the imports - -- - type signatures - -- - type/data/newtype declarations - -- - class declarations + let + (Just renamed@(_, importDecls, mbExported, _)) = + renamedSource typecheckedModule + emptyASTState = + ASTState IVM.empty IM.empty M.empty emptyTidyEnv Nothing environment [] + ASTState {..} = execState + (foldTypecheckedSource $ tm_typechecked_source typecheckedModule) + emptyASTState + -- A few things that are not in the output of the typechecker: + -- - the export list + -- - the imports + -- - type signatures + -- - type/data/newtype declarations + -- - class declarations - -- Both typechecked source and renamed source are used to populate - -- 'IdentifierInfoMap' and 'IdentifierOccurrenceMap' - (idInfoMap, idOccMap) = - L.foldl' - (addIdentifierToMaps environment astStateIdSrcSpanMap) - (HM.empty, astStateIdOccMap) - (namesFromRenamedSource renamed) - unitState = envUnitState environment - packageId = envPackageId environment - compId = envComponentId environment - importedModules = - map - ((\lm@(L _ modName) -> + -- Both typechecked source and renamed source are used to populate + -- 'IdentifierInfoMap' and 'IdentifierOccurrenceMap' + (idInfoMap, idOccMap) = L.foldl' + (addIdentifierToMaps environment astStateIdSrcSpanMap) + (HM.empty, astStateIdOccMap) + (namesFromRenamedSource renamed) + unitState = envUnitState environment + packageId = envPackageId environment + compId = envComponentId environment + importedModules = + map + ( (\lm@(L _ modName) -> ( modName , getLocA lm - , moduleLocationInfo - unitState - (envModuleNameMap environment) - packageId - compId - modName)) . - ideclName . unLoc) . - filter (not . ideclImplicit . unLoc) $ - importDecls - exportedModules = - case mbExported of - Just lieNames -> - mapMaybe - (\(li@(L _ ie),_) -> - case ie of - IEModuleContents _ (L _ modName) -> - Just - ( modName - , getLocA li - , moduleLocationInfo - unitState - (envModuleNameMap environment) - packageId - compId - modName) - _ -> Nothing) - lieNames - Nothing -> [] - addImportedAndExportedModulesToIdOccMap :: - HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap - addImportedAndExportedModulesToIdOccMap = - IM.map (L.sortOn fst) . - addModules - (envTransformation environment) - (importedModules ++ exportedModules) - in SourceInfo - { sourceInfoExprMap = astStateExprInfoMap - , sourceInfoIdMap = idInfoMap - , sourceInfoIdOccMap = addImportedAndExportedModulesToIdOccMap idOccMap - , sourceInfoTypeErrors = astStateTypeErrors - } + , moduleLocationInfo unitState + (envModuleNameMap environment) + packageId + compId + modName + ) + ) + . ideclName + . unLoc + ) + . filter (not . ideclImplicit . unLoc) + $ importDecls + exportedModules = case mbExported of + Just lieNames -> mapMaybe + (\(li@(L _ ie), _) -> case ie of + IEModuleContents _ (L _ modName) -> Just + ( modName + , getLocA li + , moduleLocationInfo unitState + (envModuleNameMap environment) + packageId + compId + modName + ) + _ -> Nothing + ) + lieNames + Nothing -> [] + addImportedAndExportedModulesToIdOccMap + :: HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap + addImportedAndExportedModulesToIdOccMap = + IM.map (L.sortOn fst) . addModules (envTransformation environment) + (importedModules ++ exportedModules) + in + SourceInfo + { sourceInfoExprMap = astStateExprInfoMap + , sourceInfoIdMap = idInfoMap + , sourceInfoIdOccMap = addImportedAndExportedModulesToIdOccMap idOccMap + , sourceInfoTypeErrors = astStateTypeErrors + } -- | Updates 'IdentifierOccurrenceMap' and 'IdentifierInfoMap' using information -- from typechecked source and renamed source -addIdentifierToMaps :: - Environment +addIdentifierToMaps + :: Environment -> M.Map SrcSpan (Id, Maybe (Type, [Type])) -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) -> NameOccurrence -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) addIdentifierToMaps environment idSrcSpanMap idMaps@(idInfoMap, idOccMap) nameOcc - | isGoodSrcSpan (getLoc $ locatedName nameOcc) && - isOneLineSpan (getLoc $ locatedName nameOcc) + | isGoodSrcSpan (getLoc $ locatedName nameOcc) + && isOneLineSpan (getLoc $ locatedName nameOcc) , Just (_, (lineNumber, startCol), (_, endCol)) <- - srcSpanToLineAndColNumbers (envTransformation environment) . - getLoc . locatedName $ - nameOcc = - case nameOcc of - TyLitOccurrence {kind = kind} -> - addNameToMaps - environment - idMaps - (Just kind) - Nothing - (description nameOcc) - lineNumber - startCol - endCol - NameOccurrence {isBinder = isBinder} -> - case lookupIdByNameOccurrence environment idSrcSpanMap nameOcc of - Just (identifier, mbTypes) -> - let name = - fromMaybe - (varName identifier) - (unLoc $ locatedName nameOcc) - identifierType = varType identifier - identifierTypeExpanded = expandTypeSynonyms identifierType - tyConsAndTyVars = - map - (, Nothing) - (tyConsOfType identifierType ++ - tyVarsOfType identifierType ++ - tyConsOfType identifierTypeExpanded ++ - tyVarsOfType identifierTypeExpanded ++ - maybe [] (tyConsOfType . fst) mbTypes ++ - maybe [] (tyVarsOfType . fst) mbTypes) - idInfoMap' = - updateIdMap - environment - ((identifier, unLoc $ locatedName nameOcc) : tyConsAndTyVars) - idInfoMap - idOcc = - mkIdentifierOccurrence - environment - identifier - name - mbTypes - isBinder - (description nameOcc) - idOccMap' = - IM.insertWith - removeOverlappingInterval - lineNumber - [((startCol, endCol), idOcc)] - idOccMap - in (idInfoMap', idOccMap') - Nothing -- type variable or an internal identifier in a pattern synonym - -> - case unLoc $ locatedName nameOcc of - Just name -> - addNameToMaps - environment - idMaps - Nothing - (Just name) - (description nameOcc) - lineNumber - startCol - endCol - Nothing -> idMaps + srcSpanToLineAndColNumbers (envTransformation environment) + . getLoc + . locatedName + $ nameOcc + = case nameOcc of + TyLitOccurrence { kind = kind } -> addNameToMaps environment + idMaps + (Just kind) + Nothing + (description nameOcc) + lineNumber + startCol + endCol + NameOccurrence { isBinder = isBinder } -> + case lookupIdByNameOccurrence environment idSrcSpanMap nameOcc of + Just (identifier, mbTypes) -> + let name = + fromMaybe (varName identifier) (unLoc $ locatedName nameOcc) + identifierType = varType identifier + identifierTypeExpanded = expandTypeSynonyms identifierType + tyConsAndTyVars = map + (, Nothing) + ( tyConsOfType identifierType + ++ tyVarsOfType identifierType + ++ tyConsOfType identifierTypeExpanded + ++ tyVarsOfType identifierTypeExpanded + ++ maybe [] (tyConsOfType . fst) mbTypes + ++ maybe [] (tyVarsOfType . fst) mbTypes + ) + idInfoMap' = updateIdMap + environment + ((identifier, unLoc $ locatedName nameOcc) : tyConsAndTyVars) + idInfoMap + idOcc = mkIdentifierOccurrence environment + identifier + name + mbTypes + isBinder + (description nameOcc) + idOccMap' = IM.insertWith removeOverlappingInterval + lineNumber + [((startCol, endCol), idOcc)] + idOccMap + in (idInfoMap', idOccMap') + -- type variable or an internal identifier in a pattern synonym + Nothing -> case unLoc $ locatedName nameOcc of + Just name -> addNameToMaps environment + idMaps + Nothing + (Just name) + (description nameOcc) + lineNumber + startCol + endCol + Nothing -> idMaps addIdentifierToMaps _ _ idMaps _ = idMaps -addNameToMaps :: - Environment +addNameToMaps + :: Environment -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) -> Maybe Type -> Maybe Name @@ -735,114 +762,110 @@ addNameToMaps :: -> Int -> Int -> Int - -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) -addNameToMaps environment (idInfoMap, idOccMap) mbKind mbName descr lineNumber colStart colEnd = - let flags = envDynFlags environment - idInfoMap' = - maybe + -> ( HCE.IdentifierInfoMap + , HCE.IdentifierOccurrenceMap + ) +addNameToMaps environment (idInfoMap, idOccMap) mbKind mbName descr lineNumber colStart colEnd + = let flags = envDynFlags environment + idInfoMap' = maybe idInfoMap - (\kind -> - updateIdMap - environment - (map (, Nothing) $ tyConsOfType kind ++ tyVarsOfType kind) - idInfoMap) + (\kind -> updateIdMap + environment + (map (, Nothing) $ tyConsOfType kind ++ tyVarsOfType kind) + idInfoMap + ) mbKind - idOcc = - HCE.IdentifierOccurrence - { internalId = fmap (HCE.InternalId . nameKey) mbName - , internalIdFromRenamedSource = - HCE.InternalId . T.pack . show . getKey . nameUnique <$> mbName - , isBinder = False - , instanceResolution = Nothing - , idOccType = mkType flags <$> mbKind - , typeArguments = Nothing - , description = descr - , sort = - maybe - HCE.TypeId - (\name -> - case occNameNameSpace . nameOccName $ name of - HCE.VarName -> HCE.ValueId - HCE.DataName -> HCE.ValueId - _ -> HCE.TypeId) - mbName + idOcc = HCE.IdentifierOccurrence + { internalId = fmap (HCE.InternalId . nameKey) mbName + , internalIdFromRenamedSource = HCE.InternalId + . T.pack + . show + . getKey + . nameUnique + <$> mbName + , isBinder = False + , instanceResolution = Nothing + , idOccType = mkType flags <$> mbKind + , typeArguments = Nothing + , description = descr + , sort = maybe + HCE.TypeId + (\name -> case occNameNameSpace . nameOccName $ name of + HCE.VarName -> HCE.ValueId + HCE.DataName -> HCE.ValueId + _ -> HCE.TypeId + ) + mbName } - idOccMap' = - IM.insertWith - removeOverlappingInterval - lineNumber - [((colStart, colEnd), idOcc)] - idOccMap - in (idInfoMap', idOccMap') + idOccMap' = IM.insertWith removeOverlappingInterval + lineNumber + [((colStart, colEnd), idOcc)] + idOccMap + in (idInfoMap', idOccMap') -lookupIdByNameOccurrence :: - Environment +lookupIdByNameOccurrence + :: Environment -> M.Map SrcSpan (Id, Maybe (Type, [Type])) -> NameOccurrence -> Maybe (Id, Maybe (Type, [Type])) -lookupIdByNameOccurrence environment idSrcSpanMap (NameOccurrence (L span mbName) _ _) = - case M.lookup span idSrcSpanMap of +lookupIdByNameOccurrence environment idSrcSpanMap (NameOccurrence (L span mbName) _ _) + = case M.lookup span idSrcSpanMap of Just (identifier, mbTypes) -> Just (identifier, mbTypes) - Nothing -> - case mbName of - Just name -> - case M.lookup (nameSrcSpan name) idSrcSpanMap of - -- LHS of a Match - Just (identifier, mbTypes) -> Just (identifier, mbTypes) - Nothing -> - -- Things that are not in the typechecked source - case lookupIdInTypeEnv (envTypeEnv environment) name of - Just t -> Just (t, Nothing) - Nothing -> Nothing - Nothing -> Nothing -lookupIdByNameOccurrence _ _ TyLitOccurrence {} = Nothing + Nothing -> case mbName of + Just name -> case M.lookup (nameSrcSpan name) idSrcSpanMap of + -- LHS of a Match + Just (identifier, mbTypes) -> Just (identifier, mbTypes) + Nothing -> + -- Things that are not in the typechecked source + case lookupIdInTypeEnv (envTypeEnv environment) name of + Just t -> Just (t, Nothing) + Nothing -> Nothing + Nothing -> Nothing +lookupIdByNameOccurrence _ _ TyLitOccurrence{} = Nothing -updateIdMap :: - Environment +updateIdMap + :: Environment -> [(Id, Maybe Name)] -> HCE.IdentifierInfoMap -> HCE.IdentifierInfoMap updateIdMap environment ids identifiersMap = let flags = envDynFlags environment - update :: - HCE.IdentifierInfoMap -> (Id, Maybe Name) -> HCE.IdentifierInfoMap + update + :: HCE.IdentifierInfoMap -> (Id, Maybe Name) -> HCE.IdentifierInfoMap update idMap (identifier, mbName) = let info = mkIdentifierInfo environment identifier mbName - in HM.insertWith - (flip const) - (HCE.InternalId $ identifierKey flags identifier) - info - idMap - in L.foldl' update identifiersMap ids + in HM.insertWith (flip const) + (HCE.InternalId $ identifierKey flags identifier) + info + idMap + in L.foldl' update identifiersMap ids -addModules :: - HCE.SourceCodeTransformation +addModules + :: HCE.SourceCodeTransformation -> [(ModuleName, SrcSpan, HCE.LocationInfo)] -> HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap addModules transformation modules idMap = - let update :: - IM.IntMap [((Int, Int), HCE.IdentifierOccurrence)] + let update + :: IM.IntMap [((Int, Int), HCE.IdentifierOccurrence)] -> (a, SrcSpan, HCE.LocationInfo) -> IM.IntMap [((Int, Int), HCE.IdentifierOccurrence)] update idOccMap (_modInfo, span, locInfo) - | Just (_file,(lineNumber, colStart), (_, colEnd)) <- - srcSpanToLineAndColNumbers transformation span = - let idOcc = - HCE.IdentifierOccurrence - { internalId = Nothing - , internalIdFromRenamedSource = Nothing - , isBinder = False - , instanceResolution = Nothing - , idOccType = Nothing - , typeArguments = Nothing - , description = "ImportDecl" - , sort = HCE.ModuleId locInfo - } - in IM.insertWith - removeOverlappingInterval - lineNumber - [((colStart, colEnd), idOcc)] - idOccMap + | Just (_file, (lineNumber, colStart), (_, colEnd)) <- + srcSpanToLineAndColNumbers transformation span + = let idOcc = HCE.IdentifierOccurrence + { internalId = Nothing + , internalIdFromRenamedSource = Nothing + , isBinder = False + , instanceResolution = Nothing + , idOccType = Nothing + , typeArguments = Nothing + , description = "ImportDecl" + , sort = HCE.ModuleId locInfo + } + in IM.insertWith removeOverlappingInterval + lineNumber + [((colStart, colEnd), idOcc)] + idOccMap update idOccMap _ = idOccMap - in L.foldl' update idMap modules + in L.foldl' update idMap modules |