From 02e633a6f9b7ccb53a92a838c1b717ef9f3737fc Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Sun, 27 Sep 2015 20:50:15 +0300
Subject: Generate docs for orphan instances
---
haddock-api/src/Haddock/Backends/Xhtml.hs | 5 +++-
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 17 +++++++++++-
haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 13 +++++++--
.../src/Haddock/Interface/AttachInstances.hs | 31 ++++++++++++++++------
haddock-api/src/Haddock/Interface/Create.hs | 2 ++
haddock-api/src/Haddock/Interface/Rename.hs | 25 ++++++++++-------
haddock-api/src/Haddock/Types.hs | 4 +++
7 files changed, 76 insertions(+), 21 deletions(-)
(limited to 'haddock-api')
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index e5e4db3f..fce95814 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -525,7 +525,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
= ppModuleContents qual exports +++
description +++
synopsis +++
- divInterface (maybe_doc_hdr +++ bdy)
+ divInterface (maybe_doc_hdr +++ bdy +++ orphans)
where
exports = numberSectionHeadings (ifaceRnExportItems iface)
@@ -564,6 +564,9 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
foldr (+++) noHtml $
mapMaybe (processExport False linksInfo unicode qual) exports
+ orphans = (h1 << "Orphan instances") +++
+ ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual
+
linksInfo = (maybe_source_url, maybe_wiki_url)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e536ae4b..031b40e5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -16,7 +16,7 @@
module Haddock.Backends.Xhtml.Decl (
ppDecl,
- ppTyName, ppTyFamHeader, ppTypeApp,
+ ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances,
tyvarNames
) where
@@ -548,6 +548,21 @@ ppInstances links origin instances splice unicode qual
((ppInstHead links splice unicode qual mdoc origin no inst), loc)
+ppOrphanInstances :: LinksInfo
+ -> [DocInstance DocName]
+ -> Splice -> Unicode -> Qualification
+ -> Html
+ppOrphanInstances links instances splice unicode qual
+ = subOrphanInstances qual links True (zipWith instDecl [1..] instances)
+ where
+ instOrigin :: InstHead name -> InstOrigin name
+ instOrigin inst = OriginClass (ihdClsName inst)
+
+ instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+ instDecl no (inst, mdoc, loc) =
+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) no inst), loc)
+
+
ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-> Maybe (MDoc DocName)
-> InstOrigin DocName -> Int -> InstHead DocName
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d624a1d0..b20cd172 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
subConstructors,
subEquations,
subFields,
- subInstances, subInstHead, subInstDetails,
+ subInstances, subOrphanInstances, subInstHead, subInstDetails,
subMethods,
subMinimal,
@@ -200,7 +200,16 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable
subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
id_ = makeAnchorId $ "i:" ++ nm
-
+
+subOrphanInstances :: Qualification
+ -> LinksInfo -> Bool
+ -> [(SubDecl,Located DocName)] -> Html
+subOrphanInstances qual lnks splice = maybe noHtml id . instTable
+ where
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice
+ id_ = makeAnchorId $ "orphans"
+
+
subInstHead :: String -- ^ Instance unique id (for anchor generation)
-> Html -- ^ Header content (instance name and type)
-> Html
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index e2fd24ee..c3e1275e 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -61,7 +61,28 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
attach iface = do
newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
(ifaceExportItems iface)
- return $ iface { ifaceExportItems = newItems }
+ let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
+ return $ iface { ifaceExportItems = newItems
+ , ifaceOrphanInstances = orphanInstances
+ }
+
+spanName :: NamedThing a => a -> InstHead e -> GenLocated SrcSpan e -> GenLocated SrcSpan e
+spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
+ let s1 = getSrcSpan s
+ sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
+ then instn
+ else clsn
+ in L (getSrcSpan s) sn
+
+attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]
+attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
+ [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L noSrcSpan n))
+ | let is = [ (instanceHead' i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
+ , not $ isInstanceHidden expInfo cls tys
+ ]
+ where
+ -- spanName: attach the location to the name that is the same file as the instance location
attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
@@ -107,13 +128,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
] }
attachFixities e = e
- -- spanName: attach the location to the name that is the same file as the instance location
- spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
- let s1 = getSrcSpan s
- sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
- then instn
- else clsn
- in L (getSrcSpan s) sn
+
-- spanName on Either
spanNameE s (Left e) _ = L (getSrcSpan s) (Left e)
spanNameE s (Right ok) linst =
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 0599151e..e158fb21 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -148,6 +148,8 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceModuleAliases = aliases
, ifaceInstances = instances
, ifaceFamInstances = fam_instances
+ , ifaceOrphanInstances = [] -- Filled in `attachInstances`
+ , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
, ifaceTokenizedSrc = tokenizedSrc
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 146a7c0b..dde8128d 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -47,13 +47,16 @@ renameInterface dflags renamingEnv warnings iface =
(rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
- (finalModuleDoc, missingNames4)
+ (renamedOrphanInstances, missingNames4)
+ = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface))
+
+ (finalModuleDoc, missingNames5)
= runRnFM localEnv (renameDocumentation (ifaceDoc iface))
-- combine the missing names and filter out the built-ins, which would
- -- otherwise allways be missing.
+ -- otherwise always be missing.
missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
- (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)
+ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5)
-- filter out certain built in type constructors using their string
-- representation. TODO: use the Name constants from the GHC API.
@@ -72,7 +75,8 @@ renameInterface dflags renamingEnv warnings iface =
return $ iface { ifaceRnDoc = finalModuleDoc,
ifaceRnDocMap = rnDocMap,
ifaceRnArgMap = rnArgMap,
- ifaceRnExportItems = renamedExportItems }
+ ifaceRnExportItems = renamedExportItems,
+ ifaceRnOrphanInstances = renamedOrphanInstances}
--------------------------------------------------------------------------------
@@ -504,6 +508,13 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs,
= HsWB pats' PlaceHolder PlaceHolder PlaceHolder
, dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)
+renameDocInstance (inst, idoc, L l n) = do
+ inst' <- renameInstHead inst
+ n' <- rename n
+ idoc' <- mapM renameDoc idoc
+ return (inst', idoc',L l n')
+
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
renameExportItem item = case item of
ExportModule mdl -> return (ExportModule mdl)
@@ -514,11 +525,7 @@ renameExportItem item = case item of
decl' <- renameLDecl decl
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
- instances' <- forM instances $ \(inst, idoc, L l n) -> do
- inst' <- renameInstHead inst
- n' <- rename n
- idoc' <- mapM renameDoc idoc
- return (inst', idoc',L l n')
+ instances' <- forM instances renameDocInstance
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 106d3544..c6631671 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -124,6 +124,10 @@ data Interface = Interface
, ifaceInstances :: ![ClsInst]
, ifaceFamInstances :: ![FamInst]
+ -- | Orphan instances
+ , ifaceOrphanInstances :: ![DocInstance Name]
+ , ifaceRnOrphanInstances :: ![DocInstance DocName]
+
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
, ifaceHaddockCoverage :: !(Int, Int)
--
cgit v1.2.3