diff --git a/haddock.cabal b/haddock.cabal
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -1,5 +1,5 @@
name: haddock
-version: 2.8.1
+version: 2.9.0
cabal-version: >= 1.6
license: BSD3
build-type: Simple
@@ -82,11 +82,10 @@
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.5,
- ghc >= 6.12 && < 6.16
+ ghc >= 7.0 && < 7.2
if flag(in-ghc-tree)
cpp-options: -DIN_GHC_TREE
- extensions: ForeignFunctionInterface
else
build-depends: ghc-paths
@@ -96,7 +95,7 @@
main-is: Main.hs
hs-source-dirs: src
- extensions: CPP, PatternGuards, DeriveDataTypeable,
+ extensions: CPP, DeriveDataTypeable,
ScopedTypeVariables, MagicHash
ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs
@@ -142,11 +141,10 @@
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.5,
- ghc >= 6.12 && < 6.14
+ ghc >= 7.0 && < 7.2
if flag(in-ghc-tree)
cpp-options: -DIN_GHC_TREE
- extensions: ForeignFunctionInterface
else
build-depends: ghc-paths
@@ -155,7 +153,7 @@
build-depends: QuickCheck >= 2.1 && < 3
hs-source-dirs: src
- extensions: CPP, PatternGuards, DeriveDataTypeable,
+ extensions: CPP, DeriveDataTypeable,
ScopedTypeVariables, MagicHash
ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs
diff --git a/haddock.spec b/haddock.spec
--- a/haddock.spec
+++ b/haddock.spec
@@ -17,7 +17,7 @@
# version label of your release tarball.
%define name haddock
-%define version 2.8.1
+%define version 2.9.0
%define release 1
Name: %{name}
diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -26,10 +26,9 @@
DocForDecl,
FnArgsDoc,
- -- * Hyperlinking
+ -- * Cross-referencing
LinkEnv,
DocName(..),
- docNameOcc,
-- * Instances
DocInstance,
@@ -43,7 +42,6 @@
markup,
-- * Interface files
- -- | (.haddock files)
InterfaceFile(..),
readInterfaceFile,
nameCacheFromGhc,
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -240,13 +240,12 @@
markupCodeBlock = box TagPre,
markupURL = box (TagInline "a") . str,
markupAName = const $ str "",
- markupExample = box TagPre . str . unlines . (map exampleToString)
+ markupExample = box TagPre . str . unlines . map exampleToString
}
showTags :: [Tag] -> [String]
-showTags = concat . intersperse [""] . map showBlock
- where
+showTags = intercalate [""] . map showBlock
showBlock :: Tag -> [String]
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -577,11 +577,7 @@
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-#if __GLASGOW_HASKELL__ == 612
-ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> LaTeX
-#else
ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX
-#endif
ppConstrHdr forall tvs ctxt unicode
= (if null tvs then empty else ppForall)
<+>
@@ -635,7 +631,7 @@
header_ = ppConstrHdr forall tyVars context
- occ = docNameOcc . unLoc . con_name $ con
+ occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
@@ -649,7 +645,7 @@
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
- decltt (ppBinder (docNameOcc name)
+ decltt (ppBinder (nameOccName . getName $ name)
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
@@ -740,7 +736,7 @@
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
ppAppDocNameNames _summ n ns =
- ppTypeApp n ns (ppBinder . docNameOcc) ppSymName
+ ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName
-- | General printing of type applications
@@ -850,11 +846,7 @@
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-#if __GLASGOW_HASKELL__ == 612
-ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]
-#else
ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
-#endif
-> Located (HsContext DocName) -> Bool -> LaTeX
ppForAll expl tvs cxt unicode
| show_forall = forall_part <+> ppLContext cxt unicode
@@ -884,12 +876,9 @@
ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)
ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
-#if __GLASGOW_HASKELL__ == 612
-ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#else
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#endif
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
= maybeParen ctxt_prec pREC_CON $
@@ -900,7 +889,7 @@
ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
where
ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
- occName = docNameOcc . unLoc $ op
+ occName = nameOccName . getName . unLoc $ op
ppr_mono_ty ctxt_prec (HsParTy ty) unicode
-- = parens (ppr_mono_lty pREC_TOP ty)
@@ -945,7 +934,7 @@
ppVerbDocName :: DocName -> LaTeX
-ppVerbDocName = ppVerbOccName . docNameOcc
+ppVerbDocName = ppVerbOccName . nameOccName . getName
ppVerbRdrName :: RdrName -> LaTeX
@@ -953,7 +942,7 @@
ppDocName :: DocName -> LaTeX
-ppDocName = ppOccName . docNameOcc
+ppDocName = ppOccName . nameOccName . getName
ppLDocName :: Located DocName -> LaTeX
@@ -961,7 +950,7 @@
ppDocBinder :: DocName -> LaTeX
-ppDocBinder = ppBinder . docNameOcc
+ppDocBinder = ppBinder . nameOccName . getName
ppName :: Name -> LaTeX
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -35,13 +35,12 @@
import Control.Monad ( when, unless )
import Control.Monad.Instances ( ) -- for Functor Either a
import Data.Char ( toUpper )
-import Data.List ( sortBy, groupBy )
+import Data.List ( sortBy, groupBy, intercalate )
import Data.Maybe
import System.FilePath hiding ( () )
import System.Directory
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
-import Data.List ( intercalate )
import Data.Function
import Data.Ord ( comparing )
@@ -56,49 +55,52 @@
ppHtml :: String
- -> Maybe String -- package
+ -> Maybe String -- ^ Package
-> [Interface]
- -> FilePath -- destination directory
- -> Maybe (Doc GHC.RdrName) -- prologue text, maybe
- -> Themes -- themes
- -> SourceURLs -- the source URL (--source)
- -> WikiURLs -- the wiki URL (--wiki)
- -> Maybe String -- the contents URL (--use-contents)
- -> Maybe String -- the index URL (--use-index)
- -> Bool -- whether to use unicode in output (--use-unicode)
+ -> FilePath -- ^ Destination directory
+ -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe
+ -> Themes -- ^ Themes
+ -> SourceURLs -- ^ The source URL (--source)
+ -> WikiURLs -- ^ The wiki URL (--wiki)
+ -> Maybe String -- ^ The contents URL (--use-contents)
+ -> Maybe String -- ^ The index URL (--use-index)
+ -> Bool -- ^ Whether to use unicode in output (--use-unicode)
+ -> Qualification -- ^ How to qualify names
+ -> Bool -- ^ Output pretty html (newlines and indenting)
-> IO ()
ppHtml doctitle maybe_package ifaces odir prologue
themes maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode = do
+ maybe_contents_url maybe_index_url unicode
+ qual debug = do
let
- visible_ifaces = filter visible ifaces
- visible i = OptHide `notElem` ifaceOptions i
- when (not (isJust maybe_contents_url)) $
+ visible_ifaces = filter visible ifaces
+ visible i = OptHide `notElem` ifaceOptions i
+
+ when (isNothing maybe_contents_url) $
ppHtmlContents odir doctitle maybe_package
themes maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces)
False -- we don't want to display the packages in a single-package contents
prologue
+ debug
- when (not (isJust maybe_index_url)) $
+ when (isNothing maybe_index_url) $
ppHtmlIndex odir doctitle maybe_package
themes maybe_contents_url maybe_source_url maybe_wiki_url
- (map toInstalledIface visible_ifaces)
+ (map toInstalledIface visible_ifaces) debug
mapM_ (ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode) visible_ifaces
+ maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
copyHtmlBits odir libdir themes = do
let
- libhtmldir = joinPath [libdir, "html"]
- copyCssFile f = do
- copyFile f (combine odir (takeFileName f))
- copyLibFile f = do
- copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
+ libhtmldir = joinPath [libdir, "html"]
+ copyCssFile f = copyFile f (combine odir (takeFileName f))
+ copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
mapM_ copyCssFile (cssFiles themes)
mapM_ copyLibFile [ jsFile, framesFile ]
@@ -148,13 +150,13 @@
contentsButton :: Maybe String -> Maybe Html
contentsButton maybe_contents_url
= Just (anchor ! [href url] << "Contents")
- where url = maybe contentsHtmlFile id maybe_contents_url
+ where url = fromMaybe contentsHtmlFile maybe_contents_url
indexButton :: Maybe String -> Maybe Html
indexButton maybe_index_url
= Just (anchor ! [href url] << "Index")
- where url = maybe indexHtmlFile id maybe_index_url
+ where url = fromMaybe indexHtmlFile maybe_index_url
bodyHtml :: String -> Maybe Interface
@@ -189,7 +191,7 @@
let
info = ifaceInfo iface
- doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
+ doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
doOneEntry (fieldName, field) =
field info >>= \a -> return (th << fieldName <-> td << a)
@@ -219,10 +221,11 @@
-> SourceURLs
-> WikiURLs
-> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
+ -> Bool
-> IO ()
ppHtmlContents odir doctitle _maybe_package
themes maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do
+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug = do
let tree = mkModuleTree showPkgs
[(instMod iface, toInstalledDescription iface) | iface <- ifaces]
html =
@@ -234,10 +237,10 @@
ppModuleTree tree
]
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html)
+ writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
-- XXX: think of a better place for this?
- ppHtmlContentsFrame odir doctitle themes ifaces
+ ppHtmlContentsFrame odir doctitle themes ifaces debug
ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
@@ -306,13 +309,13 @@
where
mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
ppModule' txt mdl =
- anchor ! [href ((moduleHtmlFile mdl)), target mainFrameName]
+ anchor ! [href (moduleHtmlFile mdl), target mainFrameName]
<< toHtml txt
ppHtmlContentsFrame :: FilePath -> String -> Themes
- -> [InstalledInterface] -> IO ()
-ppHtmlContentsFrame odir doctitle themes ifaces = do
+ -> [InstalledInterface] -> Bool -> IO ()
+ppHtmlContentsFrame odir doctitle themes ifaces debug = do
let mods = flatModuleTree ifaces
html =
headHtml doctitle Nothing themes +++
@@ -320,7 +323,7 @@
(sectionName << "Modules" +++
ulist << [ li ! [theclass "module"] << m | m <- mods ])
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)
+ writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)
--------------------------------------------------------------------------------
@@ -336,18 +339,22 @@
-> SourceURLs
-> WikiURLs
-> [InstalledInterface]
+ -> Bool
-> IO ()
ppHtmlIndex odir doctitle _maybe_package themes
- maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
+ maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
let html = indexPage split_indices Nothing
(if split_indices then [] else index)
createDirectoryIfMissing True odir
- when split_indices $
+ when split_indices $ do
mapM_ (do_sub_index index) initialChars
+ -- Let's add a single large index as well for those who don't know exactly what they're looking for:
+ let mergedhtml = indexPage False Nothing index
+ writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
- writeFile (joinPath [odir, indexHtmlFile]) (renderToString html)
+ writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)
where
indexPage showLetters ch items =
@@ -361,6 +368,7 @@
]
indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
+ merged_name = "All"
buildIndex items = table << aboves (map indexElt items)
@@ -373,9 +381,10 @@
indexInitialLetterLinks =
divAlphabet <<
- unordList [ anchor ! [href (subIndexHtmlFile c)] << [c]
- | c <- initialChars
- , any ((==c) . toUpper . head . fst) index ]
+ unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
+ [ [c] | c <- initialChars
+ , any ((==c) . toUpper . head . fst) index ] ++
+ [merged_name])
-- todo: what about names/operators that start with Unicode
-- characters?
@@ -386,7 +395,7 @@
do_sub_index this_ix c
= unless (null index_part) $
- writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString html)
+ writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
@@ -394,7 +403,7 @@
index :: [(String, Map GHC.Name [(Module,Bool)])]
index = sortBy cmp (Map.toAscList full_index)
- where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2
+ where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2
-- for each name (a plain string), we have a number of original HsNames that
-- it can refer to, and for each of those we have a list of modules
@@ -402,7 +411,7 @@
-- in a visible or invisible way (hence the Bool).
full_index :: Map String (Map GHC.Name [(Module,Bool)])
full_index = Map.fromListWith (flip (Map.unionWith (++)))
- (concat (map getIfaceIndex ifaces))
+ (concatMap getIfaceIndex ifaces)
getIfaceIndex iface =
[ (getOccString name
@@ -448,44 +457,48 @@
ppHtmlModule
:: FilePath -> String -> Themes
-> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool
- -> Interface -> IO ()
+ -> Maybe String -> Maybe String -> Bool -> Qualification
+ -> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode iface = do
+ maybe_contents_url maybe_index_url unicode qual debug iface = do
let
mdl = ifaceMod iface
mdl_str = moduleString mdl
+ real_qual = case qual of
+ LocalQual Nothing -> LocalQual (Just mdl)
+ RelativeQual Nothing -> RelativeQual (Just mdl)
+ _ -> qual
html =
headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
- ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
]
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html)
- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode
+ writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
- -> Interface -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do
+ -> Interface -> Bool -> Qualification -> Bool -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
let mdl = ifaceMod iface
html =
headHtml (moduleString mdl) Nothing themes +++
miniBody <<
(divModuleHeader << sectionName << moduleString mdl +++
- miniSynopsis mdl iface unicode)
+ miniSynopsis mdl iface unicode qual)
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)
+ writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
-ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html
-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
- = ppModuleContents exports +++
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
+ = ppModuleContents qual exports +++
description +++
synopsis +++
divInterface (maybe_doc_hdr +++ bdy)
@@ -505,7 +518,7 @@
= case ifaceRnDoc iface of
Nothing -> noHtml
Just doc -> divDescription $
- sectionName << "Description" +++ docSection doc
+ sectionName << "Description" +++ docSection qual doc
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -514,7 +527,7 @@
= divSynposis $
paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
shortDeclList (
- mapMaybe (processExport True linksInfo unicode) exports
+ mapMaybe (processExport True linksInfo unicode qual) exports
) ! (collapseSection "syn" False "" ++ collapseToggle "syn")
-- if the documentation doesn't begin with a section header, then
@@ -527,20 +540,21 @@
bdy =
foldr (+++) noHtml $
- mapMaybe (processExport False linksInfo unicode) exports
+ mapMaybe (processExport False linksInfo unicode qual) exports
linksInfo = (maybe_source_url, maybe_wiki_url)
-miniSynopsis :: Module -> Interface -> Bool -> Html
-miniSynopsis mdl iface unicode =
- divInterface << mapMaybe (processForMiniSynopsis mdl unicode) exports
+miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
+miniSynopsis mdl iface unicode qual =
+ divInterface << mapMaybe (processForMiniSynopsis mdl unicode qual) exports
where
exports = numberSectionHeadings (ifaceRnExportItems iface)
-processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Maybe Html
-processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =
+processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
+ -> Maybe Html
+processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) =
((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
(TyFamily{}) -> Just $ ppTyFamHeader True False d unicode
@@ -553,11 +567,11 @@
(ClassDecl {}) -> Just $ keyword "class" <+> b
_ -> Nothing
SigD (TypeSig (L _ n) (L _ _)) ->
- Just $ ppNameMini mdl (docNameOcc n)
+ Just $ ppNameMini mdl (nameOccName . getName $ n)
_ -> Nothing
-processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =
- Just $ groupTag lvl << docToHtml txt
-processForMiniSynopsis _ _ _ = Nothing
+processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
+ Just $ groupTag lvl << docToHtml qual txt
+processForMiniSynopsis _ _ _ _ = Nothing
ppNameMini :: Module -> OccName -> Html
@@ -571,11 +585,11 @@
ppTyClBinderWithVarsMini mdl decl =
let n = unLoc $ tcdLName decl
ns = tyvarNames $ tcdTyVars decl
- in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName
+ in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
-ppModuleContents :: [ExportItem DocName] -> Html
-ppModuleContents exports
+ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
+ppModuleContents qual exports
| null sections = noHtml
| otherwise = contentsDiv
where
@@ -591,7 +605,7 @@
| lev <= n = ( [], items )
| otherwise = ( html:secs, rest2 )
where
- html = linkedAnchor id0 << docToHtml doc +++ mk_subsections ssecs
+ html = linkedAnchor (groupId id0) << docToHtml qual doc +++ mk_subsections ssecs
(ssecs, rest1) = process lev rest
(secs, rest2) = process n rest1
process n (_ : rest) = process n rest
@@ -612,18 +626,20 @@
= other : go n es
-processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> Maybe Html
-processExport summary _ _ (ExportGroup lev id0 doc)
- = nothingIf summary $ groupTag lev ! [identifier id0] << docToHtml doc
-processExport summary links unicode (ExportDecl decl doc subdocs insts)
- = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode
-processExport summary _ _ (ExportNoDecl y [])
- = processDeclOneLiner summary $ ppDocName y
-processExport summary _ _ (ExportNoDecl y subs)
- = processDeclOneLiner summary $ ppDocName y +++ parenList (map ppDocName subs)
-processExport summary _ _ (ExportDoc doc)
- = nothingIf summary $ docSection doc
-processExport summary _ _ (ExportModule mdl)
+processExport :: Bool -> LinksInfo -> Bool -> Qualification
+ -> ExportItem DocName -> Maybe Html
+processExport summary _ _ qual (ExportGroup lev id0 doc)
+ = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
+processExport summary links unicode qual (ExportDecl decl doc subdocs insts)
+ = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual
+processExport summary _ _ qual (ExportNoDecl y [])
+ = processDeclOneLiner summary $ ppDocName qual y
+processExport summary _ _ qual (ExportNoDecl y subs)
+ = processDeclOneLiner summary $
+ ppDocName qual y +++ parenList (map (ppDocName qual) subs)
+processExport summary _ _ qual (ExportDoc doc)
+ = nothingIf summary $ docSection qual doc
+processExport summary _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
@@ -641,6 +657,8 @@
processDeclOneLiner True = Just
processDeclOneLiner False = Just . divTopDecl . declElem
+groupHeading :: Int -> String -> Html -> Html
+groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]
groupTag :: Int -> Html -> Html
groupTag lev
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,38 +39,40 @@
-- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
- DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html
-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
+ DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
+ Bool -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
+ TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual
TyClD d@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode
+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
| Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
TyClD d@(TySynonym {})
- | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode
- | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode
- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode
+ | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+ | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode qual
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- DocName -> HsType DocName -> Bool -> Html
-ppFunSig summary links loc doc docname typ unicode =
+ DocName -> HsType DocName -> Bool -> Qualification -> Html
+ppFunSig summary links loc doc docname typ unicode qual =
ppTypeOrFunSig summary links loc docname typ doc
- (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode
+ (ppTypeSig summary occname typ unicode qual, ppBinder False occname, dcolon unicode)
+ unicode qual
where
- occname = docNameOcc docname
+ occname = nameOccName . getName $ docname
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->
- DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html
-ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode
+ DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification-> Html
+ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode qual
| summary = pref1
- | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection doc
+ | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection qual doc
| otherwise = topDeclElem links loc docname pref2 +++
- subArguments (do_args 0 sep typ) +++ maybeDocSection doc
+ subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc
where
argDoc n = Map.lookup n argDocs
@@ -79,12 +81,12 @@
do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
= (leader <+>
hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
- ppLContextNoArrow lctxt unicode,
+ ppLContextNoArrow lctxt unicode qual,
Nothing, [])
: do_largs n (darrow unicode) ltype
do_args n leader (HsForAllTy Implicit _ lctxt ltype)
| not (null (unLoc lctxt))
- = (leader <+> ppLContextNoArrow lctxt unicode,
+ = (leader <+> ppLContextNoArrow lctxt unicode qual,
Nothing, [])
: do_largs n (darrow unicode) ltype
-- if we're not showing any 'forall' or class constraints or
@@ -92,10 +94,10 @@
| otherwise
= do_largs n leader ltype
do_args n leader (HsFunTy lt r)
- = (leader <+> ppLFunLhType unicode lt, argDoc n, [])
+ = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
- = (leader <+> ppType unicode t, argDoc n, []) : []
+ = (leader <+> ppType unicode qual t, argDoc n, []) : []
ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
@@ -106,26 +108,29 @@
tyvarNames = map (getName . hsTyVarName . unLoc)
-ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode
- = ppFunSig summary links loc doc name typ unicode
-ppFor _ _ _ _ _ _ = error "ppFor"
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool
+ -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual
+ = ppFunSig summary links loc doc name typ unicode qual
+ppFor _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html
-ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
+ -> Qualification -> Html
+ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual
= ppTypeOrFunSig summary links loc name (unLoc ltype) doc
- (full, hdr, spaceHtml +++ equals) unicode
+ (full, hdr, spaceHtml +++ equals) unicode qual
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
- full = hdr <+> equals <+> ppLType unicode ltype
- occ = docNameOcc name
-ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+ full = hdr <+> equals <+> ppLType unicode qual ltype
+ occ = nameOccName . getName $ name
+ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
-ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html
-ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty
+ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Qualification -> Html
+ppTypeSig summary nm ty unicode qual =
+ ppBinder summary nm <+> dcolon unicode <+> ppType unicode qual ty
ppTyName :: Name -> Html
@@ -159,18 +164,18 @@
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
- TyClDecl DocName -> Bool -> Html
-ppTyFam summary associated links loc mbDoc decl unicode
+ TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyFam summary associated links loc mbDoc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode
- | otherwise = header_ +++ maybeDocSection mbDoc +++ instancesBit
+ | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
where
docname = tcdName decl
header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode)
- instancesBit = ppInstances instances docname unicode
+ instancesBit = ppInstances instances docname unicode qual
-- TODO: get the instances
instances = []
@@ -199,22 +204,23 @@
ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
- TyClDecl DocName -> Bool -> Html
-ppTyInst summary associated links loc mbDoc decl unicode
+ TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyInst summary associated links loc mbDoc decl unicode qual
- | summary = ppTyInstHeader True associated decl unicode
- | otherwise = header_ +++ maybeDocSection mbDoc
+ | summary = ppTyInstHeader True associated decl unicode qual
+ | otherwise = header_ +++ maybeDocSection qual mbDoc
where
docname = tcdName decl
- header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode)
+ header_ = topDeclElem links loc docname
+ (ppTyInstHeader summary associated decl unicode qual)
-ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
-ppTyInstHeader _ _ decl unicode =
+ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyInstHeader _ _ decl unicode qual =
keyword "type instance" <+>
- ppAppNameTypes (tcdName decl) typeArgs unicode
+ ppAppNameTypes (tcdName decl) typeArgs unicode qual
where
typeArgs = map unLoc . fromJust . tcdTyPats $ decl
@@ -224,11 +230,12 @@
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html
-ppAssocType summ links doc (L loc decl) unicode =
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool
+ -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) unicode qual =
case decl of
- TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode
- TySynonym {} -> ppTySyn summ links loc doc decl unicode
+ TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
+ TySynonym {} -> ppTySyn summ links loc doc decl unicode qual
_ -> error "declaration type not supported by ppAssocType"
@@ -249,14 +256,15 @@
-- | Print an application of a DocName and a list of HsTypes
-ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html
-ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html
+ppAppNameTypes n ts unicode qual =
+ ppTypeApp n ts (ppDocName qual) (ppParendType unicode qual)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
ppAppDocNameNames summ n ns =
- ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName
+ ppTypeApp n ns (ppBinder summ . nameOccName . getName) ppTyName
-- | General printing of type applications
@@ -276,36 +284,39 @@
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool
+ -> Qualification -> Html
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppContextNoArrow :: HsContext DocName -> Bool -> Html
-ppContextNoArrow [] _ = noHtml
-ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
+ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
+ppContextNoArrow [] _ _ = noHtml
+ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
-ppContextNoLocs :: [HsPred DocName] -> Bool -> Html
-ppContextNoLocs [] _ = noHtml
-ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
+ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs [] _ _ = noHtml
+ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual
+ <+> darrow unicode
-ppContext :: HsContext DocName -> Bool -> Html
-ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
+ppContext :: HsContext DocName -> Bool -> Qualification -> Html
+ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
-pp_hs_context :: [HsPred DocName] -> Bool -> Html
-pp_hs_context [] _ = noHtml
-pp_hs_context [p] unicode = ppPred unicode p
-pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)
+pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html
+pp_hs_context [] _ _ = noHtml
+pp_hs_context [p] unicode qual = ppPred unicode qual p
+pp_hs_context cxt unicode qual = parenList (map (ppPred unicode qual) cxt)
-ppPred :: Bool -> HsPred DocName -> Html
-ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode
-ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2
-ppPred unicode (HsIParam (IPName n) t)
- = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t
+ppPred :: Bool -> Qualification -> HsPred DocName -> Html
+ppPred unicode qual (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode qual
+ppPred unicode qual (HsEqualP t1 t2) = ppLType unicode qual t1 <+> toHtml "~"
+ <+> ppLType unicode qual t2
+ppPred unicode qual (HsIParam (IPName n) t)
+ = toHtml "?" +++ ppDocName qual n <+> dcolon unicode <+> ppLType unicode qual t
-------------------------------------------------------------------------------
@@ -315,83 +326,87 @@
ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
-> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
- -> Bool -> Html
-ppClassHdr summ lctxt n tvs fds unicode =
+ -> Bool -> Qualification -> Html
+ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else noHtml)
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
<+> ppAppDocNameNames summ n (tyvarNames $ tvs)
- <+> ppFds fds unicode
+ <+> ppFds fds unicode qual
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html
-ppFds fds unicode =
+ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
+ppFds fds unicode qual =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
- hsep (map ppDocName vars2)
+ fundep (vars1,vars2) = hsep (map (ppDocName qual) vars1) <+> arrow unicode <+>
+ hsep (map (ppDocName qual) vars2)
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html
-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode =
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
+ -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+ -> Html
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
+ subdocs unicode qual =
if null sigs && null ats
then (if summary then id else topDeclElem links loc nm) hdr
else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where")
+++ shortSubDecls
(
- [ ppAssocType summary links doc at unicode | at <- ats
+ [ ppAssocType summary links doc at unicode qual | at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
- [ ppFunSig summary links loc doc n typ unicode
+ [ ppFunSig summary links loc doc n typ unicode qual
| L _ (TypeSig (L _ n) (L _ typ)) <- sigs
, let doc = lookupAnySubdoc n subdocs ]
)
where
- hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode
+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
nm = unLoc lname
-ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
- -> TyClDecl DocName -> Bool -> Html
+ -> TyClDecl DocName -> Bool -> Qualification -> Html
ppClassDecl summary links instances loc mbDoc subdocs
- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
- | summary = ppShortClassDecl summary links decl loc subdocs unicode
- | otherwise = classheader +++ maybeDocSection mbDoc
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual
+ | summary = ppShortClassDecl summary links decl loc subdocs unicode qual
+ | otherwise = classheader +++ maybeDocSection qual mbDoc
+++ atBit +++ methodBit +++ instancesBit
where
classheader
- | null lsigs = topDeclElem links loc nm (hdr unicode)
- | otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where")
+ | null lsigs = topDeclElem links loc nm (hdr unicode qual)
+ | otherwise = topDeclElem links loc nm (hdr unicode qual <+> keyword "where")
nm = unLoc $ tcdLName decl
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
- atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual
| at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
- methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode
+ methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode qual
| L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
, let doc = lookupAnySubdoc n subdocs ]
- instancesBit = ppInstances instances nm unicode
+ instancesBit = ppInstances instances nm unicode qual
-ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Html
-ppInstances instances baseName unicode
- = subInstances instName (map instDecl instances)
+ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html
+ppInstances instances baseName unicode qual
+ = subInstances qual instName (map instDecl instances)
where
instName = getOccString $ getName baseName
instDecl :: DocInstance DocName -> SubDecl
instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
- instHead ([], n, ts) = ppAppNameTypes n ts unicode
- instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
+ instHead ([], n, ts) = ppAppNameTypes n ts unicode qual
+ instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual
+ <+> ppAppNameTypes n ts unicode qual
lookupAnySubdoc :: (Eq name1) =>
@@ -407,13 +422,14 @@
-- TODO: print contexts
-ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html
-ppShortDataDecl summary _links _loc dataDecl unicode
+ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
+ -> Qualification -> Html
+ppShortDataDecl summary _links _loc dataDecl unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons = dataHeader
| [lcon] <- cons, ResTyH98 <- resTy,
- (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode
+ (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
| ResTyH98 <- resTy = dataHeader
@@ -423,9 +439,9 @@
+++ shortSubDecls (map doGADTConstr cons)
where
- dataHeader = ppDataHeader summary dataDecl unicode
- doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode
- doGADTConstr con = ppShortConstr summary (unLoc con) unicode
+ dataHeader = ppDataHeader summary dataDecl unicode qual
+ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
+ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
@@ -433,18 +449,19 @@
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html
-ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
+ SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+ Qualification -> Html
+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
- | summary = ppShortDataDecl summary links loc dataDecl unicode
- | otherwise = header_ +++ maybeDocSection mbDoc +++ constrBit +++ instancesBit
+ | summary = ppShortDataDecl summary links loc dataDecl unicode qual
+ | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit
where
docname = unLoc . tcdLName $ dataDecl
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
- header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode
+ header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode qual
<+> whereBit)
whereBit
@@ -453,33 +470,34 @@
ResTyGADT _ -> keyword "where"
_ -> noHtml
- constrBit = subConstructors
- (map (ppSideBySideConstr subdocs unicode) cons)
+ constrBit = subConstructors qual
+ (map (ppSideBySideConstr subdocs unicode qual) cons)
- instancesBit = ppInstances instances docname unicode
+ instancesBit = ppInstances instances docname unicode qual
-ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
-ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot
+ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html
+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
where
- (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode
+ (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode qual
-- returns three pieces: header, body, footer so that header & footer can be
-- incorporated into the declaration
-ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> (Html, Html, Html)
-ppShortConstrParts summary con unicode = case con_res con of
+ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> Qualification -> (Html, Html, Html)
+ppShortConstrParts summary con unicode qual = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- (header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args),
- noHtml, noHtml)
+ (header_ unicode qual +++ hsep (ppBinder summary occ
+ : map (ppLParendType unicode qual) args), noHtml, noHtml)
RecCon fields ->
- (header_ unicode +++ ppBinder summary occ <+> char '{',
+ (header_ unicode qual +++ ppBinder summary occ <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
- (header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2],
+ (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
+ ppBinder summary occ, ppLParendType unicode qual arg2],
noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
@@ -491,19 +509,19 @@
-- (except each field gets its own line in docs, to match
-- non-GADT records)
RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
- ppForAll forall ltvs lcontext unicode <+> char '{',
+ ppForAll forall ltvs lcontext unicode qual <+> char '{',
doRecordFields fields,
- char '}' <+> arrow unicode <+> ppLType unicode resTy)
+ char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
where
- doRecordFields fields = shortSubDecls (map (ppShortField summary unicode) fields)
+ doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields)
doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs lcontext unicode,
- ppLType unicode (foldr mkFunTy resTy args) ]
+ ppForAll forall ltvs lcontext unicode qual,
+ ppLType unicode qual (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall tyVars context
- occ = docNameOcc . unLoc . con_name $ con
+ occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames ltvs
lcontext = con_cxt con
@@ -513,36 +531,35 @@
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-#if __GLASGOW_HASKELL__ == 612
-ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html
-#else
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html
-#endif
-ppConstrHdr forall tvs ctxt unicode
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
+ -> Qualification -> Html
+ppConstrHdr forall tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
+++
- (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ")
+ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
+ <+> darrow unicode +++ toHtml " ")
where
ppForall = case forall of
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> noHtml
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart)
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+ -> LConDecl DocName -> SubDecl
+ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
where
decl = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- hsep ((header_ unicode +++ ppBinder False occ)
- : map (ppLParendType unicode) args)
+ hsep ((header_ unicode qual +++ ppBinder False occ)
+ : map (ppLParendType unicode qual) args)
- RecCon _ -> header_ unicode +++ ppBinder False occ
+ RecCon _ -> header_ unicode qual +++ ppBinder False occ
InfixCon arg1 arg2 ->
- hsep [header_ unicode+++ppLParendType unicode arg1,
+ hsep [header_ unicode qual +++ ppLParendType unicode qual arg1,
ppBinder False occ,
- ppLParendType unicode arg2]
+ ppLParendType unicode qual arg2]
ResTyGADT resTy -> case con_details con of
-- prefix & infix could also use hsConDeclArgTys if it seemed to
@@ -555,16 +572,16 @@
RecCon fields -> [doRecordFields fields]
_ -> []
- doRecordFields fields = subFields
- (map (ppSideBySideField subdocs unicode) fields)
+ doRecordFields fields = subFields qual
+ (map (ppSideBySideField subdocs unicode qual) fields)
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
doGADTCon args resTy =
ppBinder False occ <+> dcolon unicode
- <+> hsep [ppForAll forall ltvs (con_cxt con) unicode,
- ppLType unicode (foldr mkFunTy resTy args) ]
+ <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual,
+ ppLType unicode qual (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall tyVars context
- occ = docNameOcc . unLoc . con_name $ con
+ occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
@@ -576,9 +593,10 @@
mkFunTy a b = noLoc (HsFunTy a b)
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> SubDecl
-ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
- (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype,
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+ -> ConDeclField DocName -> SubDecl
+ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
+ (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
mbDoc,
[])
where
@@ -586,22 +604,22 @@
mbDoc = join $ fmap fst $ lookup name subdocs
-ppShortField :: Bool -> Bool -> ConDeclField DocName -> Html
-ppShortField summary unicode (ConDeclField (L _ name) ltype _)
- = ppBinder summary (docNameOcc name)
- <+> dcolon unicode <+> ppLType unicode ltype
+ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
+ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
+ = ppBinder summary (nameOccName . getName $ name)
+ <+> dcolon unicode <+> ppLType unicode qual ltype
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html
-ppDataHeader summary decl unicode
+ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppDataHeader summary decl unicode qual
| not (isDataDecl decl) = error "ppDataHeader: illegal argument"
| otherwise =
-- newtype or data
(if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
-- context
- ppLContext (tcdCtxt decl) unicode <+>
+ ppLContext (tcdCtxt decl) unicode qual <+>
-- T a b c ..., or a :+: b
ppTyClBinderWithVars summary decl
@@ -648,85 +666,80 @@
| otherwise = p
-ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html
-ppLType unicode y = ppType unicode (unLoc y)
-ppLParendType unicode y = ppParendType unicode (unLoc y)
-ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
+ppLType, ppLParendType, ppLFunLhType :: Bool -> Qualification
+ -> Located (HsType DocName) -> Html
+ppLType unicode qual y = ppType unicode qual (unLoc y)
+ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
+ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
-ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> Html
-ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
-ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode
+ppType, ppParendType, ppFunLhType :: Bool -> Qualification-> HsType DocName -> Html
+ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
+ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
+ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-#if __GLASGOW_HASKELL__ == 612
-ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]
-#else
ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
-#endif
- -> Located (HsContext DocName) -> Bool -> Html
-ppForAll expl tvs cxt unicode
- | show_forall = forall_part <+> ppLContext cxt unicode
- | otherwise = ppLContext cxt unicode
+ -> Located (HsContext DocName) -> Bool -> Qualification -> Html
+ppForAll expl tvs cxt unicode qual
+ | show_forall = forall_part <+> ppLContext cxt unicode qual
+ | otherwise = ppLContext cxt unicode qual
where
show_forall = not (null tvs) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False}
forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html
-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual
-ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
+ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
= maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
+ hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
-ppr_mono_ty _ (HsBangTy b ty) u = ppBang b +++ ppLParendType u ty
-ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
-ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
-ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)
-ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only
-ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
-#if __GLASGOW_HASKELL__ == 612
-ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#else
-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#endif
-ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
+ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
+ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
+ppr_mono_ty _ (HsKindSig ty kind) u q =
+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)
+ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p)
+ppr_mono_ty _ (HsNumTy n) _ _ = toHtml (show n) -- generics only
+ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
= maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
= maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
+ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
where
- ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op
- occName = docNameOcc . unLoc $ op
+ ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op
+ occName = nameOccName . getName . unLoc $ op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
-- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode
+ = ppr_mono_lty ctxt_prec ty unicode qual
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
- = ppr_mono_lty ctxt_prec ty unicode
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
+ = ppr_mono_lty ctxt_prec ty unicode qual
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html
-ppr_fun_ty ctxt_prec ty1 ty2 unicode
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
- p2 = ppr_mono_lty pREC_TOP ty2 unicode
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
in
maybeParen ctxt_prec pREC_FUN $
hsep [p1, arrow unicode <+> p2]
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -64,20 +64,20 @@
| isTyCon x = x
| otherwise = y
- examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+ examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
exampleToHtml (Example expression result) = htmlExample
where
- htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result)
+ htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
-- If the doc is a single paragraph, don't surround it with (this causes
-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
-docToHtml :: Doc DocName -> Html
-docToHtml = markup fmt . cleanup
- where fmt = parHtmlMarkup ppDocName (isTyConName . getName)
+docToHtml :: Qualification -> Doc DocName -> Html
+docToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup (ppDocName qual) (isTyConName . getName)
origDocToHtml :: Doc Name -> Html
@@ -97,12 +97,12 @@
else el ! [theclass "doc"] << content_
-docSection :: Doc DocName -> Html
-docSection = (docElement thediv <<) . docToHtml
+docSection :: Qualification -> Doc DocName -> Html
+docSection qual = (docElement thediv <<) . docToHtml qual
-maybeDocSection :: Maybe (Doc DocName) -> Html
-maybeDocSection = maybe noHtml docSection
+maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
+maybeDocSection qual = maybe noHtml (docSection qual)
cleanup :: Doc a -> Doc a
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -112,25 +112,26 @@
subCaption = paragraph ! [theclass "caption"] << captionName
-subDlist :: [SubDecl] -> Maybe Html
-subDlist [] = Nothing
-subDlist decls = Just $ dlist << map subEntry decls +++ clearDiv
+subDlist :: Qualification -> [SubDecl] -> Maybe Html
+subDlist _ [] = Nothing
+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
where
subEntry (decl, mdoc, subs) =
dterm ! [theclass "src"] << decl
+++
- docElement ddef << (fmap docToHtml mdoc +++ subs)
+ docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
+
clearDiv = thediv ! [ theclass "clear" ] << noHtml
-subTable :: [SubDecl] -> Maybe Html
-subTable [] = Nothing
-subTable decls = Just $ table << aboves (concatMap subRow decls)
+subTable :: Qualification -> [SubDecl] -> Maybe Html
+subTable _ [] = Nothing
+subTable qual decls = Just $ table << aboves (concatMap subRow decls)
where
subRow (decl, mdoc, subs) =
(td ! [theclass "src"] << decl
<->
- docElement td << fmap docToHtml mdoc)
+ docElement td << fmap (docToHtml qual) mdoc)
: map (cell . (td <<)) subs
@@ -139,28 +140,28 @@
subBlock hs = Just $ toHtml hs
-subArguments :: [SubDecl] -> Html
-subArguments = divSubDecls "arguments" "Arguments" . subTable
+subArguments :: Qualification -> [SubDecl] -> Html
+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
subAssociatedTypes :: [Html] -> Html
subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
-subConstructors :: [SubDecl] -> Html
-subConstructors = divSubDecls "constructors" "Constructors" . subTable
+subConstructors :: Qualification -> [SubDecl] -> Html
+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
-subFields :: [SubDecl] -> Html
-subFields = divSubDecls "fields" "Fields" . subDlist
+subFields :: Qualification -> [SubDecl] -> Html
+subFields qual = divSubDecls "fields" "Fields" . subDlist qual
-subInstances :: String -> [SubDecl] -> Html
-subInstances nm = maybe noHtml wrap . instTable
+subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances qual nm = maybe noHtml wrap . instTable
where
wrap = (subSection <<) . (subCaption +++)
- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable
- subSection = thediv ! [theclass $ "subs instances"]
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+ subSection = thediv ! [theclass "subs instances"]
subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
id_ = makeAnchorId $ "i:" ++ nm
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -24,6 +24,7 @@
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.List as List
import GHC
import Name
@@ -38,15 +39,45 @@
ppRdrName = ppOccName . rdrNameOcc
-ppLDocName :: Located DocName -> Html
-ppLDocName (L _ d) = ppDocName d
+ppLDocName :: Qualification -> Located DocName -> Html
+ppLDocName qual (L _ d) = ppDocName qual d
-ppDocName :: DocName -> Html
-ppDocName (Documented name mdl) =
- linkIdOcc mdl (Just occName) << ppOccName occName
- where occName = nameOccName name
-ppDocName (Undocumented name) = toHtml (getOccString name)
+ppDocName :: Qualification -> DocName -> Html
+ppDocName qual docName =
+ case docName of
+ Documented name mdl ->
+ linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
+ Undocumented name -> ppQualifyName qual name (nameModule name)
+
+
+-- | Render a name depending on the selected qualification mode
+ppQualifyName :: Qualification -> Name -> Module -> Html
+ppQualifyName qual name mdl =
+ case qual of
+ NoQual -> ppName name
+ FullQual -> ppFullQualName mdl name
+ -- this is just in case, it should never happen
+ LocalQual Nothing -> ppQualifyName FullQual name mdl
+ LocalQual (Just localmdl)
+ | moduleString mdl == moduleString localmdl -> ppName name
+ | otherwise -> ppFullQualName mdl name
+ -- again, this never happens
+ RelativeQual Nothing -> ppQualifyName FullQual name mdl
+ RelativeQual (Just localmdl) ->
+ case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+ -- local, A.x -> x
+ Just [] -> ppQualifyName NoQual name mdl
+ -- sub-module, A.B.x -> B.x
+ Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
+ -- some module with same prefix, ABC.x -> ABC.x
+ Just _ -> ppQualifyName FullQual name mdl
+ -- some other module, D.x -> D.x
+ Nothing -> ppQualifyName FullQual name mdl
+
+
+ppFullQualName :: Module -> Name -> Html
+ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
ppName :: Name -> Html
diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs
--- a/src/Haddock/Backends/Xhtml/Themes.hs
+++ b/src/Haddock/Backends/Xhtml/Themes.hs
@@ -18,6 +18,7 @@
import Haddock.Options
+import Control.Applicative
import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Either (lefts, rights)
@@ -97,13 +98,13 @@
-- | Check if we have a built in theme
doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
-doesBuiltInExist pts s = pts >>= return . either (const False) test
+doesBuiltInExist pts s = fmap (either (const False) test) pts
where test = isJust . findTheme s
-- | Find a built in theme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
-builtInTheme pts s = pts >>= return . either Left fetch
+builtInTheme pts s = either Left fetch <$> pts
where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s
@@ -157,9 +158,10 @@
-- * File Utilities
--------------------------------------------------------------------------------
+
getDirectoryItems :: FilePath -> IO [FilePath]
getDirectoryItems path =
- getDirectoryContents path >>= return . map (combine path) . filter notDot
+ map (combine path) . filter notDot <$> getDirectoryContents path
where notDot s = s /= "." && s /= ".."
@@ -178,7 +180,7 @@
styleSheet :: Themes -> Html
styleSheet ts = toHtml $ zipWith mkLink rels ts
where
- rels = ("stylesheet" : repeat "alternate stylesheet")
+ rels = "stylesheet" : repeat "alternate stylesheet"
mkLink aRel t =
thelink
! [ href (themeHref t), rel aRel, thetype "text/css",
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -15,6 +15,7 @@
namedAnchor, linkedAnchor,
spliceURL,
+ groupId,
(<+>), char, nonEmpty,
keyword, punctuate,
@@ -66,7 +67,7 @@
run ('%':'N':rest) = name ++ run rest
run ('%':'K':rest) = kind ++ run rest
run ('%':'L':rest) = line ++ run rest
- run ('%':'%':rest) = "%" ++ run rest
+ run ('%':'%':rest) = "%" ++ run rest
run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
@@ -84,9 +85,10 @@
run (c:rest) = c : run rest
-renderToString :: Html -> String
-renderToString = showHtml -- for production
---renderToString = prettyHtml -- for debugging
+renderToString :: Bool -> Html -> String
+renderToString debug html
+ | debug = renderHtml html
+ | otherwise = showHtml html
hsep :: [Html] -> Html
@@ -171,6 +173,10 @@
linkedAnchor :: String -> Html -> Html
linkedAnchor n = anchor ! [href ('#':n)]
+
+-- | generate an anchor identifier for a group
+groupId :: String -> String
+groupId g = makeAnchorId ("g:" ++ g)
--
-- A section of HTML which is collapsible.
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,12 +20,7 @@
import HsSyn
import TcType ( tcSplitSigmaTy )
import TypeRep
-#if __GLASGOW_HASKELL__ == 612
-import Type ( splitKindFunTys )
-import BasicTypes
-#else
-import Coercion ( splitKindFunTys )
-#endif
+import Coercion ( splitKindFunTys, synTyConResKind )
import Name
import Var
import Class
@@ -101,15 +96,15 @@
[]
-- "deriving" needn't be specified:
Nothing
- | isOpenSynTyCon tc =
+ | isSynFamilyTyCon tc =
case synTyConRhs tc of
- OpenSynTyCon rhs_kind _ ->
+ SynFamilyTyCon ->
TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- (Just rhs_kind)
+ (Just (synTyConResKind tc))
_ -> error "synifyTyCon: impossible open type synonym?"
- | isOpenTyCon tc = --(why no "isOpenAlgTyCon"?)
+ | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)
case algTyConRhs tc of
- OpenTyCon _ ->
+ DataFamilyTyCon ->
TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing --always kind '*'
_ -> error "synifyTyCon: impossible open data type?"
@@ -175,18 +170,10 @@
linear_tys = zipWith (\ty bang ->
let tySyn = synifyType WithinType ty
in case bang of
-#if __GLASGOW_HASKELL__ >= 613
HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn
HsNoBang -> tySyn
-- HsNoBang never appears, it's implied instead.
_ -> noLoc $ HsBangTy bang tySyn
-#else
- MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
- MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
- NotMarkedStrict -> tySyn
- -- HsNoBang never appears, it's implied instead.
-#endif
-
)
(dataConOrigArgTys dc) (dataConStrictMarks dc)
field_tys = zipWith (\field synTy -> ConDeclField
@@ -245,11 +232,7 @@
kind = tyVarKind tv
name = getName tv
in if isLiftedTypeKind kind
-#if __GLASGOW_HASKELL__ == 612
- then UserTyVar name
-#else
then UserTyVar name placeHolderKind
-#endif
else KindedTyVar name kind
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -17,7 +17,6 @@
import Data.Version
-import qualified Data.Map as Map
import Control.Arrow
import Data.Foldable hiding (concatMap)
import Data.Traversable
@@ -30,12 +29,11 @@
import Packages
import Module
import RdrName (GlobalRdrEnv)
+#if MIN_VERSION_ghc(7,1,0)
+import GhcMonad (withSession)
+#endif
import HscTypes
-#if __GLASGOW_HASKELL__ >= 613
import UniqFM
-#else
-import LazyUniqFM
-#endif
import GHC
@@ -75,10 +73,6 @@
_not_a_home_module -> return Nothing
-instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where
- ppr m = ppr (Map.toList m)
-
-
isNameSym :: Name -> Bool
isNameSym = isSymOcc . nameOccName
@@ -90,15 +84,9 @@
getMainDeclBinder :: HsDecl name -> Maybe name
getMainDeclBinder (TyClD d) = Just (tcdName d)
getMainDeclBinder (ValD d) =
-#if __GLASGOW_HASKELL__ == 612
- case collectAcc d [] of
- [] -> Nothing
- (name:_) -> Just (unLoc name)
-#else
case collectHsBindBinders d of
[] -> Nothing
(name:_) -> Just name
-#endif
getMainDeclBinder (SigD d) = sigNameNoLoc d
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -46,6 +46,7 @@
import Distribution.Verbosity
import System.Directory
import System.FilePath
+import Text.Printf
import Digraph
import Exception
@@ -101,12 +102,11 @@
-- resulting ModSummaries.
(if useTempDir then withTempOutputDir else id) $ do
modGraph <- depAnalysis
- if needsTemplateHaskell modGraph
- then do
- modGraph' <- enableCompilation modGraph
- createIfaces verbosity flags instIfaceMap modGraph'
- else
- createIfaces verbosity flags instIfaceMap modGraph
+ if needsTemplateHaskell modGraph then do
+ modGraph' <- enableCompilation modGraph
+ createIfaces verbosity flags instIfaceMap modGraph'
+ else
+ createIfaces verbosity flags instIfaceMap modGraph
where
useTempDir :: Bool
@@ -156,15 +156,21 @@
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
tm <- loadModule =<< typecheckModule =<< parseModule modsum
- if not $ isBootSummary modsum
- then do
- out verbosity verbose "Creating interface..."
- (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
- liftIO $ mapM_ putStrLn msg
- interface' <- liftIO $ evaluate interface
- return (Just interface')
- else
- return Nothing
+ if not $ isBootSummary modsum then do
+ out verbosity verbose "Creating interface..."
+ (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+ liftIO $ mapM_ putStrLn msg
+ let (haddockable, haddocked) = ifaceHaddockCoverage interface
+ percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
+ coveragemsg = printf "haddock coverage for %s: %7s %3d%%"
+ (ifaceOrigFilename interface)
+ (printf "%d/%d" haddocked haddockable :: String)
+ percentage
+ out verbosity normal coveragemsg
+ interface' <- liftIO $ evaluate interface
+ return (Just interface')
+ else
+ return Nothing
--------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -25,7 +25,12 @@
import Name
import InstEnv
import Class
-import HscTypes (withSession, ioMsg)
+#if MIN_VERSION_ghc(7,1,0)
+import GhcMonad (withSession)
+#else
+import HscTypes (withSession)
+#endif
+import MonadUtils (liftIO)
import TcRnDriver (tcRnGetInfo)
import TypeRep hiding (funTyConName)
import Var hiding (varName)
@@ -93,7 +98,9 @@
-- | 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,[Instance]))
-getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name
+getAllInfo name = withSession $ \hsc_env -> do
+ (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
+ return r
--------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -79,11 +79,18 @@
let visibleNames = mkVisibleNames exportItems opts
+ -- measure haddock documentation coverage.
+ let
+ prunedExportItems0 = pruneExportItems exportItems
+ haddockable = 1 + length exportItems -- module + exports
+ haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+ coverage = (haddockable, haddocked)
+
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
let
prunedExportItems
- | OptPrune `elem` opts = pruneExportItems exportItems
+ | OptPrune `elem` opts = prunedExportItems0
| otherwise = exportItems
return Interface {
@@ -101,7 +108,8 @@
ifaceDeclMap = declMap,
ifaceSubMap = mkSubMap declMap exportedNames,
ifaceInstances = instances,
- ifaceInstanceDocMap = instanceDocMap
+ ifaceInstanceDocMap = instanceDocMap,
+ ifaceHaddockCoverage = coverage
}
@@ -565,53 +573,52 @@
-- those exported type-inferenced values.
isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do
let mdl = nameModule t
- if modulePackageId mdl == thisPackage dflags
- then isLoaded (moduleName mdl)
- else return False
+ if modulePackageId mdl == thisPackage dflags then
+ isLoaded (moduleName mdl)
+ else return False
- if isLocalAndTypeInferenced
- then do
- -- I don't think there can be any subs in this case,
- -- currently? But better not to rely on it.
- let subs = subordinatesWithNoDocs (unLoc hsdecl)
- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
- else
- -- We try to get the subs and docs
- -- from the installed interface of that package.
- case Map.lookup (nameModule t) instIfaceMap of
- -- It's Nothing in the cases where I thought
- -- Haddock has already warned the user: "Warning: The
- -- documentation for the following packages are not
- -- installed. No links will be generated to these packages:
- -- ..."
- -- But I guess it was Cabal creating that warning. Anyway,
- -- this is more serious than links: it's exported decls where
- -- we don't have the docs that they deserve!
+ if isLocalAndTypeInferenced then do
+ -- I don't think there can be any subs in this case,
+ -- currently? But better not to rely on it.
+ let subs = subordinatesWithNoDocs (unLoc hsdecl)
+ return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
+ else
+ -- We try to get the subs and docs
+ -- from the installed interface of that package.
+ case Map.lookup (nameModule t) instIfaceMap of
+ -- It's Nothing in the cases where I thought
+ -- Haddock has already warned the user: "Warning: The
+ -- documentation for the following packages are not
+ -- installed. No links will be generated to these packages:
+ -- ..."
+ -- But I guess it was Cabal creating that warning. Anyway,
+ -- this is more serious than links: it's exported decls where
+ -- we don't have the docs that they deserve!
- -- We could use 'subordinates' to find the Names of the subs
- -- (with no docs). Is that necessary? Yes it is, otherwise
- -- e.g. classes will be shown without their exported subs.
- Nothing -> do
- liftErrMsg $ tell
- ["Warning: Couldn't find .haddock for exported "
- ++ exportInfoString]
- let subs = subordinatesWithNoDocs (unLoc hsdecl)
- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
- Just iface -> do
- let subs = case Map.lookup t (instSubMap iface) of
- Nothing -> []
- Just x -> x
- return [ mkExportDecl t
- ( hsdecl
- , fromMaybe noDocForDecl $
- Map.lookup t (instDocMap iface)
- , map (\subt ->
- ( subt ,
- fromMaybe noDocForDecl $
- Map.lookup subt (instDocMap iface)
- )
- ) subs
- )]
+ -- We could use 'subordinates' to find the Names of the subs
+ -- (with no docs). Is that necessary? Yes it is, otherwise
+ -- e.g. classes will be shown without their exported subs.
+ Nothing -> do
+ liftErrMsg $ tell
+ ["Warning: Couldn't find .haddock for exported "
+ ++ exportInfoString]
+ let subs = subordinatesWithNoDocs (unLoc hsdecl)
+ return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
+ Just iface -> do
+ let subs = case Map.lookup t (instSubMap iface) of
+ Nothing -> []
+ Just x -> x
+ return [ mkExportDecl t
+ ( hsdecl
+ , fromMaybe noDocForDecl $
+ Map.lookup t (instDocMap iface)
+ , map (\subt ->
+ ( subt ,
+ fromMaybe noDocForDecl $
+ Map.lookup subt (instDocMap iface)
+ )
+ ) subs
+ )]
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -35,6 +35,9 @@
import UniqFM
import IfaceEnv
import HscTypes
+#if MIN_VERSION_ghc(7,1,0)
+import GhcMonad (withSession)
+#endif
import FastMutInt
import FastString
import Unique
@@ -61,13 +64,9 @@
-- because we store GHC datatypes in our interface files, we need to make sure
-- we version our interface files accordingly.
binaryInterfaceVersion :: Word16
-#if __GLASGOW_HASKELL__ == 612
-binaryInterfaceVersion = 15
-#elif __GLASGOW_HASKELL__ == 613
-binaryInterfaceVersion = 15
-#elif __GLASGOW_HASKELL__ == 614
+#if __GLASGOW_HASKELL__ == 700
binaryInterfaceVersion = 16
-#elif __GLASGOW_HASKELL__ == 615
+#elif __GLASGOW_HASKELL__ == 701
binaryInterfaceVersion = 16
#else
#error Unknown GHC version
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -8,6 +8,7 @@
--
{
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -Wwarn -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
@@ -184,12 +185,12 @@
strToHsQNames :: DynFlags -> String -> Maybe [RdrName]
strToHsQNames dflags str0 =
- let buffer = unsafePerformIO (stringToStringBuffer str0)
-#if MIN_VERSION_ghc(6,13,0)
- pstate = mkPState dflags buffer noSrcLoc
+#if MIN_VERSION_ghc(7,1,0)
+ let buffer = stringToStringBuffer str0
#else
- pstate = mkPState buffer noSrcLoc dflags
+ let buffer = unsafePerformIO (stringToStringBuffer str0)
#endif
+ pstate = mkPState dflags buffer noSrcLoc
result = unP parseIdentifier pstate
in case result of
POk _ name -> Just [unLoc name]
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -24,6 +24,7 @@
wikiUrls,
optDumpInterfaceFile,
optLaTeXStyle,
+ qualification,
verbosity,
ghcFlags,
readIfaceArgs
@@ -35,12 +36,12 @@
import Haddock.Utils
import Haddock.Types
import System.Console.GetOpt
+import qualified Data.Char as Char
data Flag
= Flag_BuiltInThemes
| Flag_CSS String
- | Flag_Debug
-- | Flag_DocBook
| Flag_ReadInterface String
| Flag_DumpInterface String
@@ -74,6 +75,8 @@
| Flag_NoWarnings
| Flag_UseUnicode
| Flag_NoTmpCompDir
+ | Flag_Qualification String
+ | Flag_PrettyHtml
deriving (Eq)
@@ -120,8 +123,8 @@
"file containing prologue text",
Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
"page heading",
- Option ['d'] ["debug"] (NoArg Flag_Debug)
- "extra debugging output",
+ Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")
+ "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'",
Option ['?'] ["help"] (NoArg Flag_Help)
"display this help and exit",
Option ['V'] ["version"] (NoArg Flag_Version)
@@ -148,7 +151,9 @@
"output GHC lib dir",
Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
- "do not re-direct compilation output to a temporary directory"
+ "do not re-direct compilation output to a temporary directory",
+ Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
+ "generate html with newlines and indenting (for use with --html)"
]
@@ -216,6 +221,15 @@
optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
+
+
+qualification :: [Flag] -> Qualification
+qualification flags =
+ case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
+ "full":_ -> FullQual
+ "local":_ -> LocalQual Nothing
+ "relative":_ -> RelativeQual Nothing
+ _ -> NoQual
verbosity :: [Flag] -> Verbosity
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -1,4 +1,5 @@
{
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -Wwarn -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -53,96 +53,100 @@
-- lies in creating this structure. Note that the record contains some fields
-- that are only used to create the final record, and that are not used by the
-- backends.
-data Interface = Interface {
+data Interface = Interface
+ {
+ -- | The module behind this interface.
+ ifaceMod :: Module
- -- | The module represented by this interface.
- ifaceMod :: Module,
+ -- | Original file name of the module.
+ , ifaceOrigFilename :: FilePath
- -- | Original file name of the module.
- ifaceOrigFilename :: FilePath,
+ -- | Textual information about the module.
+ , ifaceInfo :: !(HaddockModInfo Name)
- -- | Textual information about the module.
- ifaceInfo :: !(HaddockModInfo Name),
+ -- | Documentation header.
+ , ifaceDoc :: !(Maybe (Doc Name))
- -- | Documentation header.
- ifaceDoc :: !(Maybe (Doc Name)),
+ -- | Documentation header with cross-reference information.
+ , ifaceRnDoc :: Maybe (Doc DocName)
- -- | Documentation header with link information.
- ifaceRnDoc :: Maybe (Doc DocName),
+ -- | Haddock options for this module (prune, ignore-exports, etc).
+ , ifaceOptions :: ![DocOption]
- -- | Haddock options for this module (prune, ignore-exports, etc).
- ifaceOptions :: ![DocOption],
+ -- | Declarations originating from the module. Excludes declarations without
+ -- names (instances and stand-alone documentation comments). Includes
+ -- names of subordinate declarations mapped to their parent declarations.
+ , ifaceDeclMap :: Map Name DeclInfo
- -- | Declarations originating from the module. Excludes declarations without
- -- names (instances and stand-alone documentation comments). Includes
- -- names of subordinate declarations mapped to their parent declarations.
- ifaceDeclMap :: Map Name DeclInfo,
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
+ , ifaceRnDocMap :: Map Name (DocForDecl DocName)
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- ifaceRnDocMap :: Map Name (DocForDecl DocName),
+ , ifaceSubMap :: Map Name [Name]
- ifaceSubMap :: Map Name [Name],
+ , ifaceExportItems :: ![ExportItem Name]
+ , ifaceRnExportItems :: [ExportItem DocName]
- ifaceExportItems :: ![ExportItem Name],
- ifaceRnExportItems :: [ExportItem DocName],
+ -- | All names exported by the module.
+ , ifaceExports :: ![Name]
- -- | All names exported by the module.
- ifaceExports :: ![Name],
+ -- | All \"visible\" names exported by the module.
+ -- A visible name is a name that will show up in the documentation of the
+ -- module.
+ , ifaceVisibleExports :: ![Name]
- -- | All \"visible\" names exported by the module.
- -- A visible name is a name that will show up in the documentation of the
- -- module.
- ifaceVisibleExports :: ![Name],
+ -- | Instances exported by the module.
+ , ifaceInstances :: ![Instance]
- -- | Instances exported by the module.
- ifaceInstances :: ![Instance],
+ -- | Documentation of instances defined in the module.
+ , ifaceInstanceDocMap :: Map Name (Doc Name)
- -- | Documentation of instances defined in the module.
- ifaceInstanceDocMap :: Map Name (Doc Name)
-}
+ -- | 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)
+ }
--- | A smaller version of 'Interface' that can be created from Haddock's
--- interface files ('InterfaceFile').
-data InstalledInterface = InstalledInterface {
-
- -- | The module represented by this interface.
- instMod :: Module,
+-- | A subset of the fields of 'Interface' that we store in the interface
+-- files.
+data InstalledInterface = InstalledInterface
+ {
+ -- | The module represented by this interface.
+ instMod :: Module
- -- | Textual information about the module.
- instInfo :: HaddockModInfo Name,
+ -- | Textual information about the module.
+ , instInfo :: HaddockModInfo Name
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- instDocMap :: Map Name (DocForDecl Name),
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
+ , instDocMap :: Map Name (DocForDecl Name)
- -- | All names exported by this module.
- instExports :: [Name],
+ -- | All names exported by this module.
+ , instExports :: [Name]
- -- | All \"visible\" names exported by the module.
- -- A visible name is a name that will show up in the documentation of the
- -- module.
- instVisibleExports :: [Name],
+ -- | All \"visible\" names exported by the module.
+ -- A visible name is a name that will show up in the documentation of the
+ -- module.
+ , instVisibleExports :: [Name]
- -- | Haddock options for this module (prune, ignore-exports, etc).
- instOptions :: [DocOption],
+ -- | Haddock options for this module (prune, ignore-exports, etc).
+ , instOptions :: [DocOption]
- instSubMap :: Map Name [Name]
-}
+ , instSubMap :: Map Name [Name]
+ }
-- | Convert an 'Interface' to an 'InstalledInterface'
toInstalledIface :: Interface -> InstalledInterface
-toInstalledIface interface = InstalledInterface {
- instMod = ifaceMod interface,
- instInfo = ifaceInfo interface,
- instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface,
- instExports = ifaceExports interface,
- instVisibleExports = ifaceVisibleExports interface,
- instOptions = ifaceOptions interface,
- instSubMap = ifaceSubMap interface
-}
+toInstalledIface interface = InstalledInterface
+ { instMod = ifaceMod interface
+ , instInfo = ifaceInfo interface
+ , instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface
+ , instExports = ifaceExports interface
+ , instVisibleExports = ifaceVisibleExports interface
+ , instOptions = ifaceOptions interface
+ , instSubMap = ifaceSubMap interface
+ }
-----------------------------------------------------------------------------
@@ -152,53 +156,55 @@
data ExportItem name
- = ExportDecl {
-
- -- | A declaration
- expItemDecl :: LHsDecl name,
-
- -- | Maybe a doc comment, and possibly docs for arguments (if this
- -- decl is a function or type-synonym)
- expItemMbDoc :: DocForDecl name,
-
- -- | Subordinate names, possibly with documentation
- expItemSubDocs :: [(name, DocForDecl name)],
-
- -- | Instances relevant to this declaration, possibly with documentation
- expItemInstances :: [DocInstance name]
-
- } -- ^ An exported declaration
+ -- | An exported declaration.
+ = ExportDecl
+ {
+ -- | A declaration.
+ expItemDecl :: LHsDecl name
- | ExportNoDecl {
- expItemName :: name,
+ -- | Maybe a doc comment, and possibly docs for arguments (if this
+ -- decl is a function or type-synonym).
+ , expItemMbDoc :: DocForDecl name
- -- | Subordinate names
- expItemSubs :: [name]
+ -- | Subordinate names, possibly with documentation.
+ , expItemSubDocs :: [(name, DocForDecl name)]
- } -- ^ An exported entity for which we have no
- -- documentation (perhaps because it resides in
- -- another package)
+ -- | Instances relevant to this declaration, possibly with
+ -- documentation.
+ , expItemInstances :: [DocInstance name]
+ }
- | ExportGroup {
+ -- | An exported entity for which we have no documentation (perhaps because it
+ -- resides in another package).
+ | ExportNoDecl
+ { expItemName :: name
- -- | Section level (1, 2, 3, ... )
- expItemSectionLevel :: Int,
+ -- | Subordinate names.
+ , expItemSubs :: [name]
+ }
- -- | Section id (for hyperlinks)
- expItemSectionId :: String,
+ -- | A section heading.
+ | ExportGroup
+ {
+ -- | Section level (1, 2, 3, ...).
+ expItemSectionLevel :: Int
- -- | Section heading text
- expItemSectionText :: Doc name
+ -- | Section id (for hyperlinks).
+ , expItemSectionId :: String
- } -- ^ A section heading
+ -- | Section heading text.
+ , expItemSectionText :: Doc name
+ }
- | ExportDoc (Doc name) -- ^ Some documentation
+ -- | Some documentation.
+ | ExportDoc (Doc name)
- | ExportModule Module -- ^ A cross-reference to another module
+ -- | A cross-reference to another module.
+ | ExportModule Module
-- | A declaration that may have documentation, including its subordinates,
--- which may also have documentation
+-- which may also have documentation.
type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)])
@@ -218,23 +224,24 @@
-----------------------------------------------------------------------------
--- * Hyperlinking
+-- * Cross-referencing
-----------------------------------------------------------------------------
--- | An environment used to create hyper-linked syntax.
+-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
--- | An extension of 'Name' that may contain the preferred place to link to in
--- the documentation.
-data DocName = Documented Name Module | Undocumented Name deriving Eq
--- TODO: simplify to data DocName = DocName Name (Maybe Module)
-
-
--- | The 'OccName' of this name.
-docNameOcc :: DocName -> OccName
-docNameOcc = nameOccName . getName
+-- | Extends 'Name' with cross-reference information.
+data DocName
+ = Documented Name Module
+ -- ^ This thing is part of the (existing or resulting)
+ -- documentation. The 'Module' is the preferred place
+ -- in the documentation to refer to.
+ | Undocumented Name
+ -- ^ This thing is not part of the (existing or resulting)
+ -- documentation, as far as Haddock knows.
+ deriving Eq
instance NamedThing DocName where
@@ -251,8 +258,8 @@
type DocInstance name = (InstHead name, Maybe (Doc name))
--- | The head of an instance. Consists of a context, a class name and a list of
--- instance types.
+-- | 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])
@@ -299,41 +306,41 @@
">>> " ++ expression ++ "\n" ++ unlines result
-data DocMarkup id a = Markup {
- markupEmpty :: a,
- markupString :: String -> a,
- markupParagraph :: a -> a,
- markupAppend :: a -> a -> a,
- markupIdentifier :: [id] -> a,
- markupModule :: String -> a,
- markupEmphasis :: a -> a,
- markupMonospaced :: a -> a,
- markupUnorderedList :: [a] -> a,
- markupOrderedList :: [a] -> a,
- markupDefList :: [(a,a)] -> a,
- markupCodeBlock :: a -> a,
- markupURL :: String -> a,
- markupAName :: String -> a,
- markupPic :: String -> a,
- markupExample :: [Example] -> a
-}
+data DocMarkup id a = Markup
+ { markupEmpty :: a
+ , markupString :: String -> a
+ , markupParagraph :: a -> a
+ , markupAppend :: a -> a -> a
+ , markupIdentifier :: [id] -> a
+ , markupModule :: String -> a
+ , markupEmphasis :: a -> a
+ , markupMonospaced :: a -> a
+ , markupUnorderedList :: [a] -> a
+ , markupOrderedList :: [a] -> a
+ , markupDefList :: [(a,a)] -> a
+ , markupCodeBlock :: a -> a
+ , markupURL :: String -> a
+ , markupAName :: String -> a
+ , markupPic :: String -> a
+ , markupExample :: [Example] -> a
+ }
-data HaddockModInfo name = HaddockModInfo {
- hmi_description :: Maybe (Doc name),
- hmi_portability :: Maybe String,
- hmi_stability :: Maybe String,
- hmi_maintainer :: Maybe String
-}
+data HaddockModInfo name = HaddockModInfo
+ { hmi_description :: Maybe (Doc name)
+ , hmi_portability :: Maybe String
+ , hmi_stability :: Maybe String
+ , hmi_maintainer :: Maybe String
+ }
emptyHaddockModInfo :: HaddockModInfo a
-emptyHaddockModInfo = HaddockModInfo {
- hmi_description = Nothing,
- hmi_portability = Nothing,
- hmi_stability = Nothing,
- hmi_maintainer = Nothing
-}
+emptyHaddockModInfo = HaddockModInfo
+ { hmi_description = Nothing
+ , hmi_portability = Nothing
+ , hmi_stability = Nothing
+ , hmi_maintainer = Nothing
+ }
-----------------------------------------------------------------------------
@@ -344,14 +351,23 @@
{-! for DocOption derive: Binary !-}
-- | Source-level options for controlling the documentation.
data DocOption
- = OptHide -- ^ This module should not appear in the docs
+ = OptHide -- ^ This module should not appear in the docs.
| OptPrune
- | OptIgnoreExports -- ^ Pretend everything is exported
- | OptNotHome -- ^ Not the best place to get docs for things
- -- exported by this module.
+ | OptIgnoreExports -- ^ Pretend everything is exported.
+ | OptNotHome -- ^ Not the best place to get docs for things
+ -- exported by this module.
deriving (Eq, Show)
+-- | Option controlling how to qualify names
+data Qualification
+ = NoQual -- ^ Never qualify any names.
+ | FullQual -- ^ Qualify all names fully.
+ | LocalQual (Maybe Module) -- ^ Qualify all imported names fully.
+ | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix.
+ -- from modules in the same hierarchy.
+
+
-----------------------------------------------------------------------------
-- * Error handling
-----------------------------------------------------------------------------
@@ -383,7 +399,7 @@
-- Exceptions
--- | Haddock's own exception type
+-- | Haddock's own exception type.
data HaddockException = HaddockException String deriving Typeable
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Utils
@@ -74,7 +73,7 @@
import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( hPutStr, stderr )
import System.IO.Unsafe ( unsafePerformIO )
-import System.FilePath
+import qualified System.FilePath.Posix as HtmlPath
import Distribution.Verbosity
import Distribution.ReadE
@@ -179,7 +178,7 @@
moduleHtmlFile mdl =
case Map.lookup mdl html_xrefs of
Nothing -> mdl' ++ ".html"
- Just fp0 -> joinPath [fp0, mdl' ++ ".html"]
+ Just fp0 -> HtmlPath.joinPath [fp0, mdl' ++ ".html"]
where
mdl' = map (\c -> if c == '.' then '-' else c)
(moduleNameString (moduleName mdl))
@@ -204,10 +203,10 @@
synopsisFrameName = "synopsis"
-subIndexHtmlFile :: Char -> String
-subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
- where b | isAlpha a = [a]
- | otherwise = show (ord a)
+subIndexHtmlFile :: String -> String
+subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
+ where b | all isAlpha ls = ls
+ | otherwise = concatMap (show . ord) ls
-------------------------------------------------------------------------------
@@ -245,7 +244,7 @@
makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
where
escape p c | p c = [c]
- | otherwise = '-' : (show (ord c)) ++ "-"
+ | otherwise = '-' : show (ord c) ++ "-"
isLegal ':' = True
isLegal '_' = True
isLegal '.' = True
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Main
@@ -30,7 +30,7 @@
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
-import Haddock.GhcUtils
+import Haddock.GhcUtils hiding (pretty)
import Control.Monad
import Control.Exception
@@ -78,11 +78,18 @@
(inner `onException` hFlush stdout)
`catches`
[ Handler (\(code :: ExitCode) -> exitWith code)
- , Handler (\(StackOverflow) -> do
- putStrLn "stack overflow: use -g +RTS -K to increase it"
- exitFailure)
+
+ , Handler (\(ex :: AsyncException) ->
+ case ex of
+ StackOverflow -> do
+ putStrLn "stack overflow: use -g +RTS -K to increase it"
+ exitFailure
+ _ -> do
+ putStrLn ("haddock: " ++ show ex)
+ exitFailure)
+
, Handler (\(ex :: SomeException) -> do
- putStrLn ("haddock: internal Haddock or GHC error: " ++ show ex)
+ putStrLn ("haddock: internal error: " ++ show ex)
exitFailure)
]
@@ -103,9 +110,6 @@
hFlush stdout
case e of
PhaseFailed _ code -> exitWith code
-#if ! MIN_VERSION_ghc(6,13,0)
- Interrupted -> exitFailure
-#endif
_ -> do
print (e :: GhcException)
exitFailure
@@ -124,27 +128,26 @@
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
- if not (null files)
- then do
- (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+ if not (null files) then do
+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
- -- Dump an "interface file" (.haddock file), if requested.
- case optDumpInterfaceFile flags of
- Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
- Nothing -> return ()
+ -- Dump an "interface file" (.haddock file), if requested.
+ case optDumpInterfaceFile flags of
+ Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+ Nothing -> return ()
- -- Render the interfaces.
- renderStep flags packages ifaces
+ -- Render the interfaces.
+ renderStep flags packages ifaces
- else do
- when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
- throwE "No input file(s)."
+ else do
+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+ throwE "No input file(s)."
- -- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags)
+ -- Get packages supplied with --read-interface.
+ packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags)
- -- Render even though there are no input files (usually contents/index).
- renderStep flags packages []
+ -- Render even though there are no input files (usually contents/index).
+ renderStep flags packages []
readPackagesAndProcessModules :: [Flag] -> [String]
@@ -187,11 +190,13 @@
let
title = fromMaybe "" (optTitle flags)
unicode = Flag_UseUnicode `elem` flags
+ pretty = Flag_PrettyHtml `elem` flags
opt_wiki_urls = wikiUrls flags
opt_contents_url = optContentsUrl flags
opt_index_url = optIndexUrl flags
odir = outputDir flags
opt_latex_style = optLaTeXStyle flags
+ opt_qualification = qualification flags
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -210,25 +215,26 @@
libDir <- getHaddockLibDir flags
prologue <- getPrologue flags
- themes <- getThemes libDir flags >>= either bye return
+ themes <- getThemes libDir flags >>= either bye return
when (Flag_GenIndex `elem` flags) $ do
ppHtmlIndex odir title pkgStr
themes opt_contents_url sourceUrls' opt_wiki_urls
- allVisibleIfaces
+ allVisibleIfaces pretty
copyHtmlBits odir libDir themes
when (Flag_GenContents `elem` flags) $ do
ppHtmlContents odir title pkgStr
themes opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue
+ allVisibleIfaces True prologue pretty
copyHtmlBits odir libDir themes
when (Flag_Html `elem` flags) $ do
ppHtml title pkgStr visibleIfaces odir
prologue
themes sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode
+ opt_contents_url opt_index_url unicode opt_qualification
+ pretty
copyHtmlBits odir libDir themes
when (Flag_Hoogle `elem` flags) $ do
@@ -239,6 +245,7 @@
ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
libDir
+
-------------------------------------------------------------------------------
-- * Reading and dumping interface files
-------------------------------------------------------------------------------
@@ -386,12 +393,7 @@
[] -> return Nothing
[filename] -> do
str <- readFile filename
-#if ! MIN_VERSION_ghc(6,13,0)
- let f = id
-#else
- let f = flattenExtensionFlags
-#endif
- case parseParas (tokenise (f defaultDynFlags) str
+ case parseParas (tokenise defaultDynFlags str
(1,0) {- TODO: real position -}) of
Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename
Just doc -> return (Just doc)
@@ -402,24 +404,25 @@
getInTreeLibDir :: IO String
getInTreeLibDir =
- do m <- getExecDir
- case m of
- Nothing -> error "No GhcLibDir found"
+ do m <- getExecDir
+ case m of
+ Nothing -> error "No GhcLibDir found"
#ifdef NEW_GHC_LAYOUT
- Just d -> return (d ".." "lib")
+ Just d -> return (d ".." "lib")
#else
- Just d -> return (d "..")
+ Just d -> return (d "..")
#endif
getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecDir = allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0
- then return Nothing
- else do s <- peekCString buf
- return (Just (dropFileName s))
+ ret <- getModuleFileName nullPtr buf len
+ if ret == 0 then
+ return Nothing
+ else do
+ s <- peekCString buf
+ return (Just (dropFileName s))
where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.