From e05c48731b6af1a8c71c0f379cf16c7079b93fa3 Mon Sep 17 00:00:00 2001
From: David Waern <davve@dtek.chalmers.se>
Date: Tue, 6 Nov 2007 00:49:21 +0000
Subject: Filter out instances with TyCons that are not exported

---
 src/Haddock/Interface.hs                 | 11 +++++++----
 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])
-- 
cgit v1.2.3