diff options
Diffstat (limited to 'src/HaskellCodeExplorer/GhcUtils.hs')
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 1122 |
1 files changed, 1122 insertions, 0 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs new file mode 100644 index 0000000..714e429 --- /dev/null +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -0,0 +1,1122 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} + +module HaskellCodeExplorer.GhcUtils + ( -- * Pretty-printing + toText + , instanceToText + , instanceDeclToText + , nameToText + , tyClDeclPrefix + , demangleOccName + , stringBufferToByteString + , nameSort + , occNameNameSpace + , identifierKey + , nameKey + , mbIdDetails + -- * Syntax manipulation + , hsGroupVals + , hsPatSynDetails + , ieLocNames + -- * 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 ConLike (ConLike(..)) +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.Either (either) +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 Data.Ord (comparing) +import qualified Data.Text as T +import DataCon (dataConWorkId, flSelector) +import Documentation.Haddock.Parser (overIdentifier, parseParas) +import Documentation.Haddock.Types (DocH(..), Header(..), _doc) +import DynFlags () +import FastString (mkFastString, unpackFS) +import GHC + ( DynFlags + , HsDocString(..) + , InstDecl(..) + , ModuleName + , Name + , SrcSpan(..) + , RealSrcSpan(..) + , ClsInstDecl(..) + , TyClDecl(..) + , HsDataDefn(..) + , NewOrData(..) + , Id + , HsGroup(..) + , HsBindLR(..) + , HsValBindsLR(..) + , HsPatSynDetails(..) + , Located + , IE(..) + , TyThing(..) + , LHsDecl + , HsDecl(..) + , DocDecl(..) + , ConDecl(..) + , PostRn + , HsConDetails(..) + , ConDeclField(..) + , DataFamInstDecl(..) + , LSig + , Sig(..) + , ForeignDecl(..) + , FixitySig(..) + , tcdName + , collectHsBindBinders + , getLoc + , hsSigType + , getConNames + , getConDetails + , selectorFieldOcc +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + , tyClGroupTyClDecls + , LIEWrappedName + , hsGroupInstDecls + , ieLWrappedName +#else + , tyClGroupConcat +#endif + , tyConKind + , nameSrcSpan + , srcSpanFile + , srcSpanStartLine + , srcSpanEndLine + , srcSpanStartCol + , srcSpanEndCol + , isExternalName + , moduleNameString + , recordPatSynSelectorId + , recordPatSynPatVar + , isGoodSrcSpan + , isLocalId + , isDataFamilyDecl + , tyFamInstDeclName + , idType + , hsib_body + , tfe_pats + , tfid_eqn + ) +import qualified HaskellCodeExplorer.Types as HCE +import HscTypes (TypeEnv, lookupTypeEnv) +import IdInfo (IdDetails(..)) +import InstEnv (ClsInst(..)) +import Lexer (ParseResult(POk), mkPState, unP) +import Module (Module(..)) +import Name + ( isDataConNameSpace + , isDerivedOccName + , isInternalName + , isSystemName + , isTvNameSpace + , isTyConName + , isVarNameSpace + , isWiredInName + , mkInternalName + , mkOccName + , nameModule_maybe + , nameOccName + , nameUnique + , occNameFS + , occNameSpace + , occNameString + , wiredInNameTyThing_maybe + ) +import OccName (OccName) +import Outputable (Outputable, ppr, showPpr, showSDoc) +import PackageConfig (packageVersion) +import Packages + ( LookupResult(..) + , lookupModuleWithSuggestions + , lookupPackage + , packageNameString + ) +import Pair (pSnd) +import Parser (parseIdentifier) +import PatSyn (PatSyn, patSynMatcher, patSynSig) +import Prelude hiding (id, span) +import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName) +import RnEnv (dataTcOccs) +import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc) +import StringBuffer (StringBuffer(..), stringToStringBuffer) +import System.FilePath (normalise) +import TcEvidence (HsWrapper(..), tcCoercionKind) +import TcType (evVarPred) +import TyCoRep (Type(..), +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + ArgFlag(..) +#else + VisibilityFlag(..) +#endif + ) +import TyCon (tyConName) +import Type + ( coreView + , expandTypeSynonyms + , mkForAllTy + , mkFunTy + , mkFunTys + , mkInvForAllTys +#if !MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + , mkNamedBinder +#endif + , piResultTy + , pprSigmaType + , splitFunTy_maybe + , tidyOpenType + ) +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +import ToIface +import IfaceType +#endif +import TysWiredIn (unitTy) +import UniqSet (emptyUniqSet, unionUniqSets, +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + nonDetEltsUniqSet +#else + uniqSetToList +#endif + ) +import Unique (getKey) +import Var + ( idDetails + , isId + , mkTyVar + , setVarType + , varName + , varType + , varUnique + ) +import VarEnv (TidyEnv) +import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +#else + ,varSetElems +#endif + ) + +-------------------------------------------------------------------------------- +-- 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 Name -> T.Text +instanceDeclToText flags decl = + case decl of + ClsInstD ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty) + DataFamInstD di -> + let args = + T.intercalate " " . map (toText flags) . hsib_body $ dfid_pats di + in T.concat + ["data instance ", toText flags (unLoc $ dfid_tycon di), " ", args] + TyFamInstD ti -> + let args = + T.intercalate " " . + map (toText flags) . hsib_body . tfe_pats . unLoc . 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 " + +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 + | isVarNameSpace (occNameSpace n) = HCE.VarName + | isDataConNameSpace (occNameSpace n) = HCE.DataName + | isTvNameSpace (occNameSpace n) = HCE.TvName + | 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 Name -> [GenLocated SrcSpan (HsBindLR Name Name)] +hsGroupVals hsGroup = + filter (isGoodSrcSpan . getLoc) $ + case hs_valds hsGroup of + ValBindsOut binds _ -> concatMap (bagToList . snd) binds + _ -> [] + +hsPatSynDetails :: HsPatSynDetails a -> [a] +hsPatSynDetails patDetails = + case patDetails of + InfixPatSyn name1 name2 -> [name1, name2] + PrefixPatSyn name -> name + RecordPatSyn fields -> + concatMap + (\field -> [recordPatSynSelectorId field, recordPatSynPatVar field]) + fields + +#if 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 + +ieLocNames :: IE Name -> [Located Name] +ieLocNames (IEVar n) = [unwrapName n] +ieLocNames (IEThingAbs n) = [unwrapName n] +ieLocNames (IEThingAll n) = [unwrapName n] +ieLocNames (IEThingWith n _ ns labels) = + unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels) +ieLocNames (IEModuleContents (L _ _)) = [] +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 :: + DynFlags + -> HCE.PackageId + -> Name + -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId) +lookupNameModuleAndPackage flags currentPackageId name = + case nameModule_maybe name of + Just Module {..} -> + case lookupPackage flags moduleUnitId of + Just packageConfig -> + let packageId = + if (T.pack . packageNameString $ packageConfig) == + HCE.name (currentPackageId :: HCE.PackageId) + then currentPackageId + else HCE.PackageId + (T.pack $ packageNameString packageConfig) + (PackageConfig.packageVersion packageConfig) + 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 :: + DynFlags + -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) + -> HCE.PackageId + -> HCE.ComponentId + -> ModuleName + -> HCE.LocationInfo +moduleLocationInfo flags 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 flags moduleName Nothing of + LookupFound Module {moduleUnitId = unitId} _ -> + case lookupPackage flags unitId of + Just packInfo -> + let packageId = + HCE.PackageId + (T.pack $ packageNameString packInfo) + (PackageConfig.packageVersion packInfo) + 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 :: + DynFlags + -> 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 flags currentPackageId compId transformation fileMap defSiteMap mbInstanceHead mbSrcSpan name + | Just srcSpan <- realSrcSpan name mbSrcSpan = + let filePath = + HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ + srcSpan + approximateLocation = + mkApproximateLocation + flags + 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 flags 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 name mbSrcSpan = + case nameSrcSpan name of + RealSrcSpan span -> Just span + _ + | isWiredInName name -> + case mbSrcSpan of + Just span -> + case span of + RealSrcSpan s -> Just s + _ -> Nothing + _ -> Nothing + _ -> Nothing +nameLocationInfo flags currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name = + mkApproximateLocation flags currentPackageId compId mbInstanceHead name + +mkApproximateLocation :: + DynFlags + -> HCE.PackageId + -> HCE.ComponentId + -> Maybe T.Text + -> Name + -> HCE.LocationInfo +mkApproximateLocation flags currentPackageId compId mbInstanceHead name = + let haddockAnchor = + Just . T.pack . makeAnchorId . T.unpack . nameToText $ name + in case lookupNameModuleAndPackage flags 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)) +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 = + mkInvForAllTys univTvs $ + mkFunTys reqTheta' $ + mkInvForAllTys exTvs $ mkFunTys provTheta $ mkFunTys argTys resTy + in flip setVarType patSynTy . fst . patSynMatcher $ patSyn + +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 +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +applyWrapper (WpFun w1 w2 t1 _doc) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1)) +#else +applyWrapper (WpFun w1 w2 t1) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1)) +#endif +applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion +applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t +applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of + Just (_arg,res) -> res + Nothing -> t +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +applyWrapper (WpTyLam v) t = mkForAllTy v Required t +#else +applyWrapper (WpTyLam v) t = mkForAllTy (mkNamedBinder Invisible v) t +#endif +applyWrapper (WpTyApp t') t = piResultTy t t' +applyWrapper (WpLet _) t = t + +wrapperTypes :: HsWrapper -> [Type] +wrapperTypes WpHole = [] +wrapperTypes (WpCompose w1 w2) = wrapperTypes w2 ++ wrapperTypes w1 +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +wrapperTypes (WpFun w1 w2 _ _) = wrapperTypes w2 ++ wrapperTypes w1 +#else +wrapperTypes (WpFun w1 w2 _) = wrapperTypes w2 ++ wrapperTypes w1 +#endif +wrapperTypes (WpCast _) = [] +wrapperTypes (WpEvLam _) = [] +wrapperTypes (WpEvApp _) = [] +wrapperTypes (WpTyLam _) = [] +wrapperTypes (WpTyApp t) = [t] +wrapperTypes (WpLet _) = [] + +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 :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] +collectDocs = go Nothing [] + where + go Nothing _ [] = [] + go (Just prev) docs [] = finished prev docs [] + go prev docs (L _ (DocD (DocCommentNext str)):ds) + | Nothing <- prev = go Nothing (str : docs) ds + | Just decl <- prev = finished decl docs (go Nothing [str] ds) + go prev docs (L _ (DocD (DocCommentPrev str)):ds) = go prev (str : docs) ds + go Nothing docs (d:ds) = go (Just d) docs ds + go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) + finished decl docs rest = (decl, reverse docs) : rest + +ungroup :: HsGroup Name -> [LHsDecl Name] +ungroup group_ = +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ +#else + mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ +#endif + mkDecls hs_derivds DerivD group_ ++ + mkDecls hs_defds DefD group_ ++ + mkDecls hs_fords ForD group_ ++ + mkDecls hs_docs DocD group_ ++ +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + mkDecls hsGroupInstDecls InstD group_ ++ +#else + mkDecls hs_instds InstD group_ ++ +#endif + mkDecls (typesigs . hs_valds) SigD group_ ++ + mkDecls (valbinds . hs_valds) ValD group_ + where + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs + typesigs _ = [] + valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds _ = [] + +mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] +mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct] + +sortByLoc :: [Located a] -> [Located a] +sortByLoc = L.sortBy (comparing getLoc) + +classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +classDeclDocs class_ = collectDocs . sortByLoc $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs DocD class_ + defs = mkDecls (bagToList . tcdMeths) ValD class_ + sigs = mkDecls tcdSigs SigD class_ + ats = mkDecls tcdATs (TyClD . FamDecl) class_ + +conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] +conDeclDocs conDecl = + map (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) . + getConNames $ + conDecl + +selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)] +selectorDocs con = + case getConDetails con of + RecCon (L _ flds) -> + concatMap + (\(L _ (ConDeclField fieldOccs _ mbDoc)) -> + map + (\(L span f) -> + (selectorFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span)) + fieldOccs) + flds + _ -> [] + +subordinateNamesWithDocs :: + [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)] +subordinateNamesWithDocs = + concatMap + (\(L span tyClDecl) -> + case tyClDecl of + TyClD classDecl@ClassDecl {..} -> + concatMap + (\(L _ decl, docs) -> map (, docs, span) $ getMainDeclBinder decl) $ + classDeclDocs classDecl + TyClD DataDecl {..} -> + concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $ + dd_cons tcdDataDefn + InstD (DataFamInstD DataFamInstDecl {..}) -> + concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn + _ -> []) + +isUserLSig :: LSig name -> Bool +isUserLSig (L _ TypeSig {}) = True +isUserLSig (L _ ClassOpSig {}) = True +isUserLSig _ = False + +getMainDeclBinder :: HsDecl name -> [name] +getMainDeclBinder (TyClD d) = [tcdName d] +getMainDeclBinder (ValD d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] +getMainDeclBinder (ForD ForeignExport {}) = [] +getMainDeclBinder _ = [] + +sigNameNoLoc :: Sig name -> [name] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +sigNameNoLoc (PatSynSig ns _) = map unLoc ns +#else +sigNameNoLoc (PatSynSig n _) = [unLoc n] +#endif +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns +sigNameNoLoc _ = [] + +clsInstDeclSrcSpan :: ClsInstDecl name -> SrcSpan +clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLoc (hsSigType ty) + +hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name +hsDocsToDocH flags rdrEnv = + rename flags rdrEnv . + overIdentifier (parseIdent flags) . + _doc . parseParas . concatMap (unpackFS . (\(HsDocString s) -> s)) + +parseIdent :: DynFlags -> String -> Maybe RdrName +parseIdent dflags str0 = + let buffer = stringToStringBuffer str0 + realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0 + pstate = mkPState 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 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 gre_name (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 str -> DocModule str + DocHyperlink l -> DocHyperlink l + 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) + +-- | 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 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 |