aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Html.hs47
-rw-r--r--src/Haddock/Interface.hs2
-rw-r--r--src/Haddock/Interface/AttachInstances.hs43
-rw-r--r--src/Haddock/Interface/Create.hs34
-rw-r--r--src/Haddock/Interface/Rename.hs15
-rw-r--r--src/Haddock/Types.hs15
6 files changed, 110 insertions, 46 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index fead8470..93c2a491 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -809,7 +809,7 @@ declWithDoc False links loc nm (Just doc) html_decl =
-- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
- DocForDecl DocName -> [InstHead DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
+ DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of
TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode
TyClD d@(TyData {})
@@ -955,7 +955,7 @@ ppTyFam summary associated links loc mbDoc decl unicode
tda [theclass "body"] <<
collapsed thediv instId (
spacedTable1 << (
- aboves (map (declBox . ppInstHead unicode) instances)
+ aboves (map (ppDocInstance unicode) instances)
)
)
@@ -1150,7 +1150,7 @@ ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortC
-ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Maybe (HsDoc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> HtmlTable
ppClassDecl summary links instances loc mbDoc subdocs
@@ -1191,12 +1191,19 @@ ppClassDecl summary links instances loc mbDoc subdocs
= s8 </> instHdr instId </>
tda [theclass "body"] <<
collapsed thediv instId (
- spacedTable1 << (
- aboves (map (declBox . ppInstHead unicode) instances)
- ))
+ spacedTable1 << aboves (map (ppDocInstance unicode) instances)
+ )
ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+-- | Print a possibly commented instance. The instance header is printed inside
+-- an 'argBox'. The comment is printed to the right of the box in normal comment
+-- style.
+ppDocInstance :: Bool -> DocInstance DocName -> HtmlTable
+ppDocInstance unicode (_, instHead, maybeDoc) =
+ argBox (ppInstHead unicode instHead) <-> maybeRDocBox maybeDoc
+
+
ppInstHead :: Bool -> InstHead DocName -> Html
ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode
ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
@@ -1249,7 +1256,7 @@ ppShortDataDecl summary links loc dataDecl unicode
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
-ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable
ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
@@ -1303,8 +1310,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
= instHdr instId </>
tda [theclass "body"] <<
collapsed thediv instId (
- spacedTable1 << (
- aboves (map (declBox . ppInstHead unicode) instances)
+ spacedTable1 << aboves (map (ppDocInstance unicode) instances
)
)
@@ -1374,17 +1380,17 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
PrefixCon args ->
argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args))
- <-> maybeRDocBox mbLDoc
+ <-> maybeRDocBox mbDoc
RecCon fields ->
argBox (header_ unicode +++ ppBinder False occ) <->
- maybeRDocBox mbLDoc
+ maybeRDocBox mbDoc
</>
doRecordFields fields
InfixCon arg1 arg2 ->
argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2])
- <-> maybeRDocBox mbLDoc
+ <-> maybeRDocBox mbDoc
ResTyGADT resTy -> case con_details con of
-- prefix & infix could also use hsConDeclArgTys if it seemed to
@@ -1401,7 +1407,7 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
ppForAll forall ltvs (con_cxt con) unicode,
ppLType unicode (foldr mkFunTy resTy args) ]
- ) <-> maybeRDocBox mbLDoc
+ ) <-> maybeRDocBox mbDoc
header_ = ppConstrHdr forall tyVars context
@@ -1412,19 +1418,17 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
forall = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- -- The 'fmap' and 'join' are in Maybe
- mbLDoc = fmap noLoc $ join $ fmap fst $
- lookup (unLoc $ con_name con) subdocs
+ -- 'join' is in Maybe.
+ mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable
ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
argBox (ppBinder False (docNameOcc name)
- <+> dcolon unicode <+> ppLType unicode ltype) <->
- maybeRDocBox mbLDoc
+ <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbLDoc = fmap noLoc $ join $ fmap fst $ lookup name subdocs
+ mbDoc = join $ fmap fst $ lookup name subdocs
{-
ppHsFullConstr :: HsConDecl -> Html
@@ -1764,6 +1768,7 @@ htmlCleanup = idMarkup {
-- -----------------------------------------------------------------------------
-- * Misc
+
hsep :: [Html] -> Html
hsep [] = noHtml
hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
@@ -1890,9 +1895,9 @@ ndocBox html = tda [theclass "ndoc"] << html
rdocBox :: Html -> HtmlTable
rdocBox html = tda [theclass "rdoc"] << html
-maybeRDocBox :: Maybe (LHsDoc DocName) -> HtmlTable
+maybeRDocBox :: Maybe (HsDoc DocName) -> HtmlTable
maybeRDocBox Nothing = rdocBox (noHtml)
-maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc))
+maybeRDocBox (Just doc) = rdocBox (docToHtml doc)
-- a box for the buttons at the top of the page
topButBox :: Html -> HtmlTable
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 6cbd4c9a..cc53efdf 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -61,7 +61,7 @@ createInterfaces verbosity modules flags extIfaces = do
-- part 3, attach instances
out verbosity verbose "Attaching instances..."
- interfaces' <- attachInstances interfaces
+ interfaces' <- attachInstances interfaces instIfaceMap
-- part 4, rename interfaces
out verbosity verbose "Renaming interfaces..."
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index b996f278..a10cb36a 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -18,7 +18,9 @@ module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
+import Control.Arrow
import Data.List
+import qualified Data.Map as Map
import GHC
import Name
@@ -40,22 +42,38 @@ import FastString
#define FSLIT(x) (mkFastString# (x#))
-attachInstances :: [Interface] -> Ghc [Interface]
-attachInstances = mapM attach
+attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances ifaces instIfaceMap = mapM attach ifaces
where
attach iface = do
newItems <- mapM attachExport $ ifaceExportItems iface
return $ iface { ifaceExportItems = newItems }
-
- attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do
- mb_info <- getAllInfo (unLoc (tcdLName d))
- return $ export { expItemInstances = case mb_info of
- Just (_, _, instances) ->
- map synifyInstHead . sortImage instHead . map instanceHead $ instances
- Nothing ->
- []
- }
- attachExport export = return export
+ where
+ attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do
+ mb_info <- getAllInfo (unLoc (tcdLName d))
+ return $ export { expItemInstances = case mb_info of
+ Just (_, _, instances) ->
+ let insts = map (first synifyInstHead) $ sortImage (first instHead)
+ [ (instanceHead i, getName i) | i <- instances ]
+ in [ (name, inst, lookupInstDoc name iface instIfaceMap)
+ | (inst, name) <- insts ]
+ Nothing -> []
+ }
+ attachExport export = return export
+
+
+lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (HsDoc Name)
+-- TODO: capture this pattern in a function (when we have streamlined the
+-- handling of instances)
+lookupInstDoc name iface ifaceMap =
+ case Map.lookup name (ifaceInstanceDocMap iface) of
+ Just doc -> Just doc
+ Nothing -> do -- in Maybe
+ instIface <- Map.lookup modName ifaceMap
+ (Just doc, _) <- Map.lookup name (instDocMap instIface)
+ return doc
+ where
+ modName = nameModule name
-- | Like GHC's getInfo but doesn't cut things out depending on the
@@ -63,6 +81,7 @@ attachInstances = mapM attach
getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name
+
--------------------------------------------------------------------------------
-- Collecting and sorting instances
--------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f1023825..874037d7 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -56,13 +56,18 @@ createInterface ghcMod flags modMap instIfaceMap = do
(info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader
gre (ghcMbDocHdr ghcMod)
decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod))
- let decls = filterOutInstances decls0
+
+ let instances = ghcInstances ghcMod
+ localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
+ declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ]
+ instanceDocMap = mkInstanceDocMap localInsts declDocs
+
+ decls = filterOutInstances decls0
declMap = mkDeclMap decls
exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
localNames = ghcDefinedNames ghcMod
ignoreExps = Flag_IgnoreAllExports `elem` flags
exportedNames = ghcExportedNames ghcMod
- instances = ghcInstances ghcMod
liftErrMsg $ warnAboutFilteredDecls mdl decls0
@@ -93,7 +98,8 @@ createInterface ghcMod flags modMap instIfaceMap = do
ifaceVisibleExports = visibleNames,
ifaceDeclMap = declMap,
ifaceSubMap = mkSubMap declMap exportedNames,
- ifaceInstances = ghcInstances ghcMod
+ ifaceInstances = instances,
+ ifaceInstanceDocMap = instanceDocMap
}
@@ -128,6 +134,22 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
-- Declarations
--------------------------------------------------------------------------------
+
+mkInstanceDocMap :: [Instance] -> [(HsDecl name, doc)] -> Map Name doc
+mkInstanceDocMap instances decls =
+ -- We relate Instances to InstDecls using the SrcSpans buried inside them.
+ -- That should work for normal user-written instances (from looking at GHC
+ -- sources). We can assume that commented instances are user-written.
+ -- This lets us relate Names (from Instances) to comments (associated
+ -- with InstDecls).
+ let docMap = Map.fromList [ (loc, doc)
+ | (InstD (InstDecl (L loc _) _ _ _), doc) <- decls ]
+
+ in Map.fromList [ (name, doc) | inst <- instances
+ , let name = getName inst
+ , Just doc <- [ Map.lookup (getSrcSpan name) docMap ] ]
+
+
-- | Make a sub map from a declaration map. Make sure we only include exported
-- names.
mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name]
@@ -137,13 +159,13 @@ mkSubMap declMap exports =
filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ]
--- Make a map from names to 'DeclInfo's. Exclude declarations that don't
--- have names (instances and stand-alone documentation comments). Include
+-- Make a map from names to 'DeclInfo's. Exclude declarations that don't have
+-- names (e.g. instances and stand-alone documentation comments). Include
-- subordinate names, but map them to their parent declarations.
mkDeclMap :: [DeclInfo] -> Map Name DeclInfo
mkDeclMap decls = Map.fromList . concat $
[ (declName d, (parent, doc, subs)) : subDecls
- | (parent@(L _ d), doc, subs) <- decls
+ | (parent@(L _ d), doc, subs) <- decls
, let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
, not (isDocD d), not (isInstD d) ]
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 5eac9e67..308c86c5 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -37,8 +37,13 @@ renameInterface renamingEnv warnings iface =
let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
where fn env name = Map.insert name (ifaceMod iface) env
- docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)
- docs = Map.toList docMap
+ docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)
+
+ -- make instance docs into 'docForDecls'
+ instDocs = [ (name, (Just doc, Map.empty))
+ | (name, doc) <- Map.toList (ifaceInstanceDocMap iface) ]
+
+ docs = Map.toList docMap ++ instDocs
renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d')
-- rename names in the exported declarations to point to things that
@@ -448,7 +453,11 @@ renameExportItem item = case item of
decl' <- renameLDecl decl
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
- instances' <- mapM renameInstHead instances
+ instances' <- forM instances $ \(name, inst, idoc) -> do
+ name' <- rename name
+ inst' <- renameInstHead inst
+ idoc' <- mapM renameDoc idoc
+ return (name', inst', idoc')
return (ExportDecl decl' doc' subs' instances')
ExportNoDecl x subs -> do
x' <- lookupRn id x
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 4c8c3656..d7d5e7bd 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -40,6 +40,8 @@ import Name
type Decl = LHsDecl Name
type Doc = HsDoc Name
+type DocInstance name = (name, InstHead name, Maybe (HsDoc name))
+
#if __GLASGOW_HASKELL__ <= 610
type HsDocString = HsDoc Name
type LHsDocString = Located HsDocString
@@ -98,8 +100,8 @@ data ExportItem name
-- | Subordinate names, possibly with documentation
expItemSubDocs :: [(name, DocForDecl name)],
- -- | Instances relevant to this declaration
- expItemInstances :: [InstHead name]
+ -- | Instances relevant to this declaration, possibly with documentation
+ expItemInstances :: [DocInstance name]
} -- ^ An exported declaration
@@ -131,7 +133,11 @@ data ExportItem name
| ExportModule Module -- ^ A cross-reference to another module
+-- | The head of an instance. Consists of a context, a class name and a list of
+-- instance types.
type InstHead name = ([HsPred name], name, [HsType name])
+
+
type ModuleMap = Map Module Interface
type InstIfaceMap = Map Module InstalledInterface
type DocMap = Map Name (HsDoc DocName)
@@ -215,7 +221,10 @@ data Interface = Interface {
ifaceVisibleExports :: ![Name],
-- | The instances exported by this module
- ifaceInstances :: ![Instance]
+ ifaceInstances :: ![Instance],
+
+ -- | Docs for instances defined in this module
+ ifaceInstanceDocMap :: Map Name (HsDoc Name)
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 13:50:38 +0000