aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Haddock/Interface.hs11
-rw-r--r--src/Haddock/Interface/AttachInstances.hs22
2 files changed, 23 insertions, 10 deletions
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index e27aefb1..4b178bf4 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -41,12 +41,15 @@ createInterfaces modules externalLinks flags = (interfaces, homeLinks, messages)
-- part 1, create the interfaces
interfaces <- createInterfaces' modules flags
- -- part 2, attach the instances
- let interfaces' = attachInstances interfaces
-
- -- part 3, rename the interfaces
+ -- part 2, build the link environment
let homeLinks = buildHomeLinks interfaces
let links = homeLinks `Map.union` externalLinks
+ let allNames = Map.keys links
+
+ -- part 3, attach the instances
+ let interfaces' = attachInstances interfaces allNames
+
+ -- part 3, rename the interfaces
interfaces'' <- mapM (renameInterface links) interfaces'
return (interfaces'', homeLinks)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 8e81d8a6..f5140401 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -28,10 +28,13 @@ import FastString
#define FSLIT(x) (mkFastString# (x#))
-attachInstances :: [Interface] -> [Interface]
-attachInstances modules = map attach modules
+attachInstances :: [Interface] -> [Name] -> [Interface]
+attachInstances modules filterNames = map attach modules
where
- instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules
+ instMap =
+ fmap (map toHsInstHead . sortImage instHead) $
+ collectInstances modules filterNames
+
attach mod = mod { ifaceExportItems = newItems }
where
newItems = map attachExport (ifaceExportItems mod)
@@ -43,6 +46,11 @@ attachInstances modules = map attach modules
attachExport otherExport = otherExport
+--------------------------------------------------------------------------------
+-- Collecting and sorting instances
+--------------------------------------------------------------------------------
+
+
-- | Simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
@@ -50,17 +58,19 @@ data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
collectInstances
:: [Interface]
+ -> [Name]
-> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
-collectInstances modules
+collectInstances modules filterNames
= Map.fromListWith (flip (++)) tyInstPairs `Map.union`
Map.fromListWith (flip (++)) classInstPairs
where
allInstances = concat (map ifaceInstances modules)
classInstPairs = [ (is_cls inst, [instanceHead inst]) |
- inst <- allInstances ]
+ inst <- allInstances, Just n <- nub (is_tcs inst),
+ n `elem` filterNames ]
tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
- Just tycon <- nub (is_tcs inst) ]
+ Just tycon <- nub (is_tcs inst) ]
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])