haddock-api-2.29.0: src/Haddock/Interface/Rename.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2009
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.Rename (renameInterface) where
import Data.Traversable (mapM)
import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
import Haddock.Types
import GHC.Data.Bag (emptyBag)
import GHC hiding (NoLink)
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName(Exact))
import GHC.Builtin.Types (eqTyCon_RDR)
import Control.Applicative
import Control.DeepSeq (force)
import Control.Monad hiding (mapM)
import Control.Monad.Reader
import Control.Monad.Writer.CPS
import Data.Foldable (traverse_)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Prelude hiding (mapM)
import GHC.Types.Basic ( TopLevelFlag(..) )
-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to
-- 'DocName'.
--
-- What this really boils down to is: for each 'Name', figure out which of the
-- modules that export the name is the preferred place to link to.
--
-- The renamed output gets written into fields in the Haddock interface record
-- that were previously left empty.
renameInterface
:: DynFlags
-- ^ GHC session dyn flags
-> Map.Map (Maybe String) (Set.Set String)
-- ^ Ignored symbols. A map from module names to unqualified names. Module
-- 'Just M' mapping to name 'f' means that link warnings should not be
-- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to
-- name 'f' means that link warnings should not be generated for any 'f'.
-> LinkEnv
-- ^ Link environment. A map from 'Name' to 'Module', where name 'n' maps to
-- module 'M' if 'M' is the preferred link destination for name 'n'.
-> Bool
-- ^ Are warnings enabled?
-> Bool
-- ^ Is Hoogle output enabled?
-> Interface
-- ^ The interface we are renaming.
-> Ghc Interface
-- ^ The renamed interface. Note that there is nothing really special about
-- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or
-- even pure, depending on the link warnings are reported.
renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do
let (iface', warnedNames) =
runRnM
dflags
mdl
localLinkEnv
warnName
(hoogle && not (OptHide `elem` ifaceOptions iface))
(renameInterfaceRn iface)
reportMissingLinks mdl warnedNames
return iface'
where
-- The current module
mdl :: Module
mdl = ifaceMod iface
-- The local link environment, where every name exported by this module is
-- mapped to the module itself, and everything else comes from the global
-- renaming env
localLinkEnv :: LinkEnv
localLinkEnv = foldr f renamingEnv (ifaceVisibleExports iface)
where f name !env = Map.insert name mdl env
-- The function used to determine whether we should warn about a name
-- which we do not find in the renaming environment
warnName name =
-- Warnings must be enabled
warnings
-- Current module must not be hidden from Haddock
&& not (OptHide `elem` ifaceOptions iface)
-- Must be an external name that is not built-in syntax, not a type
-- variable, and not '~'
&& isExternalName name
&& not (isBuiltInSyntax name)
&& not (isTyVarName name)
&& Exact name /= eqTyCon_RDR
-- Must not be in the set of ignored symbols for the module or the
-- unqualified ignored symbols
&& not (getOccString name `Set.member` ignoreSet')
where
-- The set of ignored symbols within the module this name is located
-- in unioned with the set of globally ignored symbols
ignoreSet' :: Set.Set String
ignoreSet' =
Set.union
(Map.findWithDefault Set.empty (Just $ modString name) ignoreSet)
(Map.findWithDefault Set.empty Nothing ignoreSet)
modString :: Name -> String
modString = moduleString . nameModule
-- | Output warning messages indicating that the renamer could not find link
-- destinations for the names in the given set as they occur in the given
-- module.
reportMissingLinks :: Module -> Set.Set Name -> Ghc ()
reportMissingLinks mdl names
| Set.null names = return ()
| otherwise =
liftIO $ do
putStrLn $ "Warning: " ++ moduleString mdl ++ ": could not find link destinations for: "
traverse_ (putStrLn . ("\t- " ++) . qualifiedName) names
where
qualifiedName :: Name -> String
qualifiedName name = moduleString (nameModule name) ++ "." ++ getOccString name
--------------------------------------------------------------------------------
-- Monad for renaming
--------------------------------------------------------------------------------
-- | A renaming monad which provides 'MonadReader' access to a renaming
-- environment, and 'MonadWriter' access to a 'Set' of names for which link
-- warnings should be generated, based on the renaming environment.
newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a }
deriving newtype (Functor, Applicative, Monad, MonadReader RnMEnv, MonadWriter (Set.Set Name))
-- | The renaming monad environment. Stores the linking environment (mapping
-- names to modules), the link warning predicate, and the current module.
data RnMEnv = RnMEnv
{ -- | The linking environment (map from names to modules)
rnLinkEnv :: LinkEnv
-- | Link warning predicate (whether failing to find a link destination
-- for a given name should result in a warning)
, rnWarnName :: (Name -> Bool)
-- | The current module
, rnModuleString :: String
-- | Should Hoogle output be generated for this module?
, rnHoogleOutput :: Bool
-- | GHC Session DynFlags, necessary for Hoogle output generation
, rnDynFlags :: DynFlags
}
-- | Run the renamer action in a renaming environment built using the given
-- module, link env, and link warning predicate. Returns the renamed value along
-- with a set of 'Name's that were not renamed and should be warned for (i.e.
-- they satisfied the link warning predicate).
runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name)
runRnM dflags mdl linkEnv warnName hoogleOutput rn =
runWriter $ runReaderT (unRnM rn) rnEnv
where
rnEnv :: RnMEnv
rnEnv = RnMEnv
{ rnLinkEnv = linkEnv
, rnWarnName = warnName
, rnModuleString = moduleString mdl
, rnHoogleOutput = hoogleOutput
, rnDynFlags = dflags
}
--------------------------------------------------------------------------------
-- Renaming
--------------------------------------------------------------------------------
-- | Rename an `Interface` in the renaming environment.
renameInterfaceRn :: Interface -> RnM Interface
renameInterfaceRn iface = do
exportItems <- renameExportItems (ifaceExportItems iface)
orphans <- mapM renameDocInstance (ifaceOrphanInstances iface)
finalModDoc <- renameDocumentation (ifaceDoc iface)
pure $! iface
{ ifaceRnDoc = finalModDoc
-- The un-renamed export items are not used after renaming
, ifaceRnExportItems = exportItems
, ifaceExportItems = []
-- The un-renamed orphan instances are not used after renaming
, ifaceRnOrphanInstances = orphans
, ifaceOrphanInstances = []
}
-- | Lookup a 'Name' in the renaming environment.
lookupRn :: Name -> RnM DocName
lookupRn name = RnM $ do
linkEnv <- asks rnLinkEnv
case Map.lookup name linkEnv of
Nothing -> return $ Undocumented name
Just mdl -> return $ Documented name mdl
-- | Rename a 'Name' in the renaming environment. This is very similar to
-- 'lookupRn', but tracks any names not found in the renaming environment if the
-- `rnWarnName` predicate is true.
renameName :: Name -> RnM DocName
renameName name = do
warnName <- asks rnWarnName
docName <- lookupRn name
case docName of
Undocumented _ -> do
when (warnName name) $
tell $ Set.singleton name
return docName
_ -> return docName
-- | Rename a located 'Name' in the current renaming environment.
renameNameL :: GenLocated l Name -> RnM (GenLocated l DocName)
renameNameL = mapM renameName
-- | Rename a list of export items in the current renaming environment.
renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI]
renameExportItems = mapM renameExportItem
-- | Rename an 'ExportItem' in the current renaming environment.
renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
renameExportItem item = case item of
ExportModule mdl -> return (ExportModule mdl)
ExportGroup lev id_ doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id_ doc')
ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do
-- If Hoogle output should be generated, generate it
RnMEnv{..} <- ask
let !hoogleOut = force $
if rnHoogleOutput then
ppExportD rnDynFlags ed
else
[]
decl' <- renameLDecl decl
pats' <- renamePats pats
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
instances' <- forM instances renameDocInstance
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
return $
ExportDecl RnExportD
{ rnExpDExpD = ExportD decl' pats' doc' subs' instances' fixities' splice
, rnExpDHoogle = hoogleOut
}
ExportNoDecl x subs -> do
x' <- lookupRn x
subs' <- mapM lookupRn subs
return (ExportNoDecl x' subs')
ExportDoc doc -> do
doc' <- renameDoc doc
return (ExportDoc doc')
renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
renameDocForDecl (doc, fnArgsDoc) =
(,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
renameDocumentation (Documentation mDoc mWarning) =
Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))
renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) []))
renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
renameDoc = traverse (traverse renameName)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType
renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI)
renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty
; return $ HsValArg ty' }
renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki
; return $ HsTypeArg l ki' }
renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
renameLSigType = mapM renameSigType
renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)
renameLSigWcType = renameWc renameLSigType
renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI)
renameLKind = renameLType
renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind
renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)
renameFamilyResultSig (L loc (NoSig _))
= return (L loc (NoSig noExtField))
renameFamilyResultSig (L loc (KindSig _ ki))
= do { ki' <- renameLKind ki
; return (L loc (KindSig noExtField ki')) }
renameFamilyResultSig (L loc (TyVarSig _ bndr))
= do { bndr' <- renameLTyVarBndr bndr
; return (L loc (TyVarSig noExtField bndr')) }
renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs))
= do { lhs' <- renameNameL lhs
; rhs' <- mapM renameNameL rhs
; return (L loc (InjectivityAnn noExtField lhs' rhs')) }
renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-> RnM (Maybe (LInjectivityAnn DocNameI))
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)
renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))
renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))
renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
HsForAllTy { hst_tele = tele, hst_body = ltype } -> do
tele' <- renameHsForAllTelescope tele
ltype' <- renameLType ltype
return (HsForAllTy { hst_xforall = noAnn
, hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n
HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype
HsStarTy _ isUni -> return (HsStarTy noAnn isUni)
HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
return (HsAppTy noAnn a' b')
HsAppKindTy _ a b -> do
a' <- renameLType a
b' <- renameLKind b
return (HsAppKindTy noAnn a' b')
HsFunTy _ w a b -> do
a' <- renameLType a
b' <- renameLType b
w' <- renameArrow w
return (HsFunTy noAnn w' a' b')
HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty
HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty)
HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
HsOpTy _ prom a (L loc op) b -> do
op' <- renameName op
a' <- renameLType a
b' <- renameLType b
return (HsOpTy noAnn prom a' (L loc op') b')
HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
return (HsKindSig noAnn ty' k')
HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
return (HsDocTy noAnn ty' doc')
HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x))
HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a
XHsType a -> pure (XHsType a)
HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b
HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b
HsSpliceTy (HsUntypedSpliceTop _ st) _ -> renameType (unLoc st)
HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice"
HsWildCardTy _ -> pure (HsWildCardTy noAnn)
renameTyLit :: HsTyLit GhcRn -> HsTyLit DocNameI
renameTyLit t = case t of
HsNumTy _ v -> HsNumTy noExtField v
HsStrTy _ v -> HsStrTy noExtField v
HsCharTy _ v -> HsCharTy noExtField v
renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
bndrs' <- renameOuterTyVarBndrs bndrs
body' <- renameLType body
pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
; return (HsQTvs { hsq_ext = noExtField
, hsq_explicit = tvs' }) }
renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)
renameHsForAllTelescope tele = case tele of
HsForAllVis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
pure $ HsForAllVis noExtField bndrs'
HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
pure $ HsForAllInvis noExtField bndrs'
renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)
renameLTyVarBndr (L loc (UserTyVar _ fl (L l n)))
= do { n' <- renameName n
; return (L loc (UserTyVar noExtField fl (L l n'))) }
renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind))
= do { n' <- renameName n
; kind' <- renameLKind kind
; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) }
renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI])
renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- renameName ihdClsName
types <- mapM renameType ihdTypes
itype <- case ihdInstType of
ClassInst { .. } -> ClassInst
<$> mapM renameType clsiCtx
<*> renameLHsQTyVars clsiTyVars
<*> mapM renameSig clsiSigs
<*> mapM renamePseudoFamilyDecl clsiAssocTys
TypeInst ts -> TypeInst <$> traverse renameType ts
DataInst dd -> DataInst <$> renameTyClD dd
return InstHead
{ ihdClsName = cname
, ihdTypes = types
, ihdInstType = itype
}
renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)]
renamePats = mapM
(\(d,doc) -> do { d' <- renameDecl d
; doc' <- renameDocForDecl doc
; return (d',doc')})
renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
TyClD _ d -> do
d' <- renameTyClD d
return (TyClD noExtField d')
SigD _ s -> do
s' <- renameSig s
return (SigD noExtField s')
ForD _ d -> do
d' <- renameForD d
return (ForD noExtField d')
InstD _ d -> do
d' <- renameInstD d
return (InstD noExtField d')
DerivD _ d -> do
d' <- renameDerivD d
return (DerivD noExtField d')
_ -> error "renameDecl"
renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI))
renameLThing fn (L loc x) = return . L (locA loc) =<< fn x
renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI)
renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
FamDecl { tcdFam = decl } -> do
decl' <- renameFamilyDecl decl
return (FamDecl { tcdFExt = noExtField, tcdFam = decl' })
SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do
lname' <- renameNameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars'
, tcdFixity = fixity, tcdRhs = rhs' })
DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do
lname' <- renameNameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars'
, tcdFixity = fixity, tcdDataDefn = defn' })
ClassDecl { tcdLayout = layout
, tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- traverse renameLContext lcontext
lname' <- renameNameL lname
ltyvars' <- renameLHsQTyVars ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM (renameLThing renameFamilyDecl) ats
at_defs' <- mapM (mapM renameTyFamDefltD) at_defs
-- we don't need the default methods or the already collected doc entities
return (ClassDecl { tcdCExt = noExtField
, tcdLayout = renameLayoutInfo layout
, tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
, tcdFixity = fixity
, tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
, tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [] })
where
renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)
renameLFunDep (L loc (FunDep _ xs ys)) = do
xs' <- mapM renameName (map unLoc xs)
ys' <- mapM renameName (map unLoc ys)
return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys')))
renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig
renameLayoutInfo :: LayoutInfo GhcRn -> LayoutInfo DocNameI
renameLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb
renameLayoutInfo (VirtualBraces n) = VirtualBraces n
renameLayoutInfo NoLayoutInfo = NoLayoutInfo
renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdTyVars = ltyvars
, fdFixity = fixity
, fdResultSig = result
, fdInjectivityAnn = injectivity }) = do
info' <- renameFamilyInfo info
lname' <- renameNameL lname
ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel
, fdLName = lname'
, fdTyVars = ltyvars'
, fdFixity = fixity
, fdResultSig = result'
, fdInjectivityAnn = injectivity' })
renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
-> RnM (PseudoFamilyDecl DocNameI)
renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
<$> renameFamilyInfo pfdInfo
<*> renameNameL pfdLName
<*> mapM renameLType pfdTyVars
<*> renameFamilyResultSig pfdKindSig
renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI)
renameFamilyInfo DataFamily = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
renameFamilyInfo (ClosedTypeFamily eqns)
= do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns
; return $ ClosedTypeFamily eqns' }
renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)
renameDataDefn (HsDataDefn { dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k, dd_cons = cons }) = do
lcontext' <- traverse renameLContext lcontext
k' <- renameMaybeLKind k
cons' <- mapM (mapMA renameCon) cons
-- I don't think we need the derivings, so we return Nothing
return (HsDataDefn { dd_ext = noExtField
, dd_ctxt = lcontext', dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
, dd_derivs = [] })
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc
, con_forall = forall_ }) = do
lname' <- renameNameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameH98Details details
mbldoc' <- mapM (renameLDocHsSyn) mbldoc
return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
, con_forall = forall_ -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
, con_dcolon = dcol
, con_mb_cxt = lcontext, con_g_args = details
, con_res_ty = res_ty
, con_doc = mbldoc } = do
lnames' <- mapM renameNameL lnames
bndrs' <- mapM renameOuterTyVarBndrs bndrs
lcontext' <- traverse renameLContext lcontext
details' <- renameGADTDetails details
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (ConDeclGADT
{ con_g_ext = noExtField, con_names = lnames'
, con_dcolon = dcol, con_bndrs = bndrs'
, con_mb_cxt = lcontext', con_g_args = details'
, con_res_ty = res_ty', con_doc = mbldoc' })
renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
-> RnM (HsScaled DocNameI (LHsType DocNameI))
renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty
renameH98Details :: HsConDeclH98Details GhcRn
-> RnM (HsConDeclH98Details DocNameI)
renameH98Details (RecCon (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
return (RecCon (L (locA l) fields'))
renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps
renameH98Details (InfixCon a b) = do
a' <- renameHsScaled a
b' <- renameHsScaled b
return (InfixCon a' b')
renameGADTDetails :: HsConDeclGADTDetails GhcRn
-> RnM (HsConDeclGADTDetails DocNameI)
renameGADTDetails (RecConGADT (L l fields) arr) = do
fields' <- mapM renameConDeclFieldField fields
return (RecConGADT (L (locA l) fields') arr)
renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
return $ L (locA l) (ConDeclField noExtField names' t' doc')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc sel lbl)) = do
sel' <- renameName sel
return $ L l (FieldOcc sel' lbl)
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
TypeSig _ lnames ltype -> do
lnames' <- mapM renameNameL lnames
ltype' <- renameLSigWcType ltype
return (TypeSig noExtField lnames' ltype')
ClassOpSig _ is_default lnames sig_ty -> do
lnames' <- mapM renameNameL lnames
ltype' <- renameLSigType sig_ty
return (ClassOpSig noExtField is_default lnames' ltype')
PatSynSig _ lnames sig_ty -> do
lnames' <- mapM renameNameL lnames
sig_ty' <- renameLSigType sig_ty
return $ PatSynSig noExtField lnames' sig_ty'
FixSig _ (FixitySig _ lnames fixity) -> do
lnames' <- mapM renameNameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ (L l s) -> do
s' <- traverse (traverse lookupRn) s
return $ MinimalSig noExtField (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport _ lname ltype x) = do
lname' <- renameNameL lname
ltype' <- renameLSigType ltype
return (ForeignImport noExtField lname' ltype' (renameForI x))
renameForD (ForeignExport _ lname ltype x) = do
lname' <- renameNameL lname
ltype' <- renameLSigType ltype
return (ForeignExport noExtField lname' ltype' (renameForE x))
renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI
renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec
renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI
renameForE (CExport _ spec) = CExport noExtField spec
renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
d' <- renameClsInstD d
return (ClsInstD { cid_d_ext = noExtField, cid_inst = d' })
renameInstD (TyFamInstD { tfid_inst = d }) = do
d' <- renameTyFamInstD d
return (TyFamInstD { tfid_ext = noExtField, tfid_inst = d' })
renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' })
renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode }) = do
ty' <- renameLSigWcType ty
strat' <- mapM (mapM renameDerivStrategy) strat
return (DerivDecl { deriv_ext = noExtField
, deriv_type = ty'
, deriv_strategy = strat'
, deriv_overlap_mode = omode })
renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI)
renameDerivStrategy (StockStrategy a) = pure (StockStrategy a)
renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a)
renameDerivStrategy (NewtypeStrategy a) = pure (NewtypeStrategy a)
renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty
renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
, cid_datafam_insts = lADTs }) = do
ltype' <- renameLSigType ltype
lATs' <- mapM (mapM renameTyFamInstD) lATs
lADTs' <- mapM (mapM renameDataFamInstD) lADTs
return (ClsInstDecl { cid_ext = noExtField, cid_overlap_mode = omode
, cid_poly_ty = ltype', cid_binds = emptyBag
, cid_sigs = []
, cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
= do { eqn' <- renameTyFamInstEqn eqn
; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) }
renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = rhs })
= do { tc' <- renameNameL tc
; bndrs' <- renameOuterTyVarBndrs bndrs
; pats' <- mapM renameLTypeArg pats
; rhs' <- renameLType rhs
; return (FamEqn { feqn_ext = noExtField
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)
renameTyFamDefltD = renameTyFamInstD
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
= do { eqn' <- rename_data_fam_eqn eqn
; return (DataFamInstDecl { dfid_eqn = eqn' }) }
where
rename_data_fam_eqn
:: FamEqn GhcRn (HsDataDefn GhcRn)
-> RnM (FamEqn DocNameI (HsDataDefn DocNameI))
rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = defn })
= do { tc' <- renameNameL tc
; bndrs' <- renameOuterTyVarBndrs bndrs
; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExtField
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
-> RnM (HsOuterTyVarBndrs flag DocNameI)
renameOuterTyVarBndrs (HsOuterImplicit{}) =
pure $ HsOuterImplicit{hso_ximplicit = noExtField}
renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =
HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs GhcRn in_thing
-> RnM (HsWildCardBndrs DocNameI out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
, hswc_ext = noExtField }) }
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n, m) = do
inst' <- renameInstHead inst
n' <- renameName n
idoc' <- mapM renameDoc idoc
return (inst', idoc', L l n', m)
renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
renameSub (n,doc) = do
n' <- renameName n
doc' <- renameDocForDecl doc
return (n', doc')