aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/AttachInstances.hs91
-rw-r--r--src/Haddock/Interface/Create.hs100
-rw-r--r--src/Haddock/Interface/LexParseRn.hs4
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs1
-rw-r--r--src/Haddock/Interface/Rename.hs63
5 files changed, 175 insertions, 84 deletions
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 427ef84d..04c4e5e1 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
@@ -20,37 +20,42 @@ 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
-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
+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 (tcdName d)
@@ -61,6 +66,11 @@ attachToExportItem iface ifaceMap instIfaceMap export =
Just (_, _, instances) ->
let insts = map (first synifyInstHead) $ sortImage (first instHead)
[ (instanceSig i, getName i) | i <- instances ]
+{- FIXME
+ 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 ]
Nothing -> []
@@ -89,6 +99,22 @@ lookupInstDoc name iface ifaceMap instIfaceMap =
modName = nameModule name
+-- | Like GHC's 'instanceHead' but drops "silent" arguments.
+{- FIXME
+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]))
@@ -143,3 +169,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/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 8f429d9c..40016a0b 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Create
@@ -40,7 +41,7 @@ import Name
import Bag
import RdrName
import TcRnTypes
-import FastString (unpackFS)
+import FastString (unpackFS, concatFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -89,8 +90,11 @@ createInterface tm flags modMap instIfaceMap = do
liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
- let warningMap = mkWarningMap warnings gre exportedNames
- exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
+ warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
+
+ let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
+
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports
instances instIfaceMap dflags
let !visibleNames = mkVisibleNames exportItems opts
@@ -111,26 +115,29 @@ createInterface tm flags modMap instIfaceMap = do
let !aliases =
mkAliasMap dflags $ tm_renamed_source tm
+ modWarn <- liftErrMsg $ moduleWarning dflags gre warnings
+
return $! Interface {
- ifaceMod = mdl,
- ifaceOrigFilename = msHsFilePath ms,
- ifaceInfo = info,
- ifaceDoc = Documentation mbDoc (moduleWarning warnings),
- ifaceRnDoc = Documentation Nothing Nothing,
- ifaceOptions = opts,
- ifaceDocMap = docMap,
- ifaceArgMap = argMap,
- ifaceRnDocMap = M.empty,
- ifaceRnArgMap = M.empty,
- ifaceExportItems = prunedExportItems,
- ifaceRnExportItems = [],
- ifaceExports = exportedNames,
- ifaceVisibleExports = visibleNames,
- ifaceDeclMap = declMap,
- ifaceSubMap = subMap,
- ifaceModuleAliases = aliases,
- ifaceInstances = instances,
- ifaceHaddockCoverage = coverage
+ ifaceMod = mdl
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceSubMap = subMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
}
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -166,31 +173,35 @@ lookupModuleDyn dflags Nothing mdlName =
-- Warnings
-------------------------------------------------------------------------------
-type WarningMap = DocMap Name
-
-mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
-mkWarningMap NoWarnings _ _ = M.empty
-mkWarningMap (WarnAll _) _ _ = M.empty
-mkWarningMap (WarnSome ws) gre exps = M.fromList
- [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
- , let n = gre_name elt, n `elem` exps ]
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap dflags warnings gre exps = case warnings of
+ NoWarnings -> return M.empty
+ WarnAll _ -> return M.empty
+ WarnSome ws -> do
+ let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+ M.fromList <$> mapM parse ws'
+ where
+ parse (n, w) = (,) n <$> parseWarning dflags gre w
-moduleWarning :: Warnings -> Maybe (Doc id)
-moduleWarning ws =
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning dflags gre ws =
case ws of
- NoWarnings -> Nothing
- WarnSome _ -> Nothing
- WarnAll w -> Just $! warnToDoc w
-
-
-warnToDoc :: WarningTxt -> Doc id
-warnToDoc w = case w of
- (DeprecatedTxt msg) -> format "Deprecated: " msg
- (WarningTxt msg) -> format "Warning: " msg
+ NoWarnings -> return Nothing
+ WarnSome _ -> return Nothing
+ WarnAll w -> Just <$> parseWarning dflags gre w
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning dflags gre w = do
+ r <- case w of
+ (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)
+ (WarningTxt msg) -> format "Warning: " (concatFS msg)
+ r `deepseq` return r
where
- format x xs = let !str = force $ concat (x : map unpackFS xs)
- in DocWarning $ DocParagraph $ DocString str
+ format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
+ . fromMaybe (DocString . unpackFS $ xs)
+ <$> processDocString dflags gre (HsDocString xs)
-------------------------------------------------------------------------------
@@ -703,6 +714,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
f x xs = x : xs
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
@@ -777,7 +789,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
--- | Keep exprt items with docs.
+-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
where
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 8070b137..ced12d8d 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -117,9 +118,10 @@ rename dflags gre = rn
DocCodeBlock doc -> DocCodeBlock (rn doc)
DocIdentifierUnchecked x -> DocIdentifierUnchecked x
DocModule str -> DocModule str
- DocURL str -> DocURL str
+ DocHyperlink l -> DocHyperlink l
DocPic str -> DocPic str
DocAName str -> DocAName str
+ DocProperty p -> DocProperty p
DocExamples e -> DocExamples e
DocEmpty -> DocEmpty
DocString str -> DocString str
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 411b6661..18f4c768 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.ParseModuleHeader
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b384886c..a2499726 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -82,42 +82,41 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-newtype GenRnM n a =
- RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function
- -> (a,[n])
+newtype RnM a =
+ RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
+ -> (a,[Name])
}
-type RnM a = GenRnM Name a
-
-instance Monad (GenRnM n) where
+instance Monad RnM where
(>>=) = thenRn
return = returnRn
-instance Functor (GenRnM n) where
+instance Functor RnM where
fmap f x = do a <- x; return (f a)
-instance Applicative (GenRnM n) where
+instance Applicative RnM where
pure = return
(<*>) = ap
-returnRn :: a -> GenRnM n a
+returnRn :: a -> RnM a
returnRn a = RnM (const (a,[]))
-thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
+thenRn :: RnM a -> (a -> RnM b) -> RnM b
m `thenRn` k = RnM (\lkp -> case unRn m lkp of
(a,out1) -> case unRn (k a) lkp of
(b,out2) -> (b,out1++out2))
getLookupRn :: RnM (Name -> (Bool, DocName))
getLookupRn = RnM (\lkp -> (lkp,[]))
+
outRn :: Name -> RnM ()
outRn name = RnM (const ((),[name]))
-lookupRn :: (DocName -> a) -> Name -> RnM a
-lookupRn and_then name = do
+lookupRn :: Name -> RnM DocName
+lookupRn name = do
lkp <- getLookupRn
case lkp name of
- (False,maps_to) -> do outRn name; return (and_then maps_to)
- (True, maps_to) -> return (and_then maps_to)
+ (False,maps_to) -> do outRn name; return maps_to
+ (True, maps_to) -> return maps_to
runRnFM :: LinkEnv -> RnM a -> (a,[Name])
@@ -134,7 +133,7 @@ runRnFM env rn = unRn rn lkp
rename :: Name -> RnM DocName
-rename = lookupRn id
+rename = lookupRn
renameL :: Located Name -> RnM (Located DocName)
@@ -199,9 +198,10 @@ renameDoc d = case d of
DocCodeBlock doc -> do
doc' <- renameDoc doc
return (DocCodeBlock doc')
- DocURL str -> return (DocURL str)
+ DocHyperlink l -> return (DocHyperlink l)
DocPic str -> return (DocPic str)
DocAName str -> return (DocAName str)
+ DocProperty p -> return (DocProperty p)
DocExamples e -> return (DocExamples e)
@@ -270,8 +270,16 @@ renameType t = case t of
HsTyLit x -> return (HsTyLit x)
- _ -> error "renameType"
+ HsWrapTy a b -> HsWrapTy a <$> renameType b
+ HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
+ HsCoreTy a -> pure (HsCoreTy a)
+ HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
+ HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a
+ HsSpliceTy _ _ _ -> error "renameType: HsSpliceTy"
+renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)
+renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c
renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
@@ -402,22 +410,25 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
where
- renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
a' <- renameLType a
b' <- renameLType b
return (InfixCon a' b')
- renameField (ConDeclField name t doc) = do
- name' <- renameL name
- t' <- renameLType t
- doc' <- mapM renameLDocHsSyn doc
- return (ConDeclField name' t' doc')
-
renameResType (ResTyH98) = return ResTyH98
renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
+renameConDeclFieldField (ConDeclField name t doc) = do
+ name' <- renameL name
+ t' <- renameLType t
+ doc' <- mapM renameLDocHsSyn doc
+ return (ConDeclField name' t' doc')
+
+
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
TypeSig lnames ltype -> do
@@ -498,8 +509,8 @@ renameExportItem item = case item of
return (inst', idoc')
return (ExportDecl decl' doc' subs' instances')
ExportNoDecl x subs -> do
- x' <- lookupRn id x
- subs' <- mapM (lookupRn id) subs
+ x' <- lookupRn x
+ subs' <- mapM lookupRn subs
return (ExportNoDecl x' subs')
ExportDoc doc -> do
doc' <- renameDoc doc
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:44:26 +0000