aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorTobias Brandt <tob.brandt@gmail.com>2010-08-27 07:01:21 +0000
committerTobias Brandt <tob.brandt@gmail.com>2010-08-27 07:01:21 +0000
commit2b87648737ad5b07e30d9bb03f7c4e3953566c24 (patch)
tree36454035a50838b558720351f0cd4886e19dfeb2 /src
parent957f4ad40b1eb9931d2b2de80f4bc8e28e22b4fa (diff)
adding the option to fully qualify identifiers
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml.hs58
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs411
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs14
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs34
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs17
-rw-r--r--src/Haddock/Options.hs5
-rw-r--r--src/Haddock/Types.hs2
-rw-r--r--src/Main.hs3
8 files changed, 291 insertions, 253 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 71a96bf9..452fdfa0 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -66,11 +66,13 @@ ppHtml :: String
-> 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
-> 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
+ quali = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
@@ -88,7 +90,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
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 quali) visible_ifaces
copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
@@ -448,11 +450,11 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
-> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool
+ -> Maybe String -> Maybe String -> Bool -> Qualification
-> 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 quali iface = do
let
mdl = ifaceMod iface
mdl_str = moduleString mdl
@@ -462,30 +464,30 @@ ppHtmlModule odir doctitle themes
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 quali
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html)
- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode
+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode quali
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
- -> Interface -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do
+ -> Interface -> Bool -> Qualification -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode quali = do
let mdl = ifaceMod iface
html =
headHtml (moduleString mdl) Nothing themes +++
miniBody <<
(divModuleHeader << sectionName << moduleString mdl +++
- miniSynopsis mdl iface unicode)
+ miniSynopsis mdl iface unicode quali)
createDirectoryIfMissing True odir
writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString 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 quali
+ = ppModuleContents quali exports +++
description +++
synopsis +++
divInterface (maybe_doc_hdr +++ bdy)
@@ -505,7 +507,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
= case ifaceRnDoc iface of
Nothing -> noHtml
Just doc -> divDescription $
- sectionName << "Description" +++ docSection doc
+ sectionName << "Description" +++ docSection quali doc
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -514,7 +516,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
= divSynposis $
paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
shortDeclList (
- mapMaybe (processExport True linksInfo unicode) exports
+ mapMaybe (processExport True linksInfo unicode quali) exports
) ! (collapseSection "syn" False "" ++ collapseToggle "syn")
-- if the documentation doesn't begin with a section header, then
@@ -527,20 +529,21 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
bdy =
foldr (+++) noHtml $
- mapMaybe (processExport False linksInfo unicode) exports
+ mapMaybe (processExport False linksInfo unicode quali) 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 quali =
+ divInterface << mapMaybe (processForMiniSynopsis mdl unicode quali) 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
@@ -555,9 +558,9 @@ processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =
SigD (TypeSig (L _ n) (L _ _)) ->
Just $ ppNameMini mdl (docNameOcc n)
_ -> Nothing
-processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =
- Just $ groupTag lvl << docToHtml txt
-processForMiniSynopsis _ _ _ = Nothing
+processForMiniSynopsis _ _ quali (ExportGroup lvl _id txt) =
+ Just $ groupTag lvl << docToHtml quali txt
+processForMiniSynopsis _ _ _ _ = Nothing
ppNameMini :: Module -> OccName -> Html
@@ -574,8 +577,8 @@ ppTyClBinderWithVarsMini mdl decl =
in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName
-ppModuleContents :: [ExportItem DocName] -> Html
-ppModuleContents exports
+ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
+ppModuleContents quali exports
| null sections = noHtml
| otherwise = contentsDiv
where
@@ -591,8 +594,7 @@ ppModuleContents exports
| lev <= n = ( [], items )
| otherwise = ( html:secs, rest2 )
where
- html = linkedAnchor (groupId id0)
- << docToHtml doc +++ mk_subsections ssecs
+ html = linkedAnchor id0 << docToHtml doc +++ mk_subsections ssecs
(ssecs, rest1) = process lev rest
(secs, rest2) = process n rest1
process n (_ : rest) = process n rest
@@ -615,7 +617,7 @@ numberSectionHeadings exports = go 1 exports
processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> Maybe Html
processExport summary _ _ (ExportGroup lev id0 doc)
- = nothingIf summary $ groupHeading lev id0 << docToHtml 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 [])
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 7031a9ae..747e8f38 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,38 +39,40 @@ import Outputable ( ppr, showSDoc, Outputable )
-- 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 quali = case decl of
+ TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode quali
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 quali
| 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 quali
+ | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode quali
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode quali
+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode quali
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode quali
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 quali =
ppTypeOrFunSig summary links loc docname typ doc
- (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode
+ (ppTypeSig summary occname typ unicode quali, ppBinder False occname, dcolon unicode)
+ unicode quali
where
occname = docNameOcc 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 quali
| summary = pref1
- | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection doc
+ | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection quali doc
| otherwise = topDeclElem links loc docname pref2 +++
- subArguments (do_args 0 sep typ) +++ maybeDocSection doc
+ subArguments quali (do_args 0 sep typ) +++ maybeDocSection quali doc
where
argDoc n = Map.lookup n argDocs
@@ -79,12 +81,12 @@ ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep)
do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
= (leader <+>
hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
- ppLContextNoArrow lctxt unicode,
+ ppLContextNoArrow lctxt unicode quali,
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 quali,
Nothing, [])
: do_largs n (darrow unicode) ltype
-- if we're not showing any 'forall' or class constraints or
@@ -92,10 +94,10 @@ ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep)
| otherwise
= do_largs n leader ltype
do_args n leader (HsFunTy lt r)
- = (leader <+> ppLFunLhType unicode lt, argDoc n, [])
+ = (leader <+> ppLFunLhType unicode quali lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
- = (leader <+> ppType unicode t, argDoc n, []) : []
+ = (leader <+> ppType unicode quali t, argDoc n, []) : []
ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
@@ -106,26 +108,29 @@ tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
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 quali
+ = ppFunSig summary links loc doc name typ unicode quali
+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 quali
= ppTypeOrFunSig summary links loc name (unLoc ltype) doc
- (full, hdr, spaceHtml +++ equals) unicode
+ (full, hdr, spaceHtml +++ equals) unicode quali
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
- full = hdr <+> equals <+> ppLType unicode ltype
+ full = hdr <+> equals <+> ppLType unicode quali ltype
occ = docNameOcc name
-ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+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 quali =
+ ppBinder summary nm <+> dcolon unicode <+> ppType unicode quali ty
ppTyName :: Name -> Html
@@ -159,18 +164,18 @@ ppTyFamHeader summary associated decl unicode =
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 quali
| summary = ppTyFamHeader True associated decl unicode
- | otherwise = header_ +++ maybeDocSection mbDoc +++ instancesBit
+ | otherwise = header_ +++ maybeDocSection quali 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 quali
-- TODO: get the instances
instances = []
@@ -199,22 +204,23 @@ ppDataInst = undefined
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 quali
- | summary = ppTyInstHeader True associated decl unicode
- | otherwise = header_ +++ maybeDocSection mbDoc
+ | summary = ppTyInstHeader True associated decl unicode quali
+ | otherwise = header_ +++ maybeDocSection quali 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 quali)
-ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
-ppTyInstHeader _ _ decl unicode =
+ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyInstHeader _ _ decl unicode quali =
keyword "type instance" <+>
- ppAppNameTypes (tcdName decl) typeArgs unicode
+ ppAppNameTypes (tcdName decl) typeArgs unicode quali
where
typeArgs = map unLoc . fromJust . tcdTyPats $ decl
@@ -224,11 +230,12 @@ ppTyInstHeader _ _ decl unicode =
--------------------------------------------------------------------------------
-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 quali =
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 quali
+ TySynonym {} -> ppTySyn summ links loc doc decl unicode quali
_ -> error "declaration type not supported by ppAssocType"
@@ -249,8 +256,9 @@ ppTyClBinderWithVars summ decl =
-- | 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 quali =
+ ppTypeApp n ts (ppDocName quali) (ppParendType unicode quali)
-- | Print an application of a DocName and a list of Names
@@ -276,36 +284,39 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-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 quali = pp_hs_context (map unLoc cxt) unicode quali
-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 quali = pp_hs_context cxt unicode quali
+ <+> darrow unicode
-ppContext :: HsContext DocName -> Bool -> Html
-ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
+ppContext :: HsContext DocName -> Bool -> Qualification -> Html
+ppContext cxt unicode quali = ppContextNoLocs (map unLoc cxt) unicode quali
-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 quali = ppPred unicode quali p
+pp_hs_context cxt unicode quali = parenList (map (ppPred unicode quali) 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 quali (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode quali
+ppPred unicode quali (HsEqualP t1 t2) = ppLType unicode quali t1 <+> toHtml "~"
+ <+> ppLType unicode quali t2
+ppPred unicode quali (HsIParam (IPName n) t)
+ = toHtml "?" +++ ppDocName quali n <+> dcolon unicode <+> ppLType unicode quali t
-------------------------------------------------------------------------------
@@ -315,83 +326,87 @@ ppPred unicode (HsIParam (IPName n) t)
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 quali =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else noHtml)
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode quali else noHtml)
<+> ppAppDocNameNames summ n (tyvarNames $ tvs)
- <+> ppFds fds unicode
+ <+> ppFds fds unicode quali
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html
-ppFds fds unicode =
+ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
+ppFds fds unicode quali =
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 quali) vars1) <+> arrow unicode <+>
+ hsep (map (ppDocName quali) 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 quali =
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 quali | 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 quali
| 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 quali
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 quali
+ | summary = ppShortClassDecl summary links decl loc subdocs unicode quali
+ | otherwise = classheader +++ maybeDocSection quali 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 quali)
+ | otherwise = topDeclElem links loc nm (hdr unicode quali <+> 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 quali
| 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 quali
| L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
, let doc = lookupAnySubdoc n subdocs ]
- instancesBit = ppInstances instances nm unicode
+ instancesBit = ppInstances instances nm unicode quali
-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 quali
+ = subInstances quali 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 quali
+ instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode quali
+ <+> ppAppNameTypes n ts unicode quali
lookupAnySubdoc :: (Eq name1) =>
@@ -407,13 +422,14 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-- 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 quali
- | [] <- cons = dataHeader
+ | [] <- cons = dataHeader
| [lcon] <- cons, ResTyH98 <- resTy,
- (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode
+ (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode quali
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
| ResTyH98 <- resTy = dataHeader
@@ -423,9 +439,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode
+++ 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 quali
+ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode quali
+ doGADTConstr con = ppShortConstr summary (unLoc con) unicode quali
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
@@ -433,18 +449,19 @@ ppShortDataDecl summary _links _loc dataDecl unicode
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 quali
- | summary = ppShortDataDecl summary links loc dataDecl unicode
- | otherwise = header_ +++ maybeDocSection mbDoc +++ constrBit +++ instancesBit
+ | summary = ppShortDataDecl summary links loc dataDecl unicode quali
+ | otherwise = header_ +++ maybeDocSection quali 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 quali
<+> whereBit)
whereBit
@@ -453,33 +470,34 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
ResTyGADT _ -> keyword "where"
_ -> noHtml
- constrBit = subConstructors
- (map (ppSideBySideConstr subdocs unicode) cons)
+ constrBit = subConstructors quali
+ (map (ppSideBySideConstr subdocs unicode quali) cons)
- instancesBit = ppInstances instances docname unicode
+ instancesBit = ppInstances instances docname unicode quali
-ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
-ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot
+ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html
+ppShortConstr summary con unicode quali = cHead <+> cBody <+> cFoot
where
- (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode
+ (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode quali
-- 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 quali = 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 quali +++ hsep (ppBinder summary occ
+ : map (ppLParendType unicode quali) args), noHtml, noHtml)
RecCon fields ->
- (header_ unicode +++ ppBinder summary occ <+> char '{',
+ (header_ unicode quali +++ ppBinder summary occ <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
- (header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2],
+ (header_ unicode quali +++ hsep [ppLParendType unicode quali arg1,
+ ppBinder summary occ, ppLParendType unicode quali arg2],
noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
@@ -491,16 +509,16 @@ ppShortConstrParts summary con unicode = case con_res con of
-- (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 quali <+> char '{',
doRecordFields fields,
- char '}' <+> arrow unicode <+> ppLType unicode resTy)
+ char '}' <+> arrow unicode <+> ppLType unicode quali 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 quali) 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 quali,
+ ppLType unicode quali (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall tyVars context
occ = docNameOcc . unLoc . con_name $ con
@@ -514,35 +532,39 @@ ppShortConstrParts summary con unicode = case con_res con of
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
#if __GLASGOW_HASKELL__ == 612
-ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html
+ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool
+ -> Qualification -> Html
#else
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
+ -> Qualification -> Html
#endif
-ppConstrHdr forall tvs ctxt unicode
+ppConstrHdr forall tvs ctxt unicode quali
= (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 quali
+ <+> 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 quali (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 quali +++ ppBinder False occ)
+ : map (ppLParendType unicode quali) args)
- RecCon _ -> header_ unicode +++ ppBinder False occ
+ RecCon _ -> header_ unicode quali +++ ppBinder False occ
InfixCon arg1 arg2 ->
- hsep [header_ unicode+++ppLParendType unicode arg1,
+ hsep [header_ unicode quali +++ ppLParendType unicode quali arg1,
ppBinder False occ,
- ppLParendType unicode arg2]
+ ppLParendType unicode quali arg2]
ResTyGADT resTy -> case con_details con of
-- prefix & infix could also use hsConDeclArgTys if it seemed to
@@ -555,13 +577,13 @@ ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart)
RecCon fields -> [doRecordFields fields]
_ -> []
- doRecordFields fields = subFields
- (map (ppSideBySideField subdocs unicode) fields)
+ doRecordFields fields = subFields quali
+ (map (ppSideBySideField subdocs unicode quali) 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 quali,
+ ppLType unicode quali (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall tyVars context
occ = docNameOcc . unLoc . con_name $ con
@@ -576,9 +598,10 @@ ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart)
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 quali (ConDeclField (L _ name) ltype _) =
+ (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode quali ltype,
mbDoc,
[])
where
@@ -586,22 +609,22 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
mbDoc = join $ fmap fst $ lookup name subdocs
-ppShortField :: Bool -> Bool -> ConDeclField DocName -> Html
-ppShortField summary unicode (ConDeclField (L _ name) ltype _)
+ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
+ppShortField summary unicode quali (ConDeclField (L _ name) ltype _)
= ppBinder summary (docNameOcc name)
- <+> dcolon unicode <+> ppLType unicode ltype
+ <+> dcolon unicode <+> ppLType unicode quali 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 quali
| 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 quali <+>
-- T a b c ..., or a :+: b
ppTyClBinderWithVars summary decl
@@ -648,16 +671,17 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
| 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 quali y = ppType unicode quali (unLoc y)
+ppLParendType unicode quali y = ppParendType unicode quali (unLoc y)
+ppLFunLhType unicode quali y = ppFunLhType unicode quali (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 quali ty = ppr_mono_ty pREC_TOP ty unicode quali
+ppParendType unicode quali ty = ppr_mono_ty pREC_CON ty unicode quali
+ppFunLhType unicode quali ty = ppr_mono_ty pREC_FUN ty unicode quali
-- Drop top-level for-all type variables in user style
@@ -668,65 +692,66 @@ 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 quali
+ | show_forall = forall_part <+> ppLContext cxt unicode quali
+ | otherwise = ppLContext cxt unicode quali
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 quali = ppr_mono_ty ctxt_prec (unLoc ty) unicode quali
-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 quali
= maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
-
-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"
+ hsep [ppForAll expl tvs ctxt unicode quali, ppr_mono_lty pREC_TOP ty unicode quali]
+
+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"
#if __GLASGOW_HASKELL__ == 612
-ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
#else
-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
#endif
-ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
+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 quali
= 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 quali, ppr_mono_lty pREC_CON arg_ty unicode quali]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode quali
= 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 quali <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode quali
where
- ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op
+ ppr_op = if not (isSymOcc occName) then quote (ppLDocName quali op) else ppLDocName quali op
occName = docNameOcc . unLoc $ op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode quali
-- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode
+ = ppr_mono_lty ctxt_prec ty unicode quali
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
- = ppr_mono_lty ctxt_prec ty unicode
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode quali
+ = ppr_mono_lty ctxt_prec ty unicode quali
-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 quali
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode quali
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode quali
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
index be9ae876..fb03b123 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -75,9 +75,9 @@ parHtmlMarkup ppId isTyCon = Markup {
-- If the doc is a single paragraph, don't surround it with <P> (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 quali = markup fmt . cleanup
+ where fmt = parHtmlMarkup (ppDocName quali) (isTyConName . getName)
origDocToHtml :: Doc Name -> Html
@@ -97,12 +97,12 @@ docElement el content_ =
else el ! [theclass "doc"] << content_
-docSection :: Doc DocName -> Html
-docSection = (docElement thediv <<) . docToHtml
+docSection :: Qualification -> Doc DocName -> Html
+docSection quali = (docElement thediv <<) . (docToHtml quali)
-maybeDocSection :: Maybe (Doc DocName) -> Html
-maybeDocSection = maybe noHtml docSection
+maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
+maybeDocSection quali = maybe noHtml (docSection quali)
cleanup :: Doc a -> Doc a
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 295af305..7277a683 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -112,25 +112,25 @@ divSubDecls cssClass captionName = maybe noHtml wrap
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 quali 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 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 quali 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 quali) mdoc)
: map (cell . (td <<)) subs
@@ -139,27 +139,27 @@ subBlock [] = Nothing
subBlock hs = Just $ toHtml hs
-subArguments :: [SubDecl] -> Html
-subArguments = divSubDecls "arguments" "Arguments" . subTable
+subArguments :: Qualification -> [SubDecl] -> Html
+subArguments quali = divSubDecls "arguments" "Arguments" . (subTable quali)
subAssociatedTypes :: [Html] -> Html
subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
-subConstructors :: [SubDecl] -> Html
-subConstructors = divSubDecls "constructors" "Constructors" . subTable
+subConstructors :: Qualification -> [SubDecl] -> Html
+subConstructors quali = divSubDecls "constructors" "Constructors" . (subTable quali)
-subFields :: [SubDecl] -> Html
-subFields = divSubDecls "fields" "Fields" . subDlist
+subFields :: Qualification -> [SubDecl] -> Html
+subFields quali = divSubDecls "fields" "Fields" . (subDlist quali)
-subInstances :: String -> [SubDecl] -> Html
-subInstances nm = maybe noHtml wrap . instTable
+subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances quali nm = maybe noHtml wrap . instTable
where
wrap = (subSection <<) . (subCaption +++)
- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . (subTable quali)
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
index 068fc0f7..6df32fc4 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -38,16 +38,21 @@ ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc
-ppLDocName :: Located DocName -> Html
-ppLDocName (L _ d) = ppDocName d
+ppLDocName :: Qualification -> Located DocName -> Html
+ppLDocName quali (L _ d) = ppDocName quali d
-ppDocName :: DocName -> Html
-ppDocName (Documented name mdl) =
- linkIdOcc mdl (Just occName) << ppOccName occName
+ppDocName :: Qualification -> DocName -> Html
+ppDocName quali (Documented name mdl) =
+ linkIdOcc mdl (Just occName) << theName
where occName = nameOccName name
-ppDocName (Undocumented name) = toHtml (getOccString name)
+ theName = case quali of
+ NoQuali -> ppName name
+ FullQuali -> ppQualName mdl name
+ppDocName _ (Undocumented name) = ppName name
+ppQualName :: Module -> Name -> Html
+ppQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
ppName :: Name -> Html
ppName name = toHtml (getOccString name)
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 4df61fe3..6e590201 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -24,6 +24,7 @@ module Haddock.Options (
wikiUrls,
optDumpInterfaceFile,
optLaTeXStyle,
+ optQualification,
verbosity,
ghcFlags,
readIfaceArgs
@@ -74,6 +75,7 @@ data Flag
| Flag_NoWarnings
| Flag_UseUnicode
| Flag_NoTmpCompDir
+ | Flag_Qualification String
deriving (Eq)
@@ -120,6 +122,8 @@ options backwardsCompat =
"file containing prologue text",
Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
"page heading",
+ Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUALI")
+ "qualification of names, either \n'none' (default) or 'full'",
Option ['d'] ["debug"] (NoArg Flag_Debug)
"extra debugging output",
Option ['?'] ["help"] (NoArg Flag_Help)
@@ -217,7 +221,6 @@ optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
-
verbosity :: [Flag] -> Verbosity
verbosity flags =
case [ str | Flag_Verbosity str <- flags ] of
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index b0ac6cac..0f868555 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -354,6 +354,8 @@ data DocOption
-- exported by this module.
deriving (Eq, Show)
+-- | Option controlling how to qualify names
+data Qualification = NoQuali | FullQuali
-----------------------------------------------------------------------------
-- * Error handling
diff --git a/src/Main.hs b/src/Main.hs
index 8e3ba3e7..8cd6f169 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -192,6 +192,7 @@ render flags ifaces installedIfaces srcMap = do
opt_index_url = optIndexUrl flags
odir = outputDir flags
opt_latex_style = optLaTeXStyle flags
+ opt_qualification = optQualification flags
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -228,7 +229,7 @@ render flags ifaces installedIfaces srcMap = 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
copyHtmlBits odir libDir themes
when (Flag_Hoogle `elem` flags) $ do