aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Cheplyaka <roma@ro-che.info>2012-06-13 14:31:22 +0300
committerRoman Cheplyaka <roma@ro-che.info>2012-07-27 13:00:13 +0300
commit2cbeae0385bddcd294a5b80a4e2c86b66ff3e1cc (patch)
treed807dbd5532e94c1b506e7350fceb2062bf81a8c
parent8b71c997072cfc40af62b0557a973e0754e843b6 (diff)
Hide "internal" instances
This fixes #37 (http://trac.haskell.org/haddock/ticket/37) Precisely, we show an instance iff its class and all the types are exported by non-hidden modules.
-rw-r--r--src/Haddock/Interface.hs7
-rw-r--r--src/Haddock/Interface/AttachInstances.hs55
2 files changed, 55 insertions, 7 deletions
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 09f01883..0003cba2 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
@@ -71,8 +72,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 c012f2e0..089f31b4 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 ]
@@ -140,3 +145,41 @@ 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