Merge branch 'hidden-instances' into ghc-7.6

7 files changed, 422 insertions, 7 deletions

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index dcd794af..5a8e8485 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -43,6 +43,7 @@ import Haddock.Utils
 import Control.Monad
 import Data.List
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import Distribution.Verbosity
 import System.Directory
 import System.FilePath
@@ -72,8 +73,12 @@ processModules verbosity modules flags extIfaces = do
                                    , iface <- ifInstalledIfaces ext ]
   interfaces <- createIfaces0 verbosity modules flags instIfaceMap
 
+  let exportedNames =
+        Set.unions $ map (Set.fromList . ifaceExports) $
+        filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
+      mods = Set.fromList $ map ifaceMod interfaces
   out verbosity verbose "Attaching instances..."
-  interfaces' <- attachInstances interfaces instIfaceMap
+  interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap
 
   out verbosity verbose "Building cross-linking environment..."
   -- Combine the link envs of the external packages into one
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 50451666..ebe62cb6 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -20,6 +20,7 @@ import Haddock.Convert
 import Control.Arrow
 import Data.List
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import GHC
 import Name
@@ -36,21 +37,24 @@ import PrelNames
 import FastString
 #define FSLIT(x) (mkFastString# (x#))
 
+type ExportedNames = Set.Set Name
+type Modules = Set.Set Module
+type ExportInfo = (ExportedNames, Modules)
 
-attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances ifaces instIfaceMap = mapM attach ifaces
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
   where
     -- TODO: take an IfaceMap as input
     ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
 
     attach iface = do
-      newItems <- mapM (attachToExportItem iface ifaceMap instIfaceMap)
+      newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
                        (ifaceExportItems iface)
       return $ iface { ifaceExportItems = newItems }
 
 
-attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
-attachToExportItem iface ifaceMap instIfaceMap export =
+attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
+attachToExportItem expInfo iface ifaceMap instIfaceMap export =
   case export of
     ExportDecl { expItemDecl = L _ (TyClD d) } -> do
       mb_info <- getAllInfo (unLoc (tcdLName d))
@@ -59,7 +63,8 @@ attachToExportItem iface ifaceMap instIfaceMap export =
               expItemInstances =
                 case mb_info of
                   Just (_, _, instances) ->
-                    let insts = map (first synifyInstHead) $ sortImage (first instHead)
+                    let insts = map (first synifyInstHead) $ sortImage (first instHead) $
+                                filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys)
                                 [ (instanceHead i, getName i) | i <- instances ]
                     in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
                        | (inst, name) <- insts ]
@@ -143,3 +148,42 @@ funTyConName = mkWiredInName gHC_PRIM
                         funTyConKey
                         (ATyCon funTyCon)       -- Relevant TyCon
                         BuiltInSyntax
+
+--------------------------------------------------------------------------------
+-- Filtering hidden instances
+--------------------------------------------------------------------------------
+
+-- | A class or data type is hidden iff
+--
+-- * it is defined in one of the modules that are being processed
+--
+-- * and it is not exported by any non-hidden module
+isNameHidden :: ExportInfo -> Name -> Bool
+isNameHidden (names, modules) name =
+  nameModule name `Set.member` modules &&
+  not (name `Set.member` names)
+
+-- | We say that an instance is «hidden» iff its class or any (part)
+-- of its type(s) is hidden.
+isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool
+isInstanceHidden expInfo cls tys =
+    instClassHidden || instTypeHidden
+  where
+    instClassHidden :: Bool
+    instClassHidden = isNameHidden expInfo $ getName cls
+
+    instTypeHidden :: Bool
+    instTypeHidden = any typeHidden tys
+
+    nameHidden :: Name -> Bool
+    nameHidden = isNameHidden expInfo
+
+    typeHidden :: Type -> Bool
+    typeHidden t =
+      case t of
+        TyVarTy {} -> False
+        AppTy t1 t2 -> typeHidden t1 || typeHidden t2
+        TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
+        FunTy t1 t2 -> typeHidden t1 || typeHidden t2
+        ForAllTy _ ty -> typeHidden ty
+        LitTy _ -> False
diff --git a/tests/html-tests/tests/HiddenInstances.hs b/tests/html-tests/tests/HiddenInstances.hs
new file mode 100644
index 00000000..99a6c2fd
--- /dev/null
+++ b/tests/html-tests/tests/HiddenInstances.hs
@@ -0,0 +1,35 @@
+-- http://trac.haskell.org/haddock/ticket/37
+module HiddenInstances (VisibleClass, VisibleData) where
+
+-- | Should be visible
+class VisibleClass a
+
+-- | Should *not* be visible
+class HiddenClass a
+
+-- | Should *not* be visible
+data HiddenData = HiddenData
+
+-- | Should be visible
+data VisibleData = VisibleData
+
+-- | Should be visible
+instance VisibleClass Int
+
+-- | Should be visible
+instance VisibleClass VisibleData
+
+-- | Should be visible
+instance Num VisibleData
+
+-- | Should *not* be visible
+instance VisibleClass HiddenData
+
+-- | Should *not* be visible
+instance HiddenClass Int
+
+-- | Should *not* be visible
+instance HiddenClass VisibleData
+
+-- | Should *not* be visible
+instance HiddenClass HiddenData
diff --git a/tests/html-tests/tests/HiddenInstances.html.ref b/tests/html-tests/tests/HiddenInstances.html.ref
new file mode 100644
index 00000000..c1b75927
--- /dev/null
+++ b/tests/html-tests/tests/HiddenInstances.html.ref
@@ -0,0 +1,169 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >HiddenInstances</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html");};
+//]]>
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href=""
+	  >Contents</a
+	  ></li
+	><li
+	><a href=""
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption" class="empty"
+      >&nbsp;</p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >None</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>HiddenInstances</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><span class="keyword"
+	    >class</span
+	    >  <a href=""
+	    >VisibleClass</a
+	    > a </li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    >  <a href=""
+	    >VisibleData</a
+	    > </li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >class</span
+	    >  <a name="t:VisibleClass" class="def"
+	    >VisibleClass</a
+	    > a </p
+	  ><div class="doc"
+	  ><p
+	    >Should be visible
+</p
+	    ></div
+	  ><div class="subs instances"
+	  ><p id="control.i:VisibleClass" class="caption collapser" onclick="toggleSection('i:VisibleClass')"
+	    >Instances</p
+	    ><div id="section.i:VisibleClass" class="show"
+	    ><table
+	      ><tr
+		><td class="src"
+		  ><a href=""
+		    >VisibleClass</a
+		    > <a href=""
+		    >Int</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible
+</p
+		    ></td
+		  ></tr
+		><tr
+		><td class="src"
+		  ><a href=""
+		    >VisibleClass</a
+		    > <a href=""
+		    >VisibleData</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible
+</p
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    >  <a name="t:VisibleData" class="def"
+	    >VisibleData</a
+	    >  </p
+	  ><div class="doc"
+	  ><p
+	    >Should be visible
+</p
+	    ></div
+	  ><div class="subs instances"
+	  ><p id="control.i:VisibleData" class="caption collapser" onclick="toggleSection('i:VisibleData')"
+	    >Instances</p
+	    ><div id="section.i:VisibleData" class="show"
+	    ><table
+	      ><tr
+		><td class="src"
+		  ><a href=""
+		    >Num</a
+		    > <a href=""
+		    >VisibleData</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible
+</p
+		    ></td
+		  ></tr
+		><tr
+		><td class="src"
+		  ><a href=""
+		    >VisibleClass</a
+		    > <a href=""
+		    >VisibleData</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible
+</p
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ><p
+      >Produced by <a href=""
+	>Haddock</a
+	> version 2.10.0</p
+      ></div
+    ></body
+  ></html
+>
diff --git a/tests/html-tests/tests/HiddenInstancesA.hs b/tests/html-tests/tests/HiddenInstancesA.hs
new file mode 100644
index 00000000..f1775208
--- /dev/null
+++ b/tests/html-tests/tests/HiddenInstancesA.hs
@@ -0,0 +1,17 @@
+{-# OPTIONS_HADDOCK hide #-}
+module HiddenInstancesA where
+
+-- | Should be visible
+class Foo a
+
+-- | Should be visible
+data Bar
+
+-- | Should be visible
+instance Foo Bar
+
+-- | Should *not* be visible
+data Baz
+
+-- | Should *not* be visible
+instance Foo Baz
diff --git a/tests/html-tests/tests/HiddenInstancesB.hs b/tests/html-tests/tests/HiddenInstancesB.hs
new file mode 100644
index 00000000..eabf0637
--- /dev/null
+++ b/tests/html-tests/tests/HiddenInstancesB.hs
@@ -0,0 +1,2 @@
+module HiddenInstancesB (Foo, Bar) where
+import HiddenInstancesA
diff --git a/tests/html-tests/tests/HiddenInstancesB.html.ref b/tests/html-tests/tests/HiddenInstancesB.html.ref
new file mode 100644
index 00000000..4d037bec
--- /dev/null
+++ b/tests/html-tests/tests/HiddenInstancesB.html.ref
@@ -0,0 +1,143 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >HiddenInstancesB</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstancesB.html");};
+//]]>
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href=""
+	  >Contents</a
+	  ></li
+	><li
+	><a href=""
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      >&nbsp;</p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >None</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>HiddenInstancesB</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><span class="keyword"
+	    >class</span
+	    >  <a href=""
+	    >Foo</a
+	    > a </li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    >  <a href=""
+	    >Bar</a
+	    > </li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >class</span
+	    >  <a name="t:Foo" class="def"
+	    >Foo</a
+	    > a </p
+	  ><div class="doc"
+	  ><p
+	    >Should be visible
+</p
+	    ></div
+	  ><div class="subs instances"
+	  ><p id="control.i:Foo" class="caption collapser" onclick="toggleSection('i:Foo')"
+	    >Instances</p
+	    ><div id="section.i:Foo" class="show"
+	    ><table
+	      ><tr
+		><td class="src"
+		  ><a href=""
+		    >Foo</a
+		    > <a href=""
+		    >Bar</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible
+</p
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    >  <a name="t:Bar" class="def"
+	    >Bar</a
+	    >  </p
+	  ><div class="doc"
+	  ><p
+	    >Should be visible
+</p
+	    ></div
+	  ><div class="subs instances"
+	  ><p id="control.i:Bar" class="caption collapser" onclick="toggleSection('i:Bar')"
+	    >Instances</p
+	    ><div id="section.i:Bar" class="show"
+	    ><table
+	      ><tr
+		><td class="src"
+		  ><a href=""
+		    >Foo</a
+		    > <a href=""
+		    >Bar</a
+		    ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible
+</p
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ><p
+      >Produced by <a href=""
+	>Haddock</a
+	> version 2.11.0</p
+      ></div
+    ></body
+  ></html
+>