aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs67
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs86
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs8
4 files changed, 90 insertions, 73 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 2d72d117..8f7abd16 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -19,6 +19,7 @@ import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
+import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
@@ -63,16 +64,24 @@ attachInstances expInfo ifaces instIfaceMap mods = do
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
attach index iface = do
- newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap)
+
+ let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
+ getFixity = findFixity iface ifaceMap instIfaceMap
+
+ newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)
(ifaceExportItems iface)
- let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
+ let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)
return $ iface { ifaceExportItems = newItems
, ifaceOrphanInstances = orphanInstances
}
-attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
-attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing)
+attachOrphanInstances
+ :: ExportInfo
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> [ClsInst] -- ^ a list of orphan instances
+ -> [DocInstance GhcRn]
+attachOrphanInstances expInfo getInstDoc cls_instances =
+ [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -80,40 +89,40 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
attachToExportItem
- :: NameEnv ([ClsInst], [FamInst])
+ :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of)
-> ExportInfo
- -> Interface
- -> IfaceMap
- -> InstIfaceMap
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
-attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
+attachToExportItem index expInfo getInstDoc getFixity export =
case attachFixities export of
e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
fam_instances = maybeToList mb_instances >>= snd
- fam_insts = [ ( synifyFamInst i opaque
- , doc
- , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))
+ fam_insts = [ ( synFamInst
+ , getInstDoc n
+ , spanNameE n synFamInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
- , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
, not $ isNameHidden expInfo (fi_fam i)
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
+ , let synFamInst = synifyFamInst i opaque
]
- cls_insts = [ ( synifyInstHead i
- , instLookup instDocMap n iface ifaceMap instIfaceMap
- , spanName n (synifyInstHead i) (L eSpan (tcdName d))
+ cls_insts = [ ( synClsInst
+ , getInstDoc n
+ , spanName n synClsInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
+ , let synClsInst = synifyInstHead i
]
-- fam_insts but with failing type fams filtered out
cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
@@ -133,7 +142,7 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
, n' <- n : (map fst subDocs ++ patsyn_names)
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ , f <- maybeToList (getFixity n')
] }
where
patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
@@ -152,16 +161,20 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
let L l r = spanName s ok linst
in L l (Right r)
+-- | Lookup the doc associated with a certain instance
+findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
+findInstDoc iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceDocMap $ iface) <|>
+ (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap)
+
+-- | Lookup the fixity associated with a certain name
+findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
+findFixity iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceFixMap $ iface) <|>
+ (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap)
-instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
- -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
-instLookup f name iface ifaceMap instIfaceMap =
- case Map.lookup name (f $ toInstalledIface iface) of
- res@(Just _) -> res
- Nothing -> do
- let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
- iface' <- Map.lookup (nameModule name) ifaceMaps
- Map.lookup name (f iface')
--------------------------------------------------------------------------------
-- Collecting and sorting instances
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index b6913012..59ad4fdf 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -135,7 +135,7 @@ rename dflags gre = rn
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
DocModule str -> pure (DocModule str)
- DocHyperlink l -> pure (DocHyperlink l)
+ DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
DocPic str -> pure (DocPic str)
DocMathInline str -> pure (DocMathInline str)
DocMathDisplay str -> pure (DocMathDisplay str)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1c976410..42281470 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -23,15 +23,15 @@ import GHC hiding (NoLink)
import Name
import Outputable ( panic )
import RdrName (RdrName(Exact))
-import PrelNames (eqTyCon_RDR)
+import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
+import Control.Arrow ( first )
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)
-
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =
@@ -92,56 +92,53 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-- Monad for renaming
---
--- The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
--------------------------------------------------------------------------------
+-- | The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
- -> (a,[Name])
+ RnM { unRn :: (Name -> (Bool, DocName))
+ -- Name lookup function. The 'Bool' indicates that if the name
+ -- was \"found\" in the environment.
+
+ -> (a, [Name] -> [Name])
+ -- Value returned, as well as a difference list of the names not
+ -- found
}
instance Monad RnM where
- (>>=) = thenRn
- return = pure
+ m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp
+ (b, out2) = unRn (k a) lkp
+ in (b, out1 . out2)
instance Functor RnM where
- fmap f x = do a <- x; return (f a)
+ fmap f (RnM lkp) = RnM (first f . lkp)
instance Applicative RnM where
- pure = returnRn
- (<*>) = ap
-
-returnRn :: a -> RnM a
-returnRn a = RnM (const (a,[]))
-thenRn :: RnM a -> (a -> RnM b) -> RnM b
-m `thenRn` k = RnM (\lkp -> case unRn m lkp of
- (a,out1) -> case unRn (k a) lkp of
- (b,out2) -> (b,out1++out2))
-
-getLookupRn :: RnM (Name -> (Bool, DocName))
-getLookupRn = RnM (\lkp -> (lkp,[]))
-
-outRn :: Name -> RnM ()
-outRn name = RnM (const ((),[name]))
+ pure a = RnM (const (a, id))
+ mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp
+ (x, out2) = unRn mx lkp
+ in (f x, out1 . out2)
+-- | Look up a 'Name' in the renaming environment.
lookupRn :: Name -> RnM DocName
-lookupRn name = do
- lkp <- getLookupRn
+lookupRn name = RnM $ \lkp ->
case lkp name of
- (False,maps_to) -> do outRn name; return maps_to
- (True, maps_to) -> return maps_to
-
-
-runRnFM :: LinkEnv -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
+ (False,maps_to) -> (maps_to, (name :))
+ (True, maps_to) -> (maps_to, id)
+
+-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
+-- Returns the renamed value along with a list of `Name`'s that could not be
+-- renamed because they weren't in the environment.
+runRnFM :: LinkEnv -> RnM a -> (a, [Name])
+runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist [])
where
- lkp n = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
+ lkp n | isTyVarName n = (True, Undocumented n)
+ | otherwise = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
--------------------------------------------------------------------------------
@@ -600,13 +597,16 @@ renameTyFamInstEqn eqn
rename_ty_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = rhs })
+ rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs })
= do { tc' <- renameL tc
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
; pats' <- mapM renameLType pats
; rhs' <- renameLType rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
@@ -620,6 +620,7 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
; rhs' <- renameLType rhs
; return (L loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = Nothing -- this is always Nothing
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
@@ -633,13 +634,16 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
rename_data_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
- rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = defn })
+ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = defn })
= do { tc' <- renameL tc
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
; pats' <- mapM renameLType pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 30931c26..e9511e3d 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -47,14 +47,13 @@ specialize specs = go spec_map0
-- one by one, we should avoid infinite loops.
spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
+{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}
-- | Instantiate given binders with corresponding types.
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: Data a
- => LHsQTyVars GhcRn -> [HsType GhcRn]
- -> a -> a
+specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
@@ -64,11 +63,12 @@ specializeTyVarBndrs bndrs typs =
bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+
specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> PseudoFamilyDecl GhcRn
-> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
- decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
+ decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)}
specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
generated by cgit v1.2.3 (git 2.39.1) at 2025-02-02 05:56:56 +0000