aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Html.hs
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2008-02-09 22:33:24 +0000
committerDavid Waern <david.waern@gmail.com>2008-02-09 22:33:24 +0000
commit953a67e86fedb849eed06154fb59de2091bb148f (patch)
tree49ad6da30d4062f6e52d46737f153af7fe2262b0 /src/Haddock/Backends/Html.hs
parent95352ca3832192a94697988c5979e258dc85003a (diff)
Change the representation of DocNames
Ross Paterson reported a bug where links would point to the defining module instead of the "best" module for an identifier (e.g Int pointing to GHC.Base instead of Data.Int). This patch fixes this problem by refactoring the way renamed names are represented. Instead of representing them by: > data DocName = Link Name | NoLink Name they are now represented as such: > data DocName = Documented Name Module | Undocumented Name and the the link-env looks like this: > type LinkEnv = Map Name Module There are several reasons for this. First of all, the bug was caused by changing the module part of Names during the renaming process, without changing the Unique field. This caused names to be overwritten during the loading of .haddock files (which caches names using the NameCache of the GHC session). So we might create new Uniques during renaming to fix this (but I'm not sure that would be problem-free). Instead, we just keep the Name and add the Module where the name is best documented, since it can be useful to keep the original Name around (for e.g. source-code location info and for users of the Haddock API). Also, the names Link/NoLink don't really make sense, since wether to use links or not is entirely up to the users of DocName. In the process of following this change into H.Backends.Html I removed the assumption that binder names are Undocumented (which was just an unnecessary assumption, the OccName is the only thing needed to render these). This will probably make it possible to get rid of the renamer and replace it with a traversal from SYB or Uniplate. Since DocName has changed, InterfaceFile has changed so this patch also increments the file-format version. No backwards-compatibility is implemented.
Diffstat (limited to 'src/Haddock/Backends/Html.hs')
-rw-r--r--src/Haddock/Backends/Html.hs106
1 files changed, 56 insertions, 50 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index cd35e9f6..45bffdcd 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -14,6 +14,7 @@ module Haddock.Backends.Html (
import Prelude hiding (div)
+import Haddock.DocName
import Haddock.Backends.DevHelp
import Haddock.Backends.HH
import Haddock.Backends.HH2
@@ -660,7 +661,7 @@ doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d
where
doDecl (TyClD d) = doTyClD d
doDecl (SigD (TypeSig (L _ n) (L _ t))) =
- ppFunSig summary links loc mbDoc (getName n) t
+ ppFunSig summary links loc mbDoc (docNameOrig n) t
doDecl (ForD d) = ppFor summary links loc mbDoc d
doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0
@@ -672,7 +673,8 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
Name -> HsType DocName -> HtmlTable
ppFunSig summary links loc mbDoc name typ =
ppTypeOrFunSig summary links loc name typ mbDoc
- (ppTypeSig summary name typ, ppBinder False name, dcolon)
+ (ppTypeSig summary (nameOccName name) typ,
+ ppBinder False (nameOccName name), dcolon)
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> Name -> HsType DocName ->
@@ -721,10 +723,10 @@ ppTypeOrFunSig summary links loc name typ doc (pref1, pref2, sep)
ppTyVars tvs = ppTyNames (tyvarNames tvs)
tyvarNames = map f
- where f x = let NoLink n = hsTyVarName (unLoc x) in n
+ where f x = docNameOrig . hsTyVarName . unLoc $ x
ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _)
- = ppFunSig summary links loc mbDoc (getName name) typ
+ = ppFunSig summary links loc mbDoc (docNameOrig name) typ
ppFor _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
@@ -732,12 +734,13 @@ ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype)
= ppTypeOrFunSig summary links loc n (unLoc ltype) mbDoc
(full, hdr, spaceHtml +++ equals)
where
- hdr = hsep ([keyword "type", ppBinder summary n] ++ ppTyVars ltyvars)
+ hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
full = hdr <+> equals <+> ppLType ltype
- NoLink n = name
+ n = docNameOrig name
+ occ = docNameOcc name
-ppTypeSig :: Bool -> Name -> HsType DocName -> Html
+ppTypeSig :: Bool -> OccName -> HsType DocName -> Html
ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty
@@ -762,7 +765,7 @@ ppAppNameTypes n ts = ppTypeApp n ts ppDocName ppParendType
-- | Print an application of a DocName and a list of Names
ppDataClassHead :: Bool -> DocName -> [Name] -> Html
ppDataClassHead summ n ns =
- ppTypeApp n ns (ppBinder summ . getName) ppTyName
+ ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName
-- | General printing of type applications
@@ -771,7 +774,7 @@ ppTypeApp n ts@(t1:t2:rest) ppDN ppT
| operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
- operator = isNameSym . getName $ n
+ operator = isNameSym . docNameOrig $ n
opApp = ppT t1 <+> ppDN n <+> ppT t2
ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
@@ -835,12 +838,12 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
vanillaTable <<
aboves ([ ppAT summary at | L _ at <- ats ] ++
[ ppFunSig summary links loc mbDoc n typ
- | L _ (TypeSig (L _ (NoLink n)) (L _ typ)) <- sigs
- , let mbDoc = Map.lookup n docMap ])
+ | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs
+ , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ])
)
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds
- NoLink nm = unLoc lname
+ nm = docNameOrig . unLoc $ lname
ppAT summary at = case at of
TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)
@@ -863,7 +866,7 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
| null lsigs = topDeclBox links loc nm hdr
| otherwise = topDeclBox links loc nm (hdr <+> keyword "where")
- NoLink nm = unLoc lname
+ nm = docNameOrig . unLoc $ lname
ctxt = unLoc lctxt
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
@@ -877,9 +880,9 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
| otherwise =
s8 </> methHdr </>
tda [theclass "body"] << vanillaTable << (
- abovesSep s8 [ ppFunSig summary links loc mbDoc (orig n) typ
- | L _ (TypeSig n (L _ typ)) <- lsigs
- , let mbDoc = Map.lookup (orig n) docMap ]
+ abovesSep s8 [ ppFunSig summary links loc mbDoc (docNameOrig n) typ
+ | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
+ , let mbDoc = Map.lookup (docNameOrig n) docMap ]
)
instId = collapseId nm
@@ -901,9 +904,6 @@ ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts
-- -----------------------------------------------------------------------------
-- Data & newtype declarations
-orig (L _ (NoLink name)) = name
-orig _ = error "orig"
-
-- TODO: print contexts
ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan ->
@@ -937,7 +937,7 @@ ppShortDataDecl summary links loc mbDoc dataDecl
doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con))
doGADTConstr con = declBox (ppShortConstr summary (unLoc con))
- name = orig (tcdLName dataDecl)
+ name = docNameOrig . unLoc . tcdLName $ dataDecl
context = unLoc (tcdCtxt dataDecl)
newOrData = tcdND dataDecl
tyVars = tyvarNames (tcdTyVars dataDecl)
@@ -962,7 +962,7 @@ ppDataDecl summary links instances x loc mbDoc dataDecl
where
- name = orig (tcdLName dataDecl)
+ name = docNameOrig . unLoc . tcdLName $ dataDecl
context = unLoc (tcdCtxt dataDecl)
newOrData = tcdND dataDecl
tyVars = tyvarNames (tcdTyVars dataDecl)
@@ -1019,11 +1019,11 @@ ppShortConstr :: Bool -> ConDecl DocName -> Html
ppShortConstr summary con = case con_res con of
ResTyH98 -> case con_details con of
- PrefixCon args -> header +++ hsep (ppBinder summary name : map ppLType args)
- RecCon fields -> header +++ ppBinder summary name <+>
+ PrefixCon args -> header +++ hsep (ppBinder summary occ : map ppLType args)
+ RecCon fields -> header +++ ppBinder summary occ <+>
braces (vanillaTable << aboves (map (ppShortField summary) fields))
InfixCon arg1 arg2 -> header +++
- hsep [ppLType arg1, ppBinder summary name, ppLType arg2]
+ hsep [ppLType arg1, ppBinder summary occ, ppLType arg2]
ResTyGADT resTy -> case con_details con of
PrefixCon args -> doGADTCon args resTy
@@ -1031,12 +1031,12 @@ ppShortConstr summary con = case con_res con of
InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
where
- doGADTCon args resTy = ppBinder summary name <+> dcolon <+> hsep [
+ doGADTCon args resTy = ppBinder summary occ <+> dcolon <+> hsep [
ppForAll forall ltvs lcontext,
ppLType (foldr mkFunTy resTy args) ]
header = ppConstrHdr forall tyVars context
- name = orig (con_name con)
+ occ = docNameOcc . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames ltvs
lcontext = con_cxt con
@@ -1060,17 +1060,17 @@ ppSideBySideConstr (L _ con) = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- argBox (hsep ((header +++ ppBinder False name) : map ppLType args))
+ argBox (hsep ((header +++ ppBinder False occ) : map ppLType args))
<-> maybeRDocBox mbLDoc
RecCon fields ->
- argBox (header +++ ppBinder False name) <->
+ argBox (header +++ ppBinder False occ) <->
maybeRDocBox mbLDoc </>
(tda [theclass "body"] << spacedTable1 <<
aboves (map ppSideBySideField fields))
InfixCon arg1 arg2 ->
- argBox (hsep [header+++ppLType arg1, ppBinder False name, ppLType arg2])
+ argBox (hsep [header+++ppLType arg1, ppBinder False occ, ppLType arg2])
<-> maybeRDocBox mbLDoc
ResTyGADT resTy -> case con_details con of
@@ -1079,14 +1079,14 @@ ppSideBySideConstr (L _ con) = case con_res con of
InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
where
- doGADTCon args resTy = argBox (ppBinder False name <+> dcolon <+> hsep [
+ doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon <+> hsep [
ppForAll forall ltvs (con_cxt con),
ppLType (foldr mkFunTy resTy args) ]
) <-> maybeRDocBox mbLDoc
header = ppConstrHdr forall tyVars context
- name = orig (con_name con)
+ occ = docNameOcc . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
@@ -1095,8 +1095,8 @@ ppSideBySideConstr (L _ con) = case con_res con of
mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: ConDeclField DocName -> HtmlTable
-ppSideBySideField (ConDeclField lname ltype mbLDoc) =
- argBox (ppBinder False (orig lname)
+ppSideBySideField (ConDeclField (L _ name) ltype mbLDoc) =
+ argBox (ppBinder False (docNameOcc name)
<+> dcolon <+> ppLType ltype) <->
maybeRDocBox mbLDoc
@@ -1128,9 +1128,9 @@ ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
-}
ppShortField :: Bool -> ConDeclField DocName -> HtmlTable
-ppShortField summary (ConDeclField lname ltype _)
+ppShortField summary (ConDeclField (L _ name) ltype _)
= tda [theclass "recfield"] << (
- ppBinder summary (orig lname)
+ ppBinder summary (docNameOcc name)
<+> dcolon <+> ppLType ltype
)
@@ -1272,8 +1272,8 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)
= maybeParen ctxt_prec pREC_OP $
ppr_mono_lty pREC_OP ty1 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2
where
- ppr_op = if not (isNameSym name) then quote (ppLDocName op) else ppLDocName op
- name = getName . unLoc $ op
+ ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op
+ occName = docNameOcc . unLoc $ op
ppr_mono_ty ctxt_prec (HsParTy ty)
= parens (ppr_mono_lty pREC_TOP ty)
@@ -1300,28 +1300,34 @@ ppRdrName = ppOccName . rdrNameOcc
ppLDocName (L _ d) = ppDocName d
ppDocName :: DocName -> Html
-ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name
-ppDocName (NoLink name) = toHtml (getOccString name)
+ppDocName (Documented name mod) =
+ linkIdOcc mod (Just occName) << ppOccName occName
+ where occName = nameOccName name
+ppDocName (Undocumented name) = toHtml (getOccString name)
-linkTarget :: Name -> Html
-linkTarget name = namedAnchor (anchorNameStr name) << toHtml ""
+linkTarget :: OccName -> Html
+linkTarget n = namedAnchor (anchorNameStr n) << toHtml ""
ppName :: Name -> Html
ppName name = toHtml (getOccString name)
-ppBinder :: Bool -> Name -> Html
+ppBinder :: Bool -> OccName -> Html
-- The Bool indicates whether we are generating the summary, in which case
-- the binder will be a link to the full definition.
-ppBinder True nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm
-ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm
+ppBinder True n = linkedAnchor (anchorNameStr n) << ppBinder' n
+ppBinder False n = linkTarget n +++ bold << ppBinder' n
+
+ppBinder' :: OccName -> Html
+ppBinder' n
+ | isSymOcc n = parens $ toHtml (occNameString n)
+ | otherwise = toHtml (occNameString n)
+
+
+linkId mod mbName = linkIdOcc mod (fmap nameOccName mbName)
-ppBinder' :: Name -> Html
-ppBinder' name
- | isNameVarSym name = parens $ toHtml (getOccString name)
- | otherwise = toHtml (getOccString name)
-linkId :: Module -> Maybe Name -> Html -> Html
-linkId mod mbName = anchor ! [href hr]
+linkIdOcc :: Module -> Maybe OccName -> Html -> Html
+linkIdOcc mod mbName = anchor ! [href hr]
where
hr = case mbName of
Nothing -> moduleHtmlFile mod