aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/DevHelp.hs4
-rw-r--r--src/Haddock/Backends/Html.hs106
-rw-r--r--src/Haddock/DocName.hs50
-rw-r--r--src/Haddock/GHC/Utils.hs4
-rw-r--r--src/Haddock/Interface.hs19
-rw-r--r--src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--src/Haddock/Interface/Rename.hs13
-rw-r--r--src/Haddock/InterfaceFile.hs23
-rw-r--r--src/Haddock/ModuleTree.hs2
-rw-r--r--src/Haddock/Types.hs21
-rw-r--r--src/Haddock/Utils.hs11
-rw-r--r--src/Main.hs2
12 files changed, 141 insertions, 116 deletions
diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs
index 85eb6399..3ba7baf3 100644
--- a/src/Haddock/Backends/DevHelp.hs
+++ b/src/Haddock/Backends/DevHelp.hs
@@ -12,7 +12,7 @@ import Haddock.Utils
import Module ( moduleName, moduleNameString, Module, mkModule, mkModuleName )
import PackageConfig ( stringToPackageId )
-import Name ( Name, nameModule, getOccString )
+import Name ( Name, nameModule, getOccString, nameOccName )
import Data.Maybe ( fromMaybe )
import qualified Data.Map as Map
@@ -77,5 +77,5 @@ ppDevHelpFile odir doctitle maybe_package modules = do
ppReference :: Name -> [Module] -> Doc
ppReference name [] = empty
ppReference name (mod:refs) =
- text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$
+ text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod (nameOccName name))<>text"\"/>" $$
ppReference name refs
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
diff --git a/src/Haddock/DocName.hs b/src/Haddock/DocName.hs
new file mode 100644
index 00000000..bb3cf711
--- /dev/null
+++ b/src/Haddock/DocName.hs
@@ -0,0 +1,50 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.DocName where
+
+
+import Haddock.GHC.Utils
+
+import GHC
+import OccName
+import Name
+import Binary
+import Outputable
+
+
+data DocName = Documented Name Module | Undocumented Name
+
+
+docNameOcc :: DocName -> OccName
+docNameOcc = nameOccName . docNameOrig
+
+
+docNameOrig :: DocName -> Name
+docNameOrig (Documented name _) = name
+docNameOrig (Undocumented name) = name
+
+
+instance Binary DocName where
+ put_ bh (Documented name mod) = do
+ putByte bh 0
+ put_ bh name
+ put_ bh mod
+ put_ bh (Undocumented name) = do
+ putByte bh 1
+ put_ bh name
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ name <- get bh
+ mod <- get bh
+ return (Documented name mod)
+ 1 -> do
+ name <- get bh
+ return (Undocumented name)
diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs
index cfe0a83b..21c34fc5 100644
--- a/src/Haddock/GHC/Utils.hs
+++ b/src/Haddock/GHC/Utils.hs
@@ -61,9 +61,7 @@ instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where
-- misc
-isNameSym n = isNameVarSym n || isNameConSym n
-isNameVarSym = isLexVarSym . occNameFS . nameOccName
-isNameConSym = isLexConSym . occNameFS . nameOccName
+isNameSym = isSymOcc . nameOccName
getMainDeclBinder :: HsDecl name -> Maybe name
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 5f40422e..51d8de2c 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -14,6 +14,7 @@ module Haddock.Interface (
) where
+import Haddock.DocName
import Haddock.Interface.Create
import Haddock.Interface.AttachInstances
import Haddock.Interface.Rename
@@ -74,17 +75,15 @@ createInterfaces' modules flags = do
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks modules = foldl upd Map.empty (reverse modules)
+buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
where
- upd old_env mod
- | OptHide `elem` ifaceOptions mod = old_env
- | OptNotHome `elem` ifaceOptions mod =
+ upd old_env iface
+ | OptHide `elem` ifaceOptions iface = old_env
+ | OptNotHome `elem` ifaceOptions iface =
foldl' keep_old old_env exported_names
| otherwise = foldl' keep_new old_env exported_names
where
- exported_names = ifaceVisibleExports mod
- modName = ifaceMod mod
-
- keep_old env n = Map.insertWith (\new old -> old) n
- (nameSetMod n modName) env
- keep_new env n = Map.insert n (nameSetMod n modName) env
+ exported_names = ifaceVisibleExports iface
+ mod = ifaceMod iface
+ keep_old env n = Map.insertWith (\new old -> old) n mod env
+ keep_new env n = Map.insert n mod env
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index d43213c8..e3acc6cf 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -133,7 +133,7 @@ toHsType t = case t of
TyConApp tc ts -> case ts of
t1:t2:rest
- | isNameConSym . tyConName $ tc ->
+ | isSymOcc . nameOccName . tyConName $ tc ->
app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest
_ -> app (tycon tc) ts
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 947c3b29..11a0a14c 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -8,6 +8,7 @@
module Haddock.Interface.Rename (renameInterface) where
+import Haddock.DocName
import Haddock.Types
import Haddock.GHC.Utils
@@ -35,7 +36,7 @@ renameInterface renamingEnv mod =
-- is mapped to itself, and everything else comes from the global renaming
-- env
let localEnv = foldl fn renamingEnv (ifaceVisibleExports mod)
- where fn env name = Map.insert name (nameSetMod name (ifaceMod mod)) env
+ where fn env name = Map.insert name (ifaceMod mod) env
docs = Map.toList (ifaceDocMap mod)
renameMapElem (k,d) = do d' <- renameDoc d; return (k, d')
@@ -119,8 +120,8 @@ runRnFM :: LinkEnv -> RnM a -> (a,[Name])
runRnFM env rn = unRn rn lkp
where
lkp n = case Map.lookup n env of
- Nothing -> (False, NoLink n)
- Just q -> (True, Link q)
+ Nothing -> (False, Undocumented n)
+ Just mod -> (True, Documented n mod)
--------------------------------------------------------------------------------
@@ -128,8 +129,8 @@ runRnFM env rn = unRn rn lkp
--------------------------------------------------------------------------------
-keep n = NoLink n
-keepL (L loc n) = L loc (NoLink n)
+keep n = Undocumented n
+keepL (L loc n) = L loc (Undocumented n)
rename = lookupRn id
@@ -162,7 +163,7 @@ renameDoc doc = case doc of
lkp <- getLookupRn
case [ n | (True, n) <- map lkp ids ] of
ids'@(_:_) -> return (DocIdentifier ids')
- [] -> return (DocIdentifier (map NoLink ids))
+ [] -> return (DocIdentifier (map Undocumented ids))
DocModule str -> return (DocModule str)
DocEmphasis doc -> do
doc' <- renameDoc doc
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index fe383336..680e71b7 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -12,6 +12,7 @@ module Haddock.InterfaceFile (
) where
+import Haddock.DocName
import Haddock.Types
import Haddock.Exception
@@ -45,7 +46,7 @@ data InterfaceFile = InterfaceFile {
binaryInterfaceMagic = 0xD0Cface :: Word32
-binaryInterfaceVersion = 0 :: Word16
+binaryInterfaceVersion = 1 :: Word16
initBinMemSize = (1024*1024) :: Int
@@ -244,26 +245,6 @@ instance Binary InstalledInterface where
return (InstalledInterface mod info (Map.fromList docMap) exps visExps)
-{-* Generated by DrIFT : Look, but Don't Touch. *-}
-instance Binary DocName where
- put_ bh (Link aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (NoLink ab) = do
- putByte bh 1
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- aa <- get bh
- return (Link aa)
- 1 -> do
- ab <- get bh
- return (NoLink ab)
- _ -> fail "invalid binary data found"
-
-
instance Binary DocOption where
put_ bh OptHide = do
putByte bh 0
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
index f73cf2ee..2413f951 100644
--- a/src/Haddock/ModuleTree.hs
+++ b/src/Haddock/ModuleTree.hs
@@ -6,7 +6,7 @@
module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
-import Haddock.Types ( DocName )
+import Haddock.DocName
import GHC ( HsDoc, Name )
import Module ( Module, moduleNameString, moduleName, modulePackageId )
import PackageConfig ( packageIdString )
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 580dc8cc..086469cf 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -8,12 +8,17 @@
module Haddock.Types where
+import Haddock.GHC.Utils
+import Haddock.DocName
+
import Data.Map (Map)
import qualified Data.Map as Map
import GHC hiding (NoLink)
import Outputable
import OccName
+import Name
+
{-! for DocOption derive: Binary !-}
data DocOption
@@ -78,21 +83,7 @@ data ExportItem name
type InstHead name = ([HsPred name], name, [HsType name])
type ModuleMap = Map Module Interface
type DocMap = Map Name (HsDoc DocName)
-type LinkEnv = Map Name Name
-
-
-{-! for DocName derive: Binary !-}
-data DocName = Link Name | NoLink Name
-
-
-instance Outputable DocName where
- ppr (Link n) = ppr n
- ppr (NoLink n) = ppr n
-
-
-instance NamedThing DocName where
- getName (Link n) = n
- getName (NoLink n) = n
+type LinkEnv = Map Name Module
-- | This structure holds the module information we get from GHC's
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index b7b215d9..ca21c020 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -167,8 +167,8 @@ moduleHtmlFile mdl =
mdl' = map (\c -> if c == '.' then '-' else c)
(moduleNameString (moduleName mdl))
-nameHtmlRef :: Module -> Name -> String
-nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)
+nameHtmlRef :: Module -> OccName -> String
+nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n)
contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
@@ -179,10 +179,9 @@ subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
where b | isAlpha a = [a]
| otherwise = show (ord a)
-anchorNameStr :: Name -> String
-anchorNameStr name | isValOcc occName = "v:" ++ getOccString name
- | otherwise = "t:" ++ getOccString name
- where occName = nameOccName name
+anchorNameStr :: OccName -> String
+anchorNameStr name | isValOcc name = "v:" ++ occNameString name
+ | otherwise = "t:" ++ occNameString name
pathJoin :: [FilePath] -> FilePath
pathJoin = foldr join []
diff --git a/src/Main.hs b/src/Main.hs
index bd2b4830..597048fb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -13,7 +13,7 @@ module Main (main) where
import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
-import Haddock.Types hiding (NoLink)
+import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Exception
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:53:52 +0000