{-# 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 qualified Data.ByteString as BS 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 Data.Hashable ( Hashable , hash ) import qualified Data.List as L import Data.Maybe ( fromMaybe , isJust , mapMaybe ) import qualified Data.Text as T import Documentation.Haddock.Parser ( overIdentifier , parseParas ) import Documentation.Haddock.Types ( DocH(..) , Header(..) , Namespace , _doc ) import GHC ( ClsInstDecl(..) , CollectFlag(..) , ConDecl(..) , ConDeclField(..) , DataFamInstDecl(..) , DynFlags , FamEqn(..) , FixitySig(..) , ForeignDecl(..) , GhcPass , HsConDetails(..) , HsDataDefn(..) , HsDecl(..) , HsDocString , HsGroup(..) , HsPatSynDetails , HsValBindsLR(..) , IE(..) , Id , InstDecl(..) , LHsBindLR , LHsDecl , LIEWrappedName , Located , NHsValBindsLR(..) , Name , NewOrData(..) , NoExtField(..) , RealSrcSpan(..) , Sig(..) , SrcSpan(..) , TyClDecl(..) , TyThing(..) , UnXRec , collectHsBindBinders , extFieldOcc , getConNames , getLocA , getRecConArgs_maybe , idType , ieLWrappedName , isDataFamilyDecl , isExternalName , isGoodSrcSpan , isLocalId , nameSrcSpan , rdrNameFieldOcc , reLocN , recordPatSynField , recordPatSynPatVar , sortLocatedA , srcSpanEndCol , srcSpanEndLine , srcSpanFile , srcSpanStartCol , srcSpanStartLine , tcdName , tfid_eqn , tyConKind , tyFamInstDeclName , unXRec , unpackHDS ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.DataCon ( dataConWorkId ) import GHC.Data.Bag ( bagToList ) import GHC.Data.FastString ( mkFastString , unpackFS ) import GHC.HsToCore.Docs ( collectDocs , mkDecls , ungroup ) import GHC.Builtin.Types ( unitTy ) import GHC.Core.InstEnv ( ClsInst(..) ) import GHC.Core.PatSyn ( PatSyn , patSynMatcher , patSynSig ) import GHC.Core.TyCo.Ppr ( pprSigmaType ) import GHC.Core.TyCo.Rep ( Type(..) , mkVisFunTyMany , mkVisFunTys , mkVisFunTysMany , scaledThing ) import GHC.Core.TyCon ( tyConName ) import GHC.Core.Type ( coreView , expandTypeSynonyms , mkForAllTy , mkTyCoInvForAllTys , piResultTy , splitFunTy_maybe , tidyOpenType ) import GHC.CoreToIface import GHC.Data.Pair ( pSnd ) import GHC.Data.StringBuffer ( StringBuffer(..) , stringToStringBuffer ) import GHC.Driver.Config ( initParserOpts ) import GHC.Driver.Ppr ( showPpr , showSDoc ) import GHC.Hs.Extension ( GhcRn ) import GHC.Iface.Type import GHC.Parser ( parseIdentifier ) import GHC.Parser.Lexer ( ParseResult(POk) , initParserState , unP ) import GHC.Rename.Env ( dataTcOccs ) import GHC.Tc.Types.Evidence ( HsWrapper(..) , tcCoercionKind ) import GHC.Tc.Utils.TcType ( evVarPred ) import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name ( isDataConNameSpace , isDerivedOccName , isInternalName , isSystemName , isTvNameSpace , isTyConName , isValNameSpace , isWiredInName , mkInternalName , mkOccName , nameModule_maybe , nameOccName , nameUnique , occNameFS , occNameSpace , occNameString , wiredInNameTyThing_maybe ) import GHC.Types.Name.Occurrence ( OccName ) import GHC.Types.Name.Reader ( GlobalRdrEnv , RdrName(..) , grePrintableName , lookupGRE_RdrName ) import GHC.Types.SrcLoc ( GenLocated(..) , mkRealSrcLoc , unLoc ) import GHC.Types.TypeEnv ( TypeEnv , lookupTypeEnv ) import GHC.Types.Unique ( getKey ) import GHC.Types.Unique.Set ( emptyUniqSet , nonDetEltsUniqSet , unionUniqSets ) import GHC.Types.Var ( idDetails , isId , mkCoVar , mkTyVar , setVarType , varName , varType , varUnique ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Types.Var.Set ( VarSet , emptyVarSet , unionVarSet , unitVarSet ) import GHC.Unit import GHC.Unit.State ( LookupResult(..) , lookupModuleWithSuggestions , lookupUnit ) import GHC.Utils.Outputable ( Outputable , ppr ) import qualified HaskellCodeExplorer.Types as HCE import Language.Haskell.Syntax.Extension ( IdP ) import Prelude hiding ( id , span ) import System.FilePath ( normalise ) -------------------------------------------------------------------------------- -- 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 " XTyClDecl _ -> "" 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 JoinId _ -> Just HCE.JoinId mbIdDetails _ = Nothing -------------------------------------------------------------------------------- -- Syntax transformation -------------------------------------------------------------------------------- hsGroupVals :: HsGroup GhcRn -> [LHsBindLR 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 unwrapName :: LIEWrappedName a -> Located a unwrapName = reLocN . ieLWrappedName ieLocNames :: IE pass -> [Located (IdP pass)] ieLocNames (XIE _ ) = [] ieLocNames (IEVar _ n ) = [unwrapName n] ieLocNames (IEThingAbs _ n ) = [unwrapName n] ieLocNames (IEThingAll _ n ) = [unwrapName n] ieLocNames (IEThingWith _ n _ ns) = unwrapName n : (map unwrapName ns) 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 ) typeToText :: DynFlags -> Type -> T.Text typeToText flags = T.pack . showSDoc flags . pprIfaceType . toIfaceType 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 = nonDetEltsUniqSet . everything unionUniqSets (emptyVarSet `mkQ` tyCon) where tyCon :: Type -> VarSet tyCon (TyConApp tc _) = unitVarSet $ mkTyVar (tyConName tc) (tyConKind tc) tyCon _ = emptyUniqSet tyVarsOfType :: (Data a) => a -> [Id] tyVarsOfType = nonDetEltsUniqSet . everything unionVarSet (emptyVarSet `mkQ` tyVar) where tyVar :: Type -> VarSet tyVar (TyVarTy ty) = unitVarSet ty tyVar _ = emptyVarSet -------------------------------------------------------------------------------- -- Documentation processing -- Some functions are copied from haddock-api package -------------------------------------------------------------------------------- -- available in GHC.HsToCore.Docs -- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])] -- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -- Take a field of declarations from a data structure and create HsDecls using the given constructor -- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl] classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDeclDocs class_ = collectDocs . sortLocatedA $ decls where decls = docs ++ defs ++ sigs ++ ats 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_ conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] conDeclDocs conDecl = map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con) ) . getConNames $ conDecl selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] selectorDocs con = case getRecConArgs_maybe 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@ClassDecl{} -> concatMap (\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl ) $ classDeclDocs classDecl TyClD _ DataDecl {..} -> concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $ dd_cons tcdDataDefn InstD _ (DataFamInstD _ DataFamInstDecl {..}) -> concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn _ -> [] ) getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of [] -> [] (name : _) -> [name] getMainDeclBinder (SigD _ d) = sigNameNoLoc d getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinder (ForD _ ForeignExport{}) = [] 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 hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name hsDocsToDocH flags rdrEnv = rename flags rdrEnv . overIdentifier (parseIdent flags) . _doc . parseParas Nothing . concatMap unpackHDS 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) DocTable t -> DocTable (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 :: (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 ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x