From a26bf151b369fc1891678eedccca4cafdc84f4c4 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Mon, 6 Jun 2022 11:38:52 +1000 Subject: moduleinfo done --- src/HaskellCodeExplorer/GhcUtils.hs | 4 +- src/HaskellCodeExplorer/ModuleInfo.hs | 100 +++++++++++++--------------------- 2 files changed, 41 insertions(+), 63 deletions(-) diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 99cf7b4..a1b121c 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -100,6 +100,7 @@ import GHC.Data.FastString import GHC ( DynFlags , CollectFlag(..) + , LHsBindLR , reLocN , unXRec , UnXRec @@ -125,7 +126,6 @@ import GHC , Id , rdrNameFieldOcc , HsGroup(..) - , HsBindLR(..) , HsValBindsLR(..) #if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0) , HsPatSynDetails @@ -474,7 +474,7 @@ mbIdDetails _ = Nothing -- Syntax transformation -------------------------------------------------------------------------------- -hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)] +hsGroupVals :: HsGroup GhcRn -> [LHsBindLR GhcRn GhcRn] hsGroupVals hsGroup = filter (isGoodSrcSpan . getLocA) $ case hs_valds hsGroup of diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs index 8942e6f..6f5c9b5 100644 --- a/src/HaskellCodeExplorer/ModuleInfo.hs +++ b/src/HaskellCodeExplorer/ModuleInfo.hs @@ -34,6 +34,7 @@ import Documentation.Haddock.Types (DocH) import GHC ( GenLocated(..) , DynFlags + , LHsBindLR , ModSummary , ModuleInfo , ModuleName @@ -63,28 +64,25 @@ 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 GHC.Hs.Binds (HsBindLR) -#endif import GHC.Hs.Decls ( ForeignDecl(..) , HsDecl(..) , HsGroup(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - , InstDecl - , TyClDecl -#endif + , LInstDecl + , LForeignDecl + , LTyClDecl , InstDecl(..) , group_tyclds , tyClDeclLName , tcdName -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) , hsGroupInstDecls -#endif ) import GHC.Hs.Doc(HsDocString) import GHC.Hs.ImpExp (IE(..), ImportDecl(..)) -import GHC.Hs.Utils(collectHsBindBinders) +import GHC.Hs.Utils + ( collectHsBindBinders + , CollectFlag(..) + ) import GHC.Unit.State (UnitState) import GHC.Unit.Module.ModDetails ( md_types @@ -99,9 +97,6 @@ import GHC.Unit.Home.ModInfo , hm_details ) import GHC.Core.InstEnv (InstEnvs(..), is_dfun) -import GHC.Unit.Module - ( Module(..) - ) import GHC.Unit.Types ( GenModule(..) ) @@ -376,6 +371,7 @@ createDefinitionSiteMap flags unitState currentPackageId compId defSiteMap fileM docHToHtml = docWithNamesToHtml flags + unitState currentPackageId compId transformation @@ -401,7 +397,7 @@ createDefinitionSiteMap flags unitState currentPackageId compId defSiteMap fileM -------------------------------------------------------------------------------- mainDeclNamesWithDocumentation = concatMap - (\dec@(L _ decl, docs) -> + (\(dec@(L _ decl), docs) -> map (, docs, getLocA dec) $ getMainDeclBinder decl) valueAndTypeDeclsWithDocs dataFamTyConsWithoutDocs = @@ -457,7 +453,7 @@ occNameToHtml flags packageId compId (modName, occName) = H.toHtml (toText flags occName) nameToHtml :: - DynFlags + UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation @@ -465,11 +461,11 @@ nameToHtml :: -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> Name -> H.Html -nameToHtml flags packageId compId transformation files defSiteMap name = +nameToHtml unitState packageId compId transformation files defSiteMap name = let location = H.textValue . toStrict . encodeToLazyText . Aeson.toJSON $ nameLocationInfo - flags + unitState packageId compId transformation @@ -483,6 +479,7 @@ nameToHtml flags packageId compId transformation files defSiteMap name = docWithNamesToHtml :: DynFlags + -> UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation @@ -490,10 +487,10 @@ docWithNamesToHtml :: -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> DocH (ModuleName, OccName) Name -> HCE.HTML -docWithNamesToHtml flags packageId compId transformation fileMap defSiteMap = +docWithNamesToHtml flags unitState packageId compId transformation fileMap defSiteMap = HCE.docToHtml (occNameToHtml flags packageId compId) - (nameToHtml flags packageId compId transformation fileMap defSiteMap) + (nameToHtml unitState packageId compId transformation fileMap defSiteMap) createDeclarations :: DynFlags @@ -519,10 +516,8 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = Nothing -> Nothing -- | Top-level functions -------------------------------------------------------------------------------- -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - valToDeclarations :: GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> [HCE.Declaration] -#endif - valToDeclarations (L loc bind) = + valToDeclarations :: LHsBindLR GhcRn GhcRn -> [HCE.Declaration] + valToDeclarations lb@(L _ bind) = map (\name -> HCE.Declaration @@ -530,58 +525,49 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = (toText flags name) (nameType name) (S.member name exportedSet) - (lineNumber loc)) $ - collectHsBindBinders bind + (lineNumber (getLocA lb))) $ + collectHsBindBinders CollNoDictBinders bind vals = concatMap valToDeclarations $ hsGroupVals hsGroup -- | Data, newtype, type, type family, data family or class declaration -------------------------------------------------------------------------------- -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - tyClToDeclaration :: GenLocated SrcSpan (TyClDecl GhcRn) -> HCE.Declaration -#endif - tyClToDeclaration (L loc tyClDecl) = + 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 loc) + (lineNumber (getLocA lt)) tyclds = map tyClToDeclaration . - filter (isGoodSrcSpan . getLoc) . concatMap group_tyclds . hs_tyclds $ + filter (isGoodSrcSpan . getLocA) . concatMap group_tyclds . hs_tyclds $ hsGroup -- | Instances -------------------------------------------------------------------------------- #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - instToDeclaration :: GenLocated SrcSpan (InstDecl GhcRn) -> HCE.Declaration + instToDeclaration :: LInstDecl GhcRn -> HCE.Declaration #endif - instToDeclaration (L loc inst) = + instToDeclaration li@(L _ inst) = HCE.Declaration HCE.InstD (instanceDeclToText flags inst) Nothing True - (lineNumber loc) + (lineNumber (getLocA li)) insts = -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - map instToDeclaration . filter (isGoodSrcSpan . getLoc) . hsGroupInstDecls $ -#else - map instToDeclaration . filter (isGoodSrcSpan . getLoc) . hs_instds $ -#endif + map instToDeclaration . filter (isGoodSrcSpan . getLocA) . hsGroupInstDecls $ hsGroup -- | Foreign functions -------------------------------------------------------------------------------- -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - foreignFunToDeclaration :: - GenLocated SrcSpan (ForeignDecl GhcRn) -> HCE.Declaration -#endif - foreignFunToDeclaration (L loc fd) = + 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 loc) + (lineNumber (getLocA lf)) fords = map foreignFunToDeclaration $ hs_fords hsGroup -------------------------------------------------------------------------------- in L.sortOn HCE.lineNumber $ vals ++ tyclds ++ insts ++ fords @@ -610,16 +596,16 @@ foldAST environment typecheckedModule = (addIdentifierToMaps environment astStateIdSrcSpanMap) (HM.empty, astStateIdOccMap) (namesFromRenamedSource renamed) - flags = envDynFlags environment + unitState = envUnitState environment packageId = envPackageId environment compId = envComponentId environment importedModules = map - ((\(L span modName) -> + ((\lm@(L _ modName) -> ( modName - , span + , getLocA lm , moduleLocationInfo - flags + unitState (envModuleNameMap environment) packageId compId @@ -631,22 +617,14 @@ foldAST environment typecheckedModule = case mbExported of Just lieNames -> mapMaybe -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - (\(L span ie,_) -> -#else - (\(L span ie) -> -#endif + (\(li@(L _ ie),_) -> case ie of -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) IEModuleContents _ (L _ modName) -> -#else - IEModuleContents (L _ modName) -> -#endif Just ( modName - , span + , getLocA li , moduleLocationInfo - flags + unitState (envModuleNameMap environment) packageId compId @@ -817,7 +795,7 @@ lookupIdByNameOccurrence environment idSrcSpanMap (NameOccurrence (L span mbName Just t -> Just (t, Nothing) Nothing -> Nothing Nothing -> Nothing -lookupIdByNameOccurrence _ _ TyLitOccurrence {..} = Nothing +lookupIdByNameOccurrence _ _ TyLitOccurrence {} = Nothing updateIdMap :: Environment -- cgit v1.2.3