diff options
| -rw-r--r-- | src/Haddock/Interface.hs | 11 | ||||
| -rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 22 |
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]) |