From 02e633a6f9b7ccb53a92a838c1b717ef9f3737fc Mon Sep 17 00:00:00 2001 From: Oleg Grenrus 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/src/Haddock') 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 From dee8ef2b918917a1469f35b24d7bd9f7caa59d62 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 28 Sep 2015 07:21:11 +0300 Subject: Have source links for orphan instances --- haddock-api/src/Haddock/Interface.hs | 2 +- haddock-api/src/Haddock/Interface/AttachInstances.hs | 20 ++++++++------------ 2 files changed, 9 insertions(+), 13 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 1bb04ed3..8b04d76b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -228,7 +228,7 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) foldl' keep_old old_env exported_names | otherwise = foldl' keep_new old_env exported_names where - exported_names = ifaceVisibleExports iface + exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index c3e1275e..5adee457 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -66,23 +66,13 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces , 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)) + [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) 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 @@ -128,7 +118,13 @@ 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 = -- cgit v1.2.3 From 7f97a59a8bf6fdfd57e9e0f8494de894ea4ee018 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 28 Sep 2015 07:24:58 +0300 Subject: Print orphan instances header only if required --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index fce95814..de4e8a1d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -564,7 +564,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual foldr (+++) noHtml $ mapMaybe (processExport False linksInfo unicode qual) exports - orphans = (h1 << "Orphan instances") +++ + orphans = ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual linksInfo = (maybe_source_url, maybe_wiki_url) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index b20cd172..3c132497 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -204,8 +204,9 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable subOrphanInstances :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html -subOrphanInstances qual lnks splice = maybe noHtml id . instTable +subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable where + wrap = ((h1 << "Orphan instances") +++) instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice id_ = makeAnchorId $ "orphans" -- cgit v1.2.3 From c609348cca068a3c081243b1fe0286f8abb12042 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 28 Sep 2015 07:40:54 +0300 Subject: Add orphan instances link to contents box --- haddock-api/src/Haddock/Backends/Xhtml.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index de4e8a1d..819974a2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -522,7 +522,7 @@ ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual - = ppModuleContents qual exports +++ + = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++ divInterface (maybe_doc_hdr +++ bdy +++ orphans) @@ -607,16 +607,22 @@ ppTyClBinderWithVarsMini mdl decl = ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName -ppModuleContents :: Qualification -> [ExportItem DocName] -> Html -ppModuleContents qual exports - | null sections = noHtml - | otherwise = contentsDiv +ppModuleContents :: Qualification + -> [ExportItem DocName] + -> Bool -- ^ Orphans sections + -> Html +ppModuleContents qual exports orphan + | null sections && not orphan = noHtml + | otherwise = contentsDiv where contentsDiv = divTableOfContents << ( sectionName << "Contents" +++ - unordList sections) + unordList (sections ++ orphanSection)) (sections, _leftovers{-should be []-}) = process 0 exports + orphanSection + | orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ] + | otherwise = [] process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) process _ [] = ([], []) -- cgit v1.2.3 From 52bc03a00cf57764cdab5124ee2b12acd5ad3780 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 28 Sep 2015 16:37:44 +0300 Subject: Fix orphan instance collapsing --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 031b40e5..6fed2e1d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -545,7 +545,7 @@ ppInstances links origin instances splice unicode qual instName = getOccString origin instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc origin no inst), loc) + ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) ppOrphanInstances :: LinksInfo @@ -560,14 +560,17 @@ ppOrphanInstances links instances splice unicode qual instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc (instOrigin inst) no inst), loc) + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification -> Maybe (MDoc DocName) - -> InstOrigin DocName -> Int -> InstHead DocName + -> InstOrigin DocName + -> Bool -- ^ Is instance orphan + -> Int -- ^ Normal + -> InstHead DocName -> SubDecl -ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = +ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ @@ -575,7 +578,7 @@ ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = , [subInstDetails iid ats sigs] ) where - iid = instanceId origin no ihd + iid = instanceId origin no orphan ihd sigs = ppInstanceSigs links splice unicode qual clsiSigs ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> @@ -614,8 +617,9 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String -instanceId origin no ihd = concat +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String +instanceId origin no orphan ihd = concat $ + [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin , ":" ++ (occNameString . getOccName . ihdClsName) ihd -- cgit v1.2.3