From 1483f369caaacc25e07f9715b15e49c35205b417 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 13:37:02 +0200 Subject: Use LANGUAGE pragmas instead of default-extensions in cabal file --- src/Haddock/Interface/AttachInstances.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Haddock/Interface/AttachInstances.hs') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index c012f2e0..d9f4350f 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances -- cgit v1.2.3 From 2cbeae0385bddcd294a5b80a4e2c86b66ff3e1cc Mon Sep 17 00:00:00 2001 From: Roman Cheplyaka Date: Wed, 13 Jun 2012 14:31:22 +0300 Subject: 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. --- src/Haddock/Interface.hs | 7 +++- src/Haddock/Interface/AttachInstances.hs | 55 ++++++++++++++++++++++++++++---- 2 files changed, 55 insertions(+), 7 deletions(-) (limited to 'src/Haddock/Interface/AttachInstances.hs') 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 -- cgit v1.2.3 From 42422b76fd65dfd37ada0d4da5a85fdf30bf0fa2 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 7 Sep 2012 14:29:27 +0200 Subject: Follow changes in GHC. --- src/Haddock/Interface/AttachInstances.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src/Haddock/Interface/AttachInstances.hs') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 8fff4d7a..ebe62cb6 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -186,3 +186,4 @@ isInstanceHidden expInfo cls tys = TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args FunTy t1 t2 -> typeHidden t1 || typeHidden t2 ForAllTy _ ty -> typeHidden ty + LitTy _ -> False -- cgit v1.2.3 From 6ccf78e15a525282fef61bc4f58a279aa9c21771 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 28 Sep 2012 19:50:20 +0200 Subject: Fix spurious superclass constraints bug. --- src/Haddock/Interface/AttachInstances.hs | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) (limited to 'src/Haddock/Interface/AttachInstances.hs') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index ebe62cb6..4b5f159d 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -22,19 +22,20 @@ import Data.List import qualified Data.Map as Map import qualified Data.Set as Set -import GHC -import Name -import InstEnv import Class +import FastString +import GHC import GhcMonad (withSession) -import TysPrim( funTyCon ) +import Id +import InstEnv import MonadUtils (liftIO) +import Name +import PrelNames import TcRnDriver (tcRnGetInfo) +import TyCon import TypeRep +import TysPrim( funTyCon ) import Var hiding (varName) -import TyCon -import PrelNames -import FastString #define FSLIT(x) (mkFastString# (x#)) type ExportedNames = Set.Set Name @@ -65,7 +66,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = Just (_, _, instances) -> let insts = map (first synifyInstHead) $ sortImage (first instHead) $ filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys) - [ (instanceHead i, getName i) | i <- instances ] + [ (instanceHead' i, getName i) | i <- instances ] in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap) | (inst, name) <- insts ] Nothing -> [] @@ -94,6 +95,20 @@ lookupInstDoc name iface ifaceMap instIfaceMap = modName = nameModule name +-- | Like GHC's 'instanceHead' but drops "silent" arguments. +instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) +instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) + where + dfun = is_dfun ispec + (tvs, theta, cls, tys) = instanceHead ispec + + +-- | Drop "silent" arguments. See GHC Note [Silent superclass +-- arguments]. +dropSilentArgs :: DFunId -> ThetaType -> ThetaType +dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta + + -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst])) -- cgit v1.2.3