aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs23
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs40
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs14
-rw-r--r--haddock-api/src/Haddock/Convert.hs2
-rw-r--r--haddock-api/src/Haddock/Interface.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs13
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs27
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs2
-rw-r--r--haddock-api/src/Haddock/Types.hs4
12 files changed, 98 insertions, 38 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 97709d78..9a15c7b3 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -29,6 +29,8 @@ import Data.Char
import Data.List
import Data.Maybe
import Data.Version
+
+import System.Directory
import System.FilePath
import System.IO
@@ -47,6 +49,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
["@version " ++ showVersion version
| not (null (versionBranch version)) ] ++
concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ createDirectoryIfMissing True odir
h <- openFile (odir </> filename) WriteMode
hSetEncoding h utf8
hPutStr h (unlines contents)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index e30c768a..b7be7ffb 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -740,7 +740,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) =
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
- decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
+ decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
@@ -981,8 +981,6 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
-ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name
-
ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index cf53c27e..ebd53370 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -526,10 +526,10 @@ 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)
+ divInterface (maybe_doc_hdr +++ bdy +++ orphans)
where
exports = numberSectionHeadings (ifaceRnExportItems iface)
@@ -568,6 +568,9 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
foldr (+++) noHtml $
mapMaybe (processExport False linksInfo unicode qual) exports
+ orphans =
+ ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual
+
linksInfo = (maybe_source_url, maybe_wiki_url)
@@ -608,16 +611,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 _ [] = ([], [])
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 49149b8c..a7a0a2d6 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
@@ -561,14 +561,32 @@ 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
+ -> [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) 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
@@ -576,7 +594,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 ->
@@ -618,8 +636,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
@@ -826,7 +845,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocName -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
- (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
+ (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
mbDoc,
[])
where
@@ -837,7 +856,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
ppShortField summary unicode qual (ConDeclField names ltype _)
- = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
+ = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual ltype
@@ -997,9 +1016,6 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
= ppr_mono_lty ctxt_prec ty unicode qual
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'
-
-ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name
-
ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d24ed9c4..98df09fe 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,17 @@ 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 wrap . instTable
+ where
+ wrap = ((h1 << "Orphan instances") +++)
+ 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/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index bc293731..38271a04 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -283,7 +283,7 @@ synifyDataCon use_gadt_syntax dc =
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy = noLoc $
- ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
+ ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
Nothing
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index afb5111e..62b0aea9 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 faf043aa..20971071 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -60,7 +60,18 @@ 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
+ }
+
+attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]
+attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
+ [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))
+ | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
+ , not $ isInstanceHidden expInfo cls tys
+ ]
attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c41946f5..6466acfb 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -150,6 +150,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 2478ce23..0f97ee3b 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -47,13 +47,17 @@ 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 +76,8 @@ renameInterface dflags renamingEnv warnings iface =
return $ iface { ifaceRnDoc = finalModuleDoc,
ifaceRnDocMap = rnDocMap,
ifaceRnArgMap = rnArgMap,
- ifaceRnExportItems = renamedExportItems }
+ ifaceRnExportItems = renamedExportItems,
+ ifaceRnOrphanInstances = renamedOrphanInstances}
--------------------------------------------------------------------------------
@@ -284,7 +289,6 @@ renameLContext (L loc context) = do
renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name
-renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
renameInstHead InstHead {..} = do
@@ -561,6 +565,13 @@ renameWc rn_thing (HsWC { hswc_body = thing })
; return (HsWC { hswc_body = thing'
, hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
+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)
@@ -571,11 +582,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/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 12fa5a93..5d15fb33 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -81,7 +81,7 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 713)
+#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 801)
binaryInterfaceVersion = 27
binaryInterfaceVersionCompatibility :: [Word16]
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index bf178c24..3a4df70c 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -126,6 +126,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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 09:46:23 +0000