{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} module HaskellCodeExplorer.GhcUtils ( -- * Pretty-printing toText , instanceToText , instanceDeclToText , nameToText , tyClDeclPrefix , demangleOccName , stringBufferToByteString , nameSort , occNameNameSpace , identifierKey , nameKey , mbIdDetails -- * Syntax manipulation , hsGroupVals , hsPatSynDetails , ieLocNames , ghcDL -- * Lookups , lookupIdInTypeEnv , lookupNameModuleAndPackage -- * Location info , isHsBoot , moduleLocationInfo , nameLocationInfo , occNameLocationInfo , nameDocumentation , srcSpanToLineAndColNumbers -- * Type-related functions , tyThingToId , tidyIdentifierType , patSynId , applyWrapper , wrapperTypes , tyVarsOfType , tyConsOfType , updateOccNames , mkType -- * Documentation processing , collectDocs , ungroup , mkDecls , getMainDeclBinder , classDeclDocs , sigNameNoLoc , clsInstDeclSrcSpan , hsDocsToDocH , subordinateNamesWithDocs ) where -- import Bag (bagToList) import GHC.Data.Bag (bagToList) -- import ConLike (ConLike(..)) import GHC.Core.ConLike (ConLike(..)) import GHC.HsToCore.Docs ( collectDocs , ungroup , mkDecls ) import qualified Data.ByteString as BS import Data.Hashable (Hashable,hash) import qualified Data.ByteString.Internal as BSI import Data.Char (isAlpha, isAlphaNum, isAscii, ord) import Data.Generics (Data) import Data.Generics.SYB (everything, everywhere, mkQ, mkT) import qualified Data.Generics.Uniplate.Data() 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 GHC.Core.DataCon (dataConWorkId) import Documentation.Haddock.Parser (overIdentifier, parseParas) import Documentation.Haddock.Types ( DocH(..) , Header(..) , _doc , Namespace ) -- import DynFlags () -- import FastString (mkFastString, unpackFS) import GHC.Data.FastString ( mkFastString , unpackFS , FastString ) import GHC ( DynFlags , CollectFlag(..) , reLocN , unXRec , UnXRec , GhcPass , recordPatSynField #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) , HsDocString #else , HsDocString (..) #endif , InstDecl(..) , Name , SrcSpan(..) , srcSpanStart , srcSpanEnd , SrcLoc(..) , RealSrcSpan(..) , SrcSpanAnnA , ClsInstDecl(..) , TyClDecl(..) , HsDataDefn(..) , NewOrData(..) , Id , rdrNameFieldOcc , HsGroup(..) , HsBindLR(..) , HsValBindsLR(..) #if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0) , HsPatSynDetails #else , HsPatSynDetails(..) #endif , Located , IE(..) , TyThing(..) , LHsDecl , HsDecl(..) , ConDecl(..) , HsConDetails(..) , DataFamInstDecl(..) , Sig(..) , ForeignDecl(..) , FixitySig(..) , tcdName , collectHsBindBinders , getLocA -- , hsSigType , getConNames #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) , NHsValBindsLR(..) -- , getConArgs , unpackHDS , NoExtField(..) -- , NoExt(..) , extFieldOcc #else , getConDetails , selectorFieldOcc #endif #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) , LIEWrappedName , ieLWrappedName #else , tyClGroupConcat #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) , FamEqn(..) #endif , tyConKind , nameSrcSpan , srcSpanFile , srcSpanStartLine , srcSpanEndLine , srcSpanStartCol , srcSpanEndCol , isExternalName -- , recordPatSynSelectorId , recordPatSynPatVar , isGoodSrcSpan , isLocalId , isDataFamilyDecl , tyFamInstDeclName , idType -- , 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 #endif ) import qualified HaskellCodeExplorer.Types as HCE -- import HscTypes (TypeEnv, lookupTypeEnv) import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -- 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) , initParserState , unP ) -- import Module (Module(..)) -- import Name import GHC.Types.Name ( isDataConNameSpace , isDerivedOccName , isInternalName , isSystemName , isTvNameSpace , isTyConName , isValNameSpace , isWiredInName , mkInternalName , mkOccName , nameModule_maybe , nameOccName , nameUnique , occNameFS , occNameSpace , occNameString , wiredInNameTyThing_maybe ) -- import OccName (OccName) import GHC.Types.Name.Occurrence (OccName) -- import Outputable (Outputable, ppr, showPpr, showSDoc) import GHC.Utils.Outputable (Outputable, ppr) import GHC.Utils.Misc (thenCmp) import GHC.Driver.Config (initParserOpts) import GHC.Driver.Ppr (showPpr, showSDoc) -- import PackageConfig (packageVersion) -- import Packages import GHC.Unit.State ( LookupResult(..) , lookupModuleWithSuggestions , lookupUnit -- , lookupPackage -- , packageNameString ) -- 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 GHC.Types.Name.Reader ( GlobalRdrEnv , RdrName(..) , grePrintableName , 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 GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind) -- import TcType (evVarPred) import GHC.Tc.Utils.TcType (evVarPred) import GHC.Core.TyCo.Rep ( Type(..) , mkVisFunTyMany , mkVisFunTys , mkVisFunTysMany , scaledThing ) -- import TyCon (tyConName) import GHC.Core.TyCon (tyConName) -- import Type import GHC.Core.Type ( coreView , expandTypeSynonyms , mkForAllTy , mkTyCoInvForAllTys -- , mkFunTys -- , mkInvForAllTys , piResultTy , splitFunTy_maybe , tidyOpenType ) import GHC.Core.TyCo.Ppr (pprSigmaType) #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) 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 GHC.Types.Unique (getKey) -- import Var import GHC.Types.Var ( idDetails , isId , mkTyVar , mkCoVar , setVarType , varName , varType , varUnique ) -- 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 -------------------------------------------------------------------------------- toText :: (Outputable a) => DynFlags -> a -> T.Text toText flags = T.pack . showSDoc flags . ppr instanceToText :: DynFlags -> ClsInst -> T.Text instanceToText flags ClsInst {..} = T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun) instanceDeclToText :: DynFlags -> InstDecl GhcRn -> T.Text instanceDeclToText flags decl = case decl of -- Pattern match has inaccessible right hand side -- XInstDecl _ -> "" -- ClsInstD _ (XClsInstDecl _) -> "" ClsInstD _ ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty) DataFamInstD _ di -> let args = T.intercalate " " . map (toText flags) . feqn_pats . dfid_eqn $ di in T.concat ["data instance ", toText flags (unLoc $ feqn_tycon . dfid_eqn $ di), " ", args] TyFamInstD _ ti -> let args = T.intercalate " " . map (toText flags) . feqn_pats . tfid_eqn $ ti in T.concat ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] nameToText :: Name -> T.Text nameToText = T.pack . unpackFS . occNameFS . nameOccName tyClDeclPrefix :: TyClDecl a -> T.Text tyClDeclPrefix tyClDecl = let isNewTy :: TyClDecl a -> Bool isNewTy DataDecl {tcdDataDefn = HsDataDefn {dd_ND = NewType}} = True isNewTy _ = False in case tyClDecl of FamDecl {} | isDataFamilyDecl tyClDecl -> "data family " | otherwise -> "type family " SynDecl {} -> "type " DataDecl {} | isNewTy tyClDecl -> "newtype " | otherwise -> "data " ClassDecl {} -> "class " #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) XTyClDecl _ -> "" #endif demangleOccName :: Name -> T.Text demangleOccName name | isDerivedOccName (nameOccName name) = let removePrefix :: T.Text -> T.Text removePrefix occName | T.isPrefixOf "$sel:" occName = fst $ T.breakOn ":" (T.drop 5 occName) | T.isPrefixOf "$W" occName = T.drop 2 occName | T.isPrefixOf "$w" occName = T.drop 2 occName | T.isPrefixOf "$m" occName = T.drop 2 occName | T.isPrefixOf "$b" occName = T.drop 2 occName | T.isPrefixOf "$dm" occName = T.drop 3 occName | T.isPrefixOf "$c" occName = T.drop 2 occName | T.isPrefixOf "$d" occName = T.drop 2 occName | T.isPrefixOf "$i" occName = T.drop 2 occName | T.isPrefixOf "$s" occName = T.drop 2 occName | T.isPrefixOf "$f" occName = T.drop 2 occName | T.isPrefixOf "$r" occName = T.drop 2 occName | T.isPrefixOf "C:" occName = T.drop 2 occName | T.isPrefixOf "N:" occName = T.drop 2 occName | T.isPrefixOf "D:" occName = T.drop 2 occName | T.isPrefixOf "$co" occName = T.drop 3 occName | otherwise = occName in removePrefix $ nameToText name | otherwise = nameToText name stringBufferToByteString :: StringBuffer -> BS.ByteString stringBufferToByteString (StringBuffer buf len cur) = BSI.fromForeignPtr buf cur len nameSort :: Name -> HCE.NameSort nameSort n = if isExternalName n then HCE.External else HCE.Internal occNameNameSpace :: OccName -> HCE.NameSpace occNameNameSpace n | isDataConNameSpace (occNameSpace n) = HCE.DataName | isTvNameSpace (occNameSpace n) = HCE.TvName | isValNameSpace (occNameSpace n) = HCE.VarName | otherwise = HCE.TcClsName -- Two 'Id''s may have different types even though they have the same 'Unique'. identifierKey :: DynFlags -> Id -> T.Text identifierKey flags id | isLocalId id = T.concat [ T.pack . show . getKey . varUnique $ id , "_" , T.pack . show . hash . showSDoc flags . ppr . varType $ id ] identifierKey _ id = T.pack . show . getKey . varUnique $ id nameKey :: Name -> T.Text nameKey = T.pack . show . getKey . nameUnique mbIdDetails :: Id -> Maybe HCE.IdDetails mbIdDetails v | isId v = case idDetails v of VanillaId -> Just HCE.VanillaId RecSelId {sel_naughty = False} -> Just HCE.RecSelId RecSelId {sel_naughty = True} -> Just HCE.RecSelIdNaughty DataConWorkId _ -> Just HCE.DataConWorkId DataConWrapId _ -> Just HCE.DataConWrapId ClassOpId _ -> Just HCE.ClassOpId PrimOpId _ -> Just HCE.PrimOpId FCallId _ -> Just HCE.FCallId TickBoxOpId _ -> Just HCE.TickBoxOpId DFunId _ -> Just HCE.DFunId CoVarId -> Just HCE.CoVarId #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) JoinId _ -> Just HCE.JoinId #endif mbIdDetails _ = Nothing -------------------------------------------------------------------------------- -- Syntax transformation -------------------------------------------------------------------------------- hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)] hsGroupVals hsGroup = filter (isGoodSrcSpan . getLocA) $ case hs_valds hsGroup of XValBindsLR (NValBinds binds _) -> concatMap (bagToList . snd) binds _ -> [] hsPatSynDetails :: HsPatSynDetails GhcRn -> [Located Name] hsPatSynDetails patDetails = case patDetails of InfixCon name1 name2 -> [reLocN name1, reLocN name2] PrefixCon _ fields -> reLocN <$> fields RecCon fields -> concatMap (\field -> [ L ((getLocA . rdrNameFieldOcc . recordPatSynField) field) (extFieldOcc $ recordPatSynField field), reLocN $ recordPatSynPatVar field]) fields #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) unwrapName :: LIEWrappedName a -> Located a unwrapName = reLocN . ieLWrappedName #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) unwrapName :: LIEWrappedName Name -> Located Name unwrapName = ieLWrappedName #else unwrapName :: Located Name -> Located Name unwrapName n = n #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) ieLocNames :: IE pass -> [Located (IdP pass)] #else ieLocNames :: IE Name -> [Located Name] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) ieLocNames (XIE _) = [] ieLocNames (IEVar _ n) = #else ieLocNames (IEVar n) = #endif [unwrapName n] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) ieLocNames (IEThingAbs _ n) = #else ieLocNames (IEThingAbs n) = #endif [unwrapName n] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) ieLocNames (IEThingAll _ n) = #else ieLocNames (IEThingAll n) = #endif [unwrapName n] #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) = unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels) #endif ieLocNames IEModuleContents {} = [] ieLocNames IEGroup {} = [] ieLocNames IEDoc {} = [] ieLocNames IEDocNamed {} = [] -------------------------------------------------------------------------------- -- Lookups -------------------------------------------------------------------------------- lookupIdInTypeEnv :: TypeEnv -> Name -> Maybe Id lookupIdInTypeEnv typeEnv name = do let mbTyThing | isInternalName name = Nothing | isSystemName name = Nothing | isWiredInName name = wiredInNameTyThing_maybe name | isExternalName name = lookupTypeEnv typeEnv name | otherwise = Nothing case mbTyThing of Just tyThing -> tyThingToId tyThing _ -> Nothing lookupNameModuleAndPackage :: UnitState -> HCE.PackageId -> Name -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId) lookupNameModuleAndPackage state currentPackageId name = case nameModule_maybe name of Just Module {..} -> case lookupUnit state moduleUnit of Just unitInfo -> let packageId = if (T.pack . unitPackageNameString $ unitInfo) == HCE.name (currentPackageId :: HCE.PackageId) then currentPackageId else HCE.PackageId (T.pack $ unitPackageNameString unitInfo) (unitPackageVersion unitInfo) in Right ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName , packageId) Nothing -> Right ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName , currentPackageId) Nothing -> Left $ T.concat ["nameModule_maybe ", nameToText name, " is Nothing"] -------------------------------------------------------------------------------- -- Location info -------------------------------------------------------------------------------- isHsBoot :: HCE.HaskellModulePath -> Bool isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath moduleLocationInfo :: UnitState -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) -> HCE.PackageId -> HCE.ComponentId -> ModuleName -> HCE.LocationInfo moduleLocationInfo unitState moduleNameMap currentPackageId compId moduleName = let moduleNameText = T.pack . moduleNameString $ moduleName currentPackageLocation = HCE.ApproximateLocation currentPackageId (HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName) HCE.Mod moduleNameText Nothing compId in case HM.lookup (HCE.HaskellModuleName moduleNameText) moduleNameMap of Just modulePathMap | Just modulePath <- HM.lookup compId modulePathMap -> HCE.ExactLocation currentPackageId modulePath (HCE.HaskellModuleName moduleNameText) 1 1 1 1 _ -> case lookupModuleWithSuggestions unitState moduleName Nothing of LookupFound Module {moduleUnit = unitId} _ -> case lookupUnit unitState unitId of Just unitInfo -> let packageId = HCE.PackageId (T.pack $ unitPackageNameString unitInfo) (unitPackageVersion unitInfo) in HCE.ApproximateLocation packageId (HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName) HCE.Mod moduleNameText Nothing (if packageId == currentPackageId then compId else HCE.ComponentId "lib") Nothing -> currentPackageLocation _ -> currentPackageLocation isDefinedInCurrentModule :: HCE.SourceCodeTransformation -> HCE.HaskellFilePath -> Bool isDefinedInCurrentModule transformation file = let includedFiles = HM.keys $ HCE.fileIndex transformation modPath = HCE.getHaskellModulePath $ HCE.filePath (transformation :: HCE.SourceCodeTransformation) in HCE.getHaskellFilePath file == modPath || (file `elem` includedFiles) nameLocationInfo :: UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> Maybe T.Text -- ^ Instance head (when name is a dictionary function) -> Maybe SrcSpan -- ^ Only for wired-in names -> Name -> HCE.LocationInfo 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 unitState currentPackageId compId mbInstanceHead name in if isDefinedInCurrentModule transformation filePath then let eitherStart = HCE.fromOriginalLineNumber transformation (filePath, srcSpanStartLine srcSpan) eitherEnd = HCE.fromOriginalLineNumber transformation (filePath, srcSpanEndLine srcSpan) in case (,) eitherStart eitherEnd of (Right startLine,Right endLine) -> let modulePath = HCE.filePath (transformation :: HCE.SourceCodeTransformation) moduleName = either (const $ HCE.HaskellModuleName "") fst (lookupNameModuleAndPackage unitState currentPackageId name) in HCE.ExactLocation { packageId = currentPackageId , modulePath = modulePath , moduleName = moduleName , startLine = startLine , endLine = endLine , startColumn = srcSpanStartCol srcSpan , endColumn = srcSpanEndCol srcSpan } _ -> approximateLocation else case HM.lookup filePath fileMap of Just haskellModulePath -> case HM.lookup haskellModulePath defSiteMap of Just defSites -> let key = fromMaybe (nameToText name) mbInstanceHead in lookupEntityLocation defSites (mkLocatableEntity name mbInstanceHead) key Nothing -> approximateLocation Nothing -> approximateLocation where realSrcSpan :: Name -> Maybe SrcSpan -> Maybe RealSrcSpan realSrcSpan n mbSpan = case nameSrcSpan n of RealSrcSpan span _ -> Just span _ | isWiredInName n -> case mbSpan of Just span -> case span of RealSrcSpan s _ -> Just s _ -> Nothing _ -> Nothing _ -> Nothing nameLocationInfo unitState currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name = mkApproximateLocation unitState currentPackageId compId mbInstanceHead name mkApproximateLocation :: UnitState -> HCE.PackageId -> HCE.ComponentId -> Maybe T.Text -> Name -> HCE.LocationInfo mkApproximateLocation unitState currentPackageId compId mbInstanceHead name = let haddockAnchor = Just . T.pack . makeAnchorId . T.unpack . nameToText $ name in case lookupNameModuleAndPackage unitState currentPackageId name of Right (moduleName, packageId) -> HCE.ApproximateLocation { moduleName = moduleName , packageId = packageId , componentId = if packageId == currentPackageId then compId else HCE.ComponentId "lib" , entity = mkLocatableEntity name mbInstanceHead , haddockAnchorId = haddockAnchor , name = fromMaybe (nameToText name) mbInstanceHead } Left errorMessage -> HCE.UnknownLocation errorMessage mkLocatableEntity :: Name -> Maybe a -> HCE.LocatableEntity mkLocatableEntity name mbInstanceHead | isJust mbInstanceHead = HCE.Inst | otherwise = case occNameNameSpace . nameOccName $ name of HCE.VarName -> HCE.Val HCE.DataName -> HCE.Val _ -> HCE.Typ occNameLocationInfo :: DynFlags -> HCE.PackageId -> HCE.ComponentId -> (ModuleName, OccName) -> HCE.LocationInfo occNameLocationInfo flags packageId componentId (modName, occName) = HCE.ApproximateLocation { packageId = packageId , moduleName = HCE.HaskellModuleName $ toText flags modName , entity = case occNameNameSpace occName of HCE.VarName -> HCE.Val HCE.DataName -> HCE.Val _ -> HCE.Typ , name = toText flags occName , haddockAnchorId = Just . T.pack . makeAnchorId . T.unpack $ toText flags occName , componentId = componentId } lookupEntityLocation :: HCE.DefinitionSiteMap -> HCE.LocatableEntity -> T.Text -> HCE.LocationInfo lookupEntityLocation defSiteMap locatableEntity text = let errorMessage = T.concat [ "Cannot find location of " , T.pack . show $ locatableEntity , " " , text ] defSiteLocation = HCE.location :: HCE.DefinitionSite -> HCE.LocationInfo lookupLocation :: (Eq a, Hashable a) => (HCE.DefinitionSiteMap -> HM.HashMap a HCE.DefinitionSite) -> (T.Text -> a) -> HCE.LocationInfo lookupLocation selector toKey = maybe (HCE.UnknownLocation errorMessage) defSiteLocation $ HM.lookup (toKey text) (selector defSiteMap) in case locatableEntity of HCE.Val -> lookupLocation HCE.values HCE.OccName HCE.Typ -> lookupLocation HCE.types HCE.OccName HCE.Inst -> lookupLocation HCE.instances (\t -> t) HCE.Mod -> HCE.UnknownLocation errorMessage nameDocumentation :: HCE.SourceCodeTransformation -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> HCE.DefinitionSiteMap -> Name -> Maybe T.Text nameDocumentation transformation fileMap defSiteMap currentModuleDefSiteMap name | isExternalName name || isWiredInName name , Just file <- srcSpanToFilePath . nameSrcSpan $ name = if isDefinedInCurrentModule transformation file then lookupNameDocumentation name currentModuleDefSiteMap else case HM.lookup file fileMap of Just haskellModulePath -> case HM.lookup haskellModulePath defSiteMap of Just defSites -> lookupNameDocumentation name defSites Nothing -> Nothing Nothing -> Nothing nameDocumentation _ _ _ _ _ = Nothing lookupNameDocumentation :: Name -> HCE.DefinitionSiteMap -> Maybe T.Text lookupNameDocumentation name defSiteMap = let key = HCE.OccName $ nameToText name lookupDoc :: (HCE.DefinitionSiteMap -> HM.HashMap HCE.OccName HCE.DefinitionSite) -> Maybe T.Text lookupDoc selector = maybe Nothing HCE.documentation $ HM.lookup key (selector (defSiteMap :: HCE.DefinitionSiteMap)) in case occNameNameSpace . nameOccName $ name of HCE.VarName -> lookupDoc HCE.values HCE.DataName -> lookupDoc HCE.values _ -> lookupDoc HCE.types srcSpanToFilePath :: SrcSpan -> Maybe HCE.HaskellFilePath srcSpanToFilePath (RealSrcSpan s _) = Just . HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s srcSpanToFilePath (UnhelpfulSpan _) = Nothing srcSpanToLineAndColNumbers :: HCE.SourceCodeTransformation -> SrcSpan -> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int)) -- do we need to do anything with the BufSpan? srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) = let filePath = HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s eitherStart = HCE.fromOriginalLineNumber transformation (filePath, srcSpanStartLine s) eitherEnd = HCE.fromOriginalLineNumber transformation (filePath, srcSpanEndLine s) in case (,) eitherStart eitherEnd of (Right startLine, Right endLine) -> Just ( filePath , (startLine, srcSpanStartCol s) , (endLine, srcSpanEndCol s)) _ -> Nothing srcSpanToLineAndColNumbers _ _ = Nothing -------------------------------------------------------------------------------- -- Type-related functions -------------------------------------------------------------------------------- tyThingToId :: TyThing -> Maybe Id tyThingToId tyThing = case tyThing of AnId id -> Just id ATyCon tc -> Just $ mkTyVar (tyConName tc) (tyConKind tc) AConLike con -> case con of RealDataCon dataCon -> Just $ dataConWorkId dataCon PatSynCon ps -> Just $ patSynId ps ACoAxiom _ -> Nothing tidyIdentifierType :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdentifierType tidyEnv identifier = let (tidyEnv', typ') = tidyOpenType tidyEnv (varType identifier) in (tidyEnv', setVarType identifier typ') patSynId :: PatSyn -> Id patSynId patSyn = let (univTvs, reqTheta, exTvs, provTheta, argTys, resTy) = patSynSig patSyn reqTheta' | null reqTheta && not (null provTheta && null exTvs) = [unitTy] | otherwise = reqTheta -- required => provided => arg_1 -> ... -> arg_n -> res patSynTy = mkTyCoInvForAllTys univTvs $ mkVisFunTysMany reqTheta' $ mkTyCoInvForAllTys exTvs $ mkVisFunTysMany provTheta $ mkVisFunTys argTys resTy (name, _, _) = patSynMatcher patSyn in mkCoVar name patSynTy applyWrapper :: HsWrapper -> Type -> Type applyWrapper wp ty | Just ty' <- coreView ty = applyWrapper wp ty' applyWrapper WpHole t = t applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t applyWrapper (WpFun w1 w2 t1 _doc) t = mkVisFunTys [t1] (applyWrapper w2 $ piResultTy t (applyWrapper w1 $ scaledThing t1)) applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion applyWrapper (WpEvLam v) t = mkVisFunTyMany (evVarPred v) t applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of Just (_, _arg,res) -> res Nothing -> t applyWrapper (WpTyLam v) t = mkForAllTy v Required t applyWrapper (WpTyApp t') t = piResultTy t t' applyWrapper (WpLet _) t = t applyWrapper (WpMultCoercion coercion) _ = pSnd $ tcCoercionKind coercion wrapperTypes :: HsWrapper -> [Type] wrapperTypes WpHole = [] wrapperTypes (WpCompose w1 w2) = wrapperTypes w2 ++ wrapperTypes w1 wrapperTypes (WpFun w1 w2 _ _) = wrapperTypes w2 ++ wrapperTypes w1 wrapperTypes (WpCast _) = [] wrapperTypes (WpEvLam _) = [] wrapperTypes (WpEvApp _) = [] wrapperTypes (WpTyLam _) = [] wrapperTypes (WpTyApp t) = [t] wrapperTypes (WpLet _) = [] wrapperTypes (WpMultCoercion _) = [] mkType :: DynFlags -> Type -> HCE.Type mkType flags typ = let typeExpanded = expandTypeSynonyms typ typeComponents = toTypeComponents flags typ typeComponentsExpanded = toTypeComponents flags typeExpanded in HCE.Type typeComponents (if typeComponents /= typeComponentsExpanded then Just typeComponentsExpanded else Nothing) #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) typeToText :: DynFlags -> Type -> T.Text typeToText flags = T.pack . showSDoc flags . pprIfaceType . toIfaceType #else typeToText :: DynFlags -> Type -> T.Text typeToText = toText #endif toTypeComponents :: DynFlags -> Type -> [HCE.TypeComponent] toTypeComponents flags typ = let signature = typeToText flags $ updateOccNames (\_unique occName -> ";" ++ drop 2 occName ++ ";") typ -- Signature with OccNames and uniques signatureWithUniques = typeToText flags $ updateOccNames (\unique occName -> ";," ++ occName ++ "," ++ unique ++ ";") typ -- Dirty but simple way to extract a list of TypeComponent from a type signature. -- Assumptions : -- 1. Character ';' cannot appear anywhere in a type signature -- 2. Character ',' cannot appear in an 'OccName' -- 3. length (T.splitOn ";" signature) == length (T.splitOn ";" signatureWithUniques) components = L.zip (T.splitOn ";" signature) (T.splitOn ";" signatureWithUniques) in mapMaybe (\(text1, text2) -> if T.isPrefixOf "," text2 then case T.splitOn "," text2 of ["", name, id] -> Just HCE.TyCon {name = name, internalId = HCE.InternalId id} _ -> Just $ HCE.Text text1 else if T.null text1 then Nothing else Just $ HCE.Text text1) components -- | Replaces 'OccName' of each type variable and type constructor in a type. updateOccNames :: (String -> String -> String) -> Type -> Type updateOccNames update = everywhere (mkT updateType) where updateType :: Type -> Type updateType (TyVarTy var) = TyVarTy var {varName = updateName (varName var)} updateType (TyConApp con args) = TyConApp (con {tyConName = updateName (tyConName con)}) args updateType other = other updateName :: Name -> Name updateName oldName = let oldOccName = nameOccName oldName unique = T.unpack $ nameKey oldName newOccName = mkOccName (occNameSpace oldOccName) (update unique (occNameString oldOccName)) in mkInternalName (nameUnique oldName) newOccName (nameSrcSpan oldName) -- | This function doesn't look through type synonyms tyConsOfType :: Type -> [Id] tyConsOfType = #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) nonDetEltsUniqSet . everything unionUniqSets (emptyVarSet `mkQ` tyCon) #else uniqSetToList . everything unionUniqSets (emptyVarSet `mkQ` tyCon) #endif where tyCon :: Type -> VarSet tyCon (TyConApp tc _) = unitVarSet $ mkTyVar (tyConName tc) (tyConKind tc) tyCon _ = emptyUniqSet tyVarsOfType :: (Data a) => a -> [Id] #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) tyVarsOfType = nonDetEltsUniqSet . everything unionVarSet (emptyVarSet `mkQ` tyVar) #else tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar) #endif where tyVar :: Type -> VarSet tyVar (TyVarTy ty) = unitVarSet ty tyVar _ = emptyVarSet -------------------------------------------------------------------------------- -- Documentation processing -- Some functions are copied from haddock-api package -------------------------------------------------------------------------------- -- collectDocs is available in GHC.HsToCore.Docs -- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])] -- available in GHC.HsToCore.Docs -- #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -- #else -- ungroup :: HsGroup Name -> [LHsDecl Name] -- #endif -- also available in GHC.HsToCore.Docs -- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl] -- mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -- mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct] instance Ord FastString where a `compare` b = unpackFS a `compare` unpackFS b deriving instance () => Ord SrcLoc instance Ord SrcSpan where a `compare` b = (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) sortByLoc :: [GenLocated SrcSpanAnnA a] -> [GenLocated SrcSpanAnnA a] sortByLoc = L.sortOn getLocA #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] #else classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] #endif classDeclDocs class_ = collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) docs = mkDecls tcdDocs (DocD NoExtField) class_ defs = mkDecls (bagToList . tcdMeths) (ValD NoExtField) class_ sigs = mkDecls tcdSigs (SigD NoExtField) class_ ats = mkDecls tcdATs ((TyClD NoExtField) . (FamDecl NoExtField)) class_ #else docs = mkDecls tcdDocs DocD class_ defs = mkDecls (bagToList . tcdMeths) ValD class_ sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] #else conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] #endif conDeclDocs conDecl = map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)) . getConNames $ conDecl -- no longer used by subordinateNamesWithDocs -- extractRecCon :: ConDecl p -> Maybe (XRec p [LConDeclField p]) -- extractRecCon = undefined -- no longer used by subordinateNamesWithDocs -- selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] -- selectorDocs con = -- case extractRecCon con of -- Just (L _ flds) -> -- concatMap -- (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) -> -- map -- (\(L span f) -> -- (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span)) -- fieldOccs) -- flds -- _ -> [] subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)] subordinateNamesWithDocs = concatMap (\lhd -> case unLoc lhd of TyClD _ classDecl -> concatMap (\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl) $ classDeclDocs classDecl -- Pattern match is redundant -- TyClD _ DataDecl {..} -> -- concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $ -- dd_cons tcdDataDefn InstD _ (DataFamInstD _ DataFamInstDecl {..}) -> concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn _ -> []) -- no longer needed by ungroup -- isUserLSig :: forall p. UnXRec p => LSig p -> Bool -- isUserLSig sig = case unXRec @p sig of -- TypeSig {} -> True -- ClassOpSig {} -> True -- _ -> False #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn] #else getMainDeclBinder :: HsDecl name -> [name] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) getMainDeclBinder (TyClD _ d) = #else getMainDeclBinder (TyClD d) = #endif [tcdName d] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) getMainDeclBinder (ValD _ d) = #else getMainDeclBinder (ValD d) = #endif case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) getMainDeclBinder (SigD _ d) = sigNameNoLoc d #else getMainDeclBinder (SigD d) = sigNameNoLoc d #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] #else getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) getMainDeclBinder (ForD _ ForeignExport {}) = [] #else getMainDeclBinder (ForD ForeignExport {}) = [] #endif getMainDeclBinder _ = [] sigNameNoLoc :: forall p. UnXRec p => Sig p -> [IdP p] sigNameNoLoc (TypeSig _ ns _) = map (unXRec @p) ns sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @p) ns sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @p) ns sigNameNoLoc (SpecSig _ n _ _) = [unXRec @p n] sigNameNoLoc (InlineSig _ n _) = [unXRec @p n] sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @p) ns sigNameNoLoc _ = [] clsInstDeclSrcSpan :: ClsInstDecl (GhcPass p) -> SrcSpan clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLocA ty -- Pattern match is redundant -- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -- clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan (UnhelpfulOther "XClsinstdecl") -- #endif hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name hsDocsToDocH flags rdrEnv = rename flags rdrEnv . overIdentifier (parseIdent flags) . _doc #if MIN_VERSION_haddock_library(1,6,0) . parseParas Nothing #else . parseParas #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) . concatMap unpackHDS #else . concatMap (unpackFS . (\(HsDocString s) -> s)) #endif parseIdent :: DynFlags -> Namespace -> String -> Maybe RdrName parseIdent dflags _ str0 = let buffer = stringToStringBuffer str0 realSrcLc = mkRealSrcLoc (mkFastString "") 0 0 pstate = initParserState (initParserOpts dflags) buffer realSrcLc in case unP parseIdentifier pstate of POk _ name -> Just (unLoc name) _ -> Nothing type Doc id = DocH (ModuleName, OccName) id rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name rename dflags gre = rn where rn :: Doc RdrName -> Doc Name rn d = case d of DocAppend a b -> DocAppend (rn a) (rn b) DocParagraph doc -> DocParagraph (rn doc) DocIdentifier x -> do -- Generate the choices for the possible kind of thing this -- is. let choices = dataTcOccs x -- Try to look up all the names in the GlobalRdrEnv that match -- the names. let names = concatMap (\c -> map grePrintableName (lookupGRE_RdrName c gre)) choices case names of -- We found no names in the env so we start guessing. [] -> case choices of [] -> DocMonospaced (DocString (showPpr dflags x)) -- There was nothing in the environment so we need to -- pick some default from what's available to us. We -- diverge here from the old way where we would default -- to type constructors as we're much more likely to -- actually want anchors to regular definitions than -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. a:_ -> outOfScope dflags a -- There is only one name in the environment that matches so -- use it. [a] -> DocIdentifier a -- But when there are multiple names available, default to -- type constructors: somewhat awfully GHC returns the -- values in the list positionally. a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) DocBold doc -> DocBold (rn doc) DocMonospaced doc -> DocMonospaced (rn doc) DocUnorderedList docs -> DocUnorderedList (map rn docs) DocOrderedList docs -> DocOrderedList (map rn docs) DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] DocCodeBlock doc -> DocCodeBlock (rn doc) DocIdentifierUnchecked x -> DocIdentifierUnchecked x DocModule modLink -> DocModule (rn <$> modLink) DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink) DocPic str -> DocPic str DocMathInline str -> DocMathInline str DocMathDisplay str -> DocMathDisplay str DocAName str -> DocAName str DocProperty p -> DocProperty p DocExamples e -> DocExamples e DocEmpty -> DocEmpty DocString str -> DocString str DocHeader (Header l t) -> DocHeader $ Header l (rn t) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) DocTable t -> DocTable (rn <$> t) #endif -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently -- we simply monospace the identifier in most cases except when the -- identifier is qualified: if the identifier is qualified then we can -- still try to guess and generate anchors accross modules but the -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. outOfScope :: DynFlags -> RdrName -> Doc a outOfScope dflags x = case x of Unqual occ -> monospaced occ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) Orig _ occ -> monospaced occ Exact name -> monospaced name -- Shouldn't happen since x is out of scope where monospaced :: (Outputable a) => a -> Doc b monospaced a = DocMonospaced (DocString (showPpr dflags a)) makeAnchorId :: String -> String makeAnchorId [] = [] makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r where escape p c | p c = [c] | otherwise = '-' : show (ord c) ++ "-" isLegal ':' = True isLegal '_' = True isLegal '.' = True isLegal c = isAscii c && isAlphaNum c -- no more HasSrcSpan or SrcSpanLess -- #if MIN_VERSION_ghc(8,8,0) -- ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) -- ghcDL = GHC.dL -- #else ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x -- #endif