aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs29
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs51
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs604
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs33
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs19
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs113
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs182
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs69
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs69
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs8
11 files changed, 725 insertions, 467 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 2c7be079..9a31428f 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -129,6 +129,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
+ f (TyClD _ (FamDecl _ d)) = ppFam dflags d
f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
f (SigD _ sig) = ppSig dflags sig ++ ppFixities
@@ -141,11 +142,7 @@ ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags (TypeSig _ names sig) subdocs
= concatMap mkDocSig names
where
- mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
- ++ [pp_sig dflags names (hsSigWcType sig)]
-
- getDoc :: Located Name -> [Documentation Name]
- getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
+ mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]
ppSigWithDoc _ _ _ = []
@@ -173,10 +170,14 @@ ppClass dflags decl subdocs =
ppTyFams
| null $ tcdATs decl = ""
| otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
- [ map ppr (tcdATs decl)
+ [ map pprTyFam (tcdATs decl)
, map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
]
+ pprTyFam :: LFamilyDecl GhcRn -> SDoc
+ pprTyFam (L _ at) = vcat' $ map text $
+ mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)
+
whereWrapper elems = vcat'
[ text "where" <+> lbrace
, nest 4 . vcat . map (Outputable.<> semi) $ elems
@@ -192,6 +193,15 @@ ppClass dflags decl subdocs =
, tcdSExt = emptyNameSet
}
+ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
+ppFam dflags decl@(FamilyDecl { fdInfo = info })
+ = [out dflags decl']
+ where
+ decl' = case info of
+ -- We don't need to print out a closed type family's equations
+ -- for Hoogle, so pretend it doesn't have any.
+ ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
+ _ -> decl
ppInstance :: DynFlags -> ClsInst -> [String]
ppInstance dflags x =
@@ -286,6 +296,10 @@ docWith dflags header d
lines header ++ ["" | header /= "" && isJust d] ++
maybe [] (showTags . markup (markupTag dflags)) d
+mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
+ where
+ getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
deriving Show
@@ -329,7 +343,8 @@ markupTag dflags = Markup {
markupAName = const $ str "",
markupProperty = box TagPre . str,
markupExample = box TagPre . str . unlines . map exampleToString,
- markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h
+ markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h,
+ markupTable = \(Table _ _) -> str "TODO: table"
}
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 56137f51..220a59fe 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
+import qualified SrcLoc
import qualified Outputable as GHC
import Control.Applicative
@@ -52,10 +53,10 @@ type DetailsMap = Map.Map Position (Span, TokenDetails)
mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
mkDetailsMap xs =
- Map.fromListWith select_details [ (start, (token_span, token_details))
+ Map.fromListWith select_details [ (start, (span, token_details))
| (ghc_span, token_details) <- xs
- , Just !token_span <- [ghcSrcSpanToSpan ghc_span]
- , let start = spStart token_span
+ , GHC.RealSrcSpan span <- [ghc_span]
+ , let start = SrcLoc.realSrcSpanStart span
]
where
-- favour token details which appear earlier in the list
@@ -63,17 +64,11 @@ mkDetailsMap xs =
lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
lookupBySpan span details = do
- (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details
- guard (tok_span `containsSpan` span )
+ let pos = SrcLoc.realSrcSpanStart span
+ (_, (tok_span, tok_details)) <- Map.lookupLE pos details
+ guard (tok_span `SrcLoc.containsSpan` span)
return tok_details
-ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span
-ghcSrcSpanToSpan (GHC.RealSrcSpan span) =
- Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span)
- , spEnd = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span)
- })
-ghcSrcSpanToSpan _ = Nothing
-
enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
enrichToken (Token typ _ spn) dm
| typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
@@ -99,9 +94,12 @@ variables =
types :: GHC.RenamedSource -> LTokenDetails
types = everythingInRenamedSource ty
where
+ ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
ty term = case cast term of
(Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
pure (sspan, RtkType (GHC.unLoc name))
+ (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->
+ (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
_ -> empty
-- | Obtain details map for identifier bindings.
@@ -117,6 +115,11 @@ binds = everythingInRenamedSource
fun term = case cast term of
(Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
pure (sspan, RtkBind name)
+ (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->
+ pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
+ _ -> empty
+ patsyn_binds term = case cast term of
+ (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
_ -> empty
pat term = case cast term of
(Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
@@ -142,6 +145,7 @@ decls :: GHC.RenamedSource -> LTokenDetails
decls (group, _, _, _) = concatMap ($ group)
[ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
, everythingInRenamedSource fun . GHC.hs_valds
+ , everythingInRenamedSource fix . GHC.hs_fixds
, everythingInRenamedSource (con `Syb.combine` ins)
]
where
@@ -149,11 +153,16 @@ decls (group, _, _, _) = concatMap ($ group)
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
GHC.SynDecl _ name _ _ _ -> pure . decl $ name
GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
- GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
+ GHC.ClassDecl{..} ->
+ [decl tcdLName]
+ ++ concatMap sig tcdSigs
+ ++ concatMap tyfam tcdATs
GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
fun term = case cast term of
(Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
+ (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))
+ | GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
(Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
@@ -171,7 +180,14 @@ decls (group, _, _, _) = concatMap ($ group)
Just (field :: GHC.ConDeclField GHC.GhcRn)
-> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
+ fix term = case cast term of
+ Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)
+ -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
+ Nothing -> empty
+ tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
+ sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
+ sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
sig _ = []
decl (GHC.L sspan name) = (sspan, RtkDecl name)
tyref (GHC.L sspan name) = (sspan, RtkType name)
@@ -190,10 +206,11 @@ imports src@(_, imps, _, _) =
(Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith _ t _ vs _fls)) ->
[typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
+ (Just (GHC.IEModuleContents _ m)) -> pure $ modu m
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
- imp idecl | not . GHC.ideclImplicit $ idecl =
- let (GHC.L sspan name) = GHC.ideclName idecl
- in Just (sspan, RtkModule name)
- imp _ = Nothing
+ modu (GHC.L sspan name) = (sspan, RtkModule name)
+ imp idecl
+ | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))
+ | otherwise = Nothing
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index e4345602..34512de8 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,11 +1,17 @@
module Haddock.Backends.Hyperlinker.Parser (parse) where
+import Data.Either ( isRight, isLeft )
+import Data.List ( foldl', isPrefixOf, isSuffixOf )
+import Data.Maybe ( maybeToList )
-import Data.Char
-import Data.List
-import Data.Maybe
+import GHC ( DynFlags, addSourceToTokens )
+import SrcLoc
+import FastString ( mkFastString )
+import StringBuffer ( stringToStringBuffer )
+import Lexer ( Token(..) )
+import qualified Lexer as L
-import Haddock.Backends.Hyperlinker.Types
+import Haddock.Backends.Hyperlinker.Types as T
-- | Turn source code string into a stream of more descriptive tokens.
@@ -13,202 +19,404 @@ import Haddock.Backends.Hyperlinker.Types
-- Result should retain original file layout (including comments, whitespace,
-- etc.), i.e. the following "law" should hold:
--
--- @concat . map 'tkValue' . 'parse' = id@
-parse :: String -> [Token]
-parse = tokenize . tag . chunk
-
--- | Split raw source string to more meaningful chunks.
---
--- This is the initial stage of tokenization process. Each chunk is either
--- a comment (including comment delimiters), a whitespace string, preprocessor
--- macro (and all its content until the end of a line) or valid Haskell lexeme.
-chunk :: String -> [String]
-chunk [] = []
-chunk str@(c:_)
- | isSpace c =
- let (space, mcpp, rest) = spanSpaceOrCpp str
- in [space] ++ maybeToList mcpp ++ chunk rest
-chunk str
- | "--" `isPrefixOf` str = chunk' $ spanToNewline str
- | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
- | otherwise = case lex' str of
- (tok:_) -> chunk' tok
- [] -> [str]
+-- prop> concat . map tkValue . parse = id
+--
+-- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v',
+-- characters, since GHC transforms those into ' ' and '\n')
+parse :: DynFlags -> FilePath -> String -> [T.Token]
+parse dflags fp s = ghcToks (processCPP dflags fp s)
+
+
+-- | Parse the source into tokens using the GHC lexer.
+--
+-- * CPP lines are removed and reinserted as line-comments
+-- * top-level file pragmas are parsed as block comments (see the
+-- 'ITblockComment' case of 'classify' for more details)
+--
+processCPP :: DynFlags -- ^ GHC's flags
+ -> FilePath -- ^ source file name (for position information)
+ -> String -- ^ source file contents
+ -> [(Located L.Token, String)]
+processCPP dflags fpath s = addSrc . go start . splitCPP $ s
where
- chunk' (c, rest) = c:(chunk rest)
-
--- | A bit better lexer then the default, i.e. handles DataKinds quotes
-lex' :: ReadS String
-lex' ('\'' : '\'' : rest) = [("''", rest)]
-lex' str@('\'' : '\\' : _ : '\'' : _) = lex str
-lex' str@('\'' : _ : '\'' : _) = lex str
-lex' ('\'' : rest) = [("'", rest)]
-lex' str = lex str
-
--- | Split input to "first line" string and the rest of it.
---
--- Ideally, this should be done simply with @'break' (== '\n')@. However,
--- Haskell also allows line-unbreaking (or whatever it is called) so things
--- are not as simple and this function deals with that.
-spanToNewline :: String -> (String, String)
-spanToNewline [] = ([], [])
-spanToNewline ('\\':'\n':str) =
- let (str', rest) = spanToNewline str
+ start = mkRealSrcLoc (mkFastString fpath) 1 1
+ addSrc = addSourceToTokens start (stringToStringBuffer s)
+
+ -- Transform a list of Haskell/CPP lines into a list of tokens
+ go :: RealSrcLoc -> [Either String String] -> [Located L.Token]
+ go _ [] = []
+ go pos ls =
+ let (hLinesRight, ls') = span isRight ls
+ (cppLinesLeft, rest) = span isLeft ls'
+
+ hSrc = concat [ hLine | Right hLine <- hLinesRight ]
+ cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ]
+
+ in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of
+
+ -- Stuff that fails to lex gets turned into comments
+ L.PFailed _ _ss _msg ->
+ let (src_pos, failed) = mkToken ITunknown pos hSrc
+ (new_pos, cpp) = mkToken ITlineComment src_pos cppSrc
+ in failed : cpp : go new_pos rest
+
+ -- Successfully lexed
+ L.POk ss toks ->
+ let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc
+ in toks ++ [cpp] ++ go new_pos rest
+
+ -- Manually make a token from a 'String', advancing the cursor position
+ mkToken tok start' str =
+ let end = foldl' advanceSrcLoc start' str
+ in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str))
+
+
+-- | Split apart the initial file into Haskell source lines ('Left' entries) and
+-- CPP lines ('Right' entries).
+--
+-- All characters in the input are present in the output:
+--
+-- prop> concat . map (either id id) . splitCPP = id
+splitCPP :: String -> [Either String String]
+splitCPP "" = []
+splitCPP s | isCPPline s = Left l : splitCPP rest
+ | otherwise = Right l : splitCPP rest
+ where
+ ~(l, rest) = spanToNewline 0 s
+
+
+-- | Heuristic to decide if a line is going to be a CPP line. This should be a
+-- cheap operation since it is going to be run on every line being processed.
+--
+-- Right now it just checks if the first non-whitespace character in the first
+-- five characters of the line is a '#':
+--
+-- >>> isCPPline "#define FOO 1"
+-- True
+--
+-- >>> isCPPline "\t\t #ifdef GHC"
+-- True
+--
+-- >>> isCPPline " #endif"
+-- False
+--
+isCPPline :: String -> Bool
+isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5
+
+
+-- | Split a "line" off the front of a string, supporting newline escapes.
+--
+-- By "line", we understand: the shortest substring ending in a '\n' that is not
+--
+-- 1. immediately preceded by a '\\'
+-- 2. not inside some (possibly nested) block comment
+--
+-- All characters in the input are present in the output:
+--
+-- prop> curry (++) . spanToNewLine 0 = id
+spanToNewline :: Int -- ^ open '{-'
+ -> String -- ^ input
+ -> (String, String)
+spanToNewline _ [] = ([], [])
+spanToNewline n ('\n':str) | n <= 0 = ("\n", str)
+spanToNewline n ('\\':'\n':str) =
+ let (str', rest) = spanToNewline n str
in ('\\':'\n':str', rest)
-spanToNewline str@('\n':_) = ("", str)
-spanToNewline (c:str) =
- let (str', rest) = spanToNewline str
+spanToNewline n ('{':'-':str) =
+ let (str', rest) = spanToNewline (n+1) str
+ in ('{':'-':str', rest)
+spanToNewline n ('-':'}':str) =
+ let (str', rest) = spanToNewline (n-1) str
+ in ('-':'}':str', rest)
+spanToNewline n (c:str) =
+ let (str', rest) = spanToNewline n str
in (c:str', rest)
--- | Split input to whitespace string, (optional) preprocessor directive and
--- the rest of it.
---
--- Again, using something like @'span' 'isSpace'@ would be nice to chunk input
--- to whitespace. The problem is with /#/ symbol - if it is placed at the very
--- beginning of a line, it should be recognized as preprocessor macro. In any
--- other case, it is ordinary Haskell symbol and can be used to declare
--- operators. Hence, while dealing with whitespace we also check whether there
--- happens to be /#/ symbol just after a newline character - if that is the
--- case, we begin treating the whole line as preprocessor macro.
-spanSpaceOrCpp :: String -> (String, Maybe String, String)
-spanSpaceOrCpp ('\n':'#':str) =
- let (str', rest) = spanToNewline str
- in ("\n", Just $ '#':str', rest)
-spanSpaceOrCpp (c:str')
- | isSpace c =
- let (space, mcpp, rest) = spanSpaceOrCpp str'
- in (c:space, mcpp, rest)
-spanSpaceOrCpp str = ("", Nothing, str)
-
--- | Split input to comment content (including delimiters) and the rest.
---
--- Again, some more logic than simple 'span' is required because of Haskell
--- comment nesting policy.
-chunkComment :: Int -> String -> (String, String)
-chunkComment _ [] = ("", "")
-chunkComment depth ('{':'-':str) =
- let (c, rest) = chunkComment (depth + 1) str
- in ("{-" ++ c, rest)
-chunkComment depth ('-':'}':str)
- | depth == 1 = ("-}", str)
- | otherwise =
- let (c, rest) = chunkComment (depth - 1) str
- in ("-}" ++ c, rest)
-chunkComment depth (e:str) =
- let (c, rest) = chunkComment depth str
- in (e:c, rest)
-
--- | Assign source location for each chunk in given stream.
-tag :: [String] -> [(Span, String)]
-tag =
- reverse . snd . foldl aux (Position 1 1, [])
- where
- aux (pos, cs) str =
- let pos' = foldl move pos str
- in (pos', (Span pos pos', str):cs)
- move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
- move pos _ = pos { posCol = posCol pos + 1 }
-
--- | Turn unrecognised chunk stream to more descriptive token stream.
-tokenize :: [(Span, String)] -> [Token]
-tokenize =
- map aux
- where
- aux (sp, str) = Token
- { tkType = classify str
- , tkValue = str
- , tkSpan = sp
- }
-
--- | Classify given string as appropriate Haskell token.
---
--- This method is based on Haskell 98 Report lexical structure description:
--- https://www.haskell.org/onlinereport/lexemes.html
---
--- However, this is probably far from being perfect and most probably does not
--- handle correctly all corner cases.
-classify :: String -> TokenType
-classify str
- | "--" `isPrefixOf` str = TkComment
- | "{-#" `isPrefixOf` str = TkPragma
- | "{-" `isPrefixOf` str = TkComment
-classify "''" = TkSpecial
-classify "'" = TkSpecial
-classify str@(c:_)
- | isSpace c = TkSpace
- | isDigit c = TkNumber
- | c `elem` special = TkSpecial
- | str `elem` glyphs = TkGlyph
- | all (`elem` symbols) str = TkOperator
- | c == '#' = TkCpp
- | c == '"' = TkString
- | c == '\'' = TkChar
-classify str
- | str `elem` keywords = TkKeyword
- | isIdentifier str = TkIdentifier
- | otherwise = TkUnknown
-
-keywords :: [String]
-keywords =
- [ "as"
- , "case"
- , "class"
- , "data"
- , "default"
- , "deriving"
- , "do"
- , "else"
- , "hiding"
- , "if"
- , "import"
- , "in"
- , "infix"
- , "infixl"
- , "infixr"
- , "instance"
- , "let"
- , "module"
- , "newtype"
- , "of"
- , "qualified"
- , "then"
- , "type"
- , "where"
- , "forall"
- , "family"
- , "mdo"
- ]
-
-glyphs :: [String]
-glyphs =
- [ ".."
- , ":"
- , "::"
- , "="
- , "\\"
- , "|"
- , "<-"
- , "->"
- , "@"
- , "~"
- , "~#"
- , "=>"
- , "-"
- , "!"
- ]
-
-special :: [Char]
-special = "()[]{},;`"
-
--- TODO: Add support for any Unicode symbol or punctuation.
--- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators
-symbols :: [Char]
-symbols = "!#$%&*+./<=>?@\\^|-~:"
-
-isIdentifier :: String -> Bool
-isIdentifier (s:str)
- | (isLower' s || isUpper s) && all isAlphaNum' str = True
+
+-- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of
+-- Haddock's 'T.Token'.
+ghcToks :: [(Located L.Token, String)] -> [T.Token]
+ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
where
- isLower' c = isLower c || c == '_'
- isAlphaNum' c = isAlphaNum c || c == '_' || c == '\''
-isIdentifier _ = False
+ start = mkRealSrcLoc (mkFastString "lexing") 1 1
+
+ go :: (RealSrcLoc, [T.Token], Bool)
+ -- ^ current position, tokens accumulated, currently in pragma (or not)
+
+ -> (Located L.Token, String)
+ -- ^ next token, its content
+
+ -> (RealSrcLoc, [T.Token], Bool)
+ -- ^ new position, new tokens accumulated, currently in pragma (or not)
+
+ go (pos, toks, in_prag) (L l tok, raw) =
+ ( next_pos
+ , classifiedTok ++ maybeToList white ++ toks
+ , inPragma in_prag tok
+ )
+ where
+ (next_pos, white) = mkWhitespace pos l
+
+ classifiedTok = [ Token (classify' tok) raw rss
+ | RealSrcSpan rss <- [l]
+ , not (null raw)
+ ]
+
+ classify' | in_prag = const TkPragma
+ | otherwise = classify
+
+
+-- | Find the correct amount of whitespace between tokens.
+mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token)
+mkWhitespace prev spn =
+ case spn of
+ UnhelpfulSpan _ -> (prev,Nothing)
+ RealSrcSpan s | null wsstring -> (end, Nothing)
+ | otherwise -> (end, Just (Token TkSpace wsstring wsspan))
+ where
+ start = realSrcSpanStart s
+ end = realSrcSpanEnd s
+ wsspan = mkRealSrcSpan prev start
+ nls = srcLocLine start - srcLocLine prev
+ spaces = if nls == 0 then srcLocCol start - srcLocCol prev
+ else srcLocCol start - 1
+ wsstring = replicate nls '\n' ++ replicate spaces ' '
+
+
+-- | Classify given tokens as appropriate Haskell token type.
+classify :: L.Token -> TokenType
+classify tok =
+ case tok of
+ ITas -> TkKeyword
+ ITcase -> TkKeyword
+ ITclass -> TkKeyword
+ ITdata -> TkKeyword
+ ITdefault -> TkKeyword
+ ITderiving -> TkKeyword
+ ITdo -> TkKeyword
+ ITelse -> TkKeyword
+ IThiding -> TkKeyword
+ ITforeign -> TkKeyword
+ ITif -> TkKeyword
+ ITimport -> TkKeyword
+ ITin -> TkKeyword
+ ITinfix -> TkKeyword
+ ITinfixl -> TkKeyword
+ ITinfixr -> TkKeyword
+ ITinstance -> TkKeyword
+ ITlet -> TkKeyword
+ ITmodule -> TkKeyword
+ ITnewtype -> TkKeyword
+ ITof -> TkKeyword
+ ITqualified -> TkKeyword
+ ITthen -> TkKeyword
+ ITtype -> TkKeyword
+ ITwhere -> TkKeyword
+
+ ITforall {} -> TkKeyword
+ ITexport -> TkKeyword
+ ITlabel -> TkKeyword
+ ITdynamic -> TkKeyword
+ ITsafe -> TkKeyword
+ ITinterruptible -> TkKeyword
+ ITunsafe -> TkKeyword
+ ITstdcallconv -> TkKeyword
+ ITccallconv -> TkKeyword
+ ITcapiconv -> TkKeyword
+ ITprimcallconv -> TkKeyword
+ ITjavascriptcallconv -> TkKeyword
+ ITmdo -> TkKeyword
+ ITfamily -> TkKeyword
+ ITrole -> TkKeyword
+ ITgroup -> TkKeyword
+ ITby -> TkKeyword
+ ITusing -> TkKeyword
+ ITpattern -> TkKeyword
+ ITstatic -> TkKeyword
+ ITstock -> TkKeyword
+ ITanyclass -> TkKeyword
+
+ ITunit -> TkKeyword
+ ITsignature -> TkKeyword
+ ITdependency -> TkKeyword
+ ITrequires -> TkKeyword
+
+ ITinline_prag {} -> TkPragma
+ ITspec_prag {} -> TkPragma
+ ITspec_inline_prag {} -> TkPragma
+ ITsource_prag {} -> TkPragma
+ ITrules_prag {} -> TkPragma
+ ITwarning_prag {} -> TkPragma
+ ITdeprecated_prag {} -> TkPragma
+ ITline_prag {} -> TkPragma
+ ITcolumn_prag {} -> TkPragma
+ ITscc_prag {} -> TkPragma
+ ITgenerated_prag {} -> TkPragma
+ ITcore_prag {} -> TkPragma
+ ITunpack_prag {} -> TkPragma
+ ITnounpack_prag {} -> TkPragma
+ ITann_prag {} -> TkPragma
+ ITcomplete_prag {} -> TkPragma
+ ITclose_prag -> TkPragma
+ IToptions_prag {} -> TkPragma
+ ITinclude_prag {} -> TkPragma
+ ITlanguage_prag -> TkPragma
+ ITvect_prag {} -> TkPragma
+ ITvect_scalar_prag {} -> TkPragma
+ ITnovect_prag {} -> TkPragma
+ ITminimal_prag {} -> TkPragma
+ IToverlappable_prag {} -> TkPragma
+ IToverlapping_prag {} -> TkPragma
+ IToverlaps_prag {} -> TkPragma
+ ITincoherent_prag {} -> TkPragma
+ ITctype {} -> TkPragma
+
+ ITdotdot -> TkGlyph
+ ITcolon -> TkGlyph
+ ITdcolon {} -> TkGlyph
+ ITequal -> TkGlyph
+ ITlam -> TkGlyph
+ ITlcase -> TkGlyph
+ ITvbar -> TkGlyph
+ ITlarrow {} -> TkGlyph
+ ITrarrow {} -> TkGlyph
+ ITat -> TkGlyph
+ ITtilde -> TkGlyph
+ ITtildehsh -> TkGlyph
+ ITdarrow {} -> TkGlyph
+ ITminus -> TkGlyph
+ ITbang -> TkGlyph
+ ITdot -> TkOperator
+ ITtypeApp -> TkGlyph
+
+ ITbiglam -> TkGlyph
+
+ ITocurly -> TkSpecial
+ ITccurly -> TkSpecial
+ ITvocurly -> TkSpecial
+ ITvccurly -> TkSpecial
+ ITobrack -> TkSpecial
+ ITopabrack -> TkSpecial
+ ITcpabrack -> TkSpecial
+ ITcbrack -> TkSpecial
+ IToparen -> TkSpecial
+ ITcparen -> TkSpecial
+ IToubxparen -> TkSpecial
+ ITcubxparen -> TkSpecial
+ ITsemi -> TkSpecial
+ ITcomma -> TkSpecial
+ ITunderscore -> TkIdentifier
+ ITbackquote -> TkSpecial
+ ITsimpleQuote -> TkSpecial
+
+ ITvarid {} -> TkIdentifier
+ ITconid {} -> TkIdentifier
+ ITvarsym {} -> TkOperator
+ ITconsym {} -> TkOperator
+ ITqvarid {} -> TkIdentifier
+ ITqconid {} -> TkIdentifier
+ ITqvarsym {} -> TkOperator
+ ITqconsym {} -> TkOperator
+
+ ITdupipvarid {} -> TkUnknown
+ ITlabelvarid {} -> TkUnknown
+
+ ITchar {} -> TkChar
+ ITstring {} -> TkString
+ ITinteger {} -> TkNumber
+ ITrational {} -> TkNumber
+
+ ITprimchar {} -> TkChar
+ ITprimstring {} -> TkString
+ ITprimint {} -> TkNumber
+ ITprimword {} -> TkNumber
+ ITprimfloat {} -> TkNumber
+ ITprimdouble {} -> TkNumber
+
+ ITopenExpQuote {} -> TkSpecial
+ ITopenPatQuote -> TkSpecial
+ ITopenDecQuote -> TkSpecial
+ ITopenTypQuote -> TkSpecial
+ ITcloseQuote {} -> TkSpecial
+ ITopenTExpQuote {} -> TkSpecial
+ ITcloseTExpQuote -> TkSpecial
+ ITidEscape {} -> TkUnknown
+ ITparenEscape -> TkSpecial
+ ITidTyEscape {} -> TkUnknown
+ ITparenTyEscape -> TkSpecial
+ ITtyQuote -> TkSpecial
+ ITquasiQuote {} -> TkUnknown
+ ITqQuasiQuote {} -> TkUnknown
+
+ ITproc -> TkKeyword
+ ITrec -> TkKeyword
+ IToparenbar {} -> TkGlyph
+ ITcparenbar {} -> TkGlyph
+ ITlarrowtail {} -> TkGlyph
+ ITrarrowtail {} -> TkGlyph
+ ITLarrowtail {} -> TkGlyph
+ ITRarrowtail {} -> TkGlyph
+
+ ITunknown {} -> TkUnknown
+ ITeof -> TkUnknown
+
+ -- Line comments are only supposed to start with '--'. Starting with '#'
+ -- means that this was probably a CPP.
+ ITlineComment s
+ | isCPPline s -> TkCpp
+ | otherwise -> TkComment
+
+ ITdocCommentNext {} -> TkComment
+ ITdocCommentPrev {} -> TkComment
+ ITdocCommentNamed {} -> TkComment
+ ITdocSection {} -> TkComment
+ ITdocOptions {} -> TkComment
+
+ -- The lexer considers top-level pragmas as comments (see `pragState` in
+ -- the GHC lexer for more), so we have to manually reverse this. The
+ -- following is a hammer: it smashes _all_ pragma-like block comments into
+ -- pragmas.
+ ITblockComment c
+ | isPrefixOf "{-#" c
+ , isSuffixOf "#-}" c -> TkPragma
+ | otherwise -> TkComment
+
+-- | Classify given tokens as beginning pragmas (or not).
+inPragma :: Bool -- ^ currently in pragma
+ -> L.Token -- ^ current token
+ -> Bool -- ^ new information about whether we are in a pragma
+inPragma _ ITclose_prag = False
+inPragma True _ = True
+inPragma False tok =
+ case tok of
+ ITinline_prag {} -> True
+ ITspec_prag {} -> True
+ ITspec_inline_prag {} -> True
+ ITsource_prag {} -> True
+ ITrules_prag {} -> True
+ ITwarning_prag {} -> True
+ ITdeprecated_prag {} -> True
+ ITline_prag {} -> True
+ ITcolumn_prag {} -> True
+ ITscc_prag {} -> True
+ ITgenerated_prag {} -> True
+ ITcore_prag {} -> True
+ ITunpack_prag {} -> True
+ ITnounpack_prag {} -> True
+ ITann_prag {} -> True
+ ITcomplete_prag {} -> True
+ IToptions_prag {} -> True
+ ITinclude_prag {} -> True
+ ITlanguage_prag -> True
+ ITvect_prag {} -> True
+ ITvect_scalar_prag {} -> True
+ ITnovect_prag {} -> True
+ ITminimal_prag {} -> True
+ IToverlappable_prag {} -> True
+ IToverlapping_prag {} -> True
+ IToverlaps_prag {} -> True
+ ITincoherent_prag {} -> True
+ ITctype {} -> True
+
+ _ -> False
+
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 15793f0c..5291220a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -15,7 +15,6 @@ import System.FilePath.Posix ((</>))
import Data.List
import Data.Maybe
-import Data.Monoid
import qualified Data.Map as Map
import Text.XHtml (Html, HtmlAttr, (!))
@@ -82,7 +81,7 @@ header mcss mjs =
tokenGroup :: SrcMap -> TokenGroup -> Html
tokenGroup _ (GrpNormal tok@(Token { .. }))
- | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue
+ | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue
| otherwise = tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle $ tkType ]
@@ -155,7 +154,7 @@ internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
+externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleNameUrl mdl name ]
Just (SrcExternal path) -> Html.anchor content !
@@ -165,12 +164,14 @@ externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
mdl = GHC.nameModule name
externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
-externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
- Just SrcLocal -> Html.anchor content !
+externalModHyperlink srcs name content =
+ let srcs' = Map.mapKeys GHC.moduleName srcs in
+ case Map.lookup name srcs' of
+ Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleUrl' name ]
- Just (SrcExternal path) -> Html.anchor content !
+ Just (SrcExternal path) -> Html.anchor content !
[ Html.href $ path </> hypSrcModuleUrl' name ]
- Nothing -> content
+ Nothing -> content
renderSpace :: Int -> String -> Html
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index d8ae89e4..e377471e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -4,8 +4,6 @@ module Haddock.Backends.Hyperlinker.Types where
import qualified GHC
import Data.Map (Map)
-import qualified Data.Map as Map
-
data Token = Token
{ tkType :: TokenType
@@ -14,23 +12,8 @@ data Token = Token
}
deriving (Show)
-data Position = Position
- { posRow :: !Int
- , posCol :: !Int
- }
- deriving (Eq, Ord, Show)
-
-data Span = Span
- { spStart :: !Position
- , spEnd :: !Position
- }
- deriving (Show)
-
--- | Tests whether the first span "contains" the other span, meaning
--- that it covers at least as much source code. True where spans are equal.
-containsSpan :: Span -> Span -> Bool
-containsSpan s1 s2 =
- spStart s1 <= spStart s2 && spEnd s1 >= spEnd s2
+type Position = GHC.RealSrcLoc
+type Span = GHC.RealSrcSpan
data TokenType
= TkIdentifier
@@ -80,15 +63,5 @@ data SrcPath
| SrcLocal
-- | Mapping from modules to cross-package source paths.
---
--- This mapping is actually a pair of maps instead of just one map. The reason
--- for this is because when hyperlinking modules in import lists we have no
--- 'GHC.Module' available. On the other hand, we can't just use map with
--- 'GHC.ModuleName' as indices because certain modules may have common name
--- but originate in different packages. Hence, we use both /rich/ and /poor/
--- versions, where the /poor/ is just projection of /rich/ one cached in pair
--- for better performance.
-type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
+type SrcMap = Map GHC.Module SrcPath
-mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
-mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 1b2515fa..d06e85d1 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -547,13 +547,11 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig doc names (hsSigWcType typ) unicode
+ vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode
| L _ (TypeSig _ lnames typ) <- lsigs
- , let doc = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames ]
- -- FIXME: is taking just the first name ok? Is it possible that
- -- there are different subdocs for different names in a single
- -- type signature?
+ , name <- map unLoc lnames
+ , let doc = lookupAnySubdoc name subdocs
+ ]
instancesBit = ppDocInstances unicode instances
@@ -571,14 +569,14 @@ ppDocInstances unicode (i : rest)
(is, rest') = spanWith isUndocdInstance rest
isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (i,Nothing,_) = Just i
+isUndocdInstance (i,Nothing,_,_) = Just i
isUndocdInstance _ = Nothing
-- | Print a possibly commented instance. The instance header is printed inside
-- an 'argBox'. The comment is printed to the right of the box in normal comment
-- style.
ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX
-ppDocInstance unicode (instHead, doc, _) =
+ppDocInstance unicode (instHead, doc, _, _) =
declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
@@ -1148,7 +1146,8 @@ parLatexMarkup ppId = Markup {
markupAName = \_ _ -> empty,
markupProperty = \p _ -> quote $ verb $ text p,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
- markupHeader = \(Header l h) p -> header l (h p)
+ markupHeader = \(Header l h) p -> header l (h p),
+ markupTable = \(Table h b) p -> table h b p
}
where
header 1 d = text "\\section*" <> braces d
@@ -1157,6 +1156,8 @@ parLatexMarkup ppId = Markup {
| l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
+ table _ _ _ = text "{TODO: Table}"
+
fixString Plain s = latexFilter s
fixString Verb s = s
fixString Mono s = latexMonoFilter s
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 464c166b..6da6a2e8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -70,6 +70,7 @@ ppHtml :: DynFlags
-> Maybe String -- ^ The contents URL (--use-contents)
-> Maybe String -- ^ The index URL (--use-index)
-> Bool -- ^ Whether to use unicode in output (--use-unicode)
+ -> Maybe String -- ^ Package name
-> QualOption -- ^ How to qualify names
-> Bool -- ^ Output pretty html (newlines and indenting)
-> Bool -- ^ Also write Quickjump index
@@ -78,7 +79,7 @@ ppHtml :: DynFlags
ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode
- qual debug withQuickjump = do
+ pkg qual debug withQuickjump = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
@@ -88,7 +89,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces ++ reexported_ifaces)
False -- we don't want to display the packages in a single-package contents
- prologue debug (makeContentsQual qual)
+ prologue debug pkg (makeContentsQual qual)
when (isNothing maybe_index_url) $ do
ppHtmlIndex odir doctitle maybe_package
@@ -96,12 +97,12 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
(map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
when withQuickjump $
- ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual
+ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual
visible_ifaces
mapM_ (ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
+ maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces
copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
@@ -258,11 +259,12 @@ ppHtmlContents
-> WikiURLs
-> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)
-> Bool
+ -> Maybe Package -- ^ Current package
-> Qualification -- ^ How to qualify names
-> IO ()
ppHtmlContents dflags odir doctitle _maybe_package
themes mathjax_url maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
let tree = mkModuleTree dflags showPkgs
[(instMod iface, toInstalledDescription iface)
| iface <- ifaces
@@ -276,41 +278,41 @@ ppHtmlContents dflags odir doctitle _maybe_package
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
- ppPrologue qual doctitle prologue,
- ppSignatureTree qual sig_tree,
- ppModuleTree qual tree
+ ppPrologue pkg qual doctitle prologue,
+ ppSignatureTree pkg qual sig_tree,
+ ppModuleTree pkg qual tree
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
-ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
-ppPrologue _ _ Nothing = noHtml
-ppPrologue qual title (Just doc) =
- divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
+ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
+ppPrologue _ _ _ Nothing = noHtml
+ppPrologue pkg qual title (Just doc) =
+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))
-ppSignatureTree :: Qualification -> [ModuleTree] -> Html
-ppSignatureTree qual ts =
- divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)
+ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
+ppSignatureTree pkg qual ts =
+ divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
-ppModuleTree :: Qualification -> [ModuleTree] -> Html
-ppModuleTree _ [] = mempty
-ppModuleTree qual ts =
- divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
+ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
+ppModuleTree _ _ [] = mempty
+ppModuleTree pkg qual ts =
+ divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)
-mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
-mkNodeList qual ss p ts = case ts of
+mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
+mkNodeList pkg qual ss p ts = case ts of
[] -> noHtml
- _ -> unordList (zipWith (mkNode qual ss) ps ts)
+ _ -> unordList (zipWith (mkNode pkg qual ss) ps ts)
where
ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
-mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
-mkNode qual ss p (Node s leaf _pkg srcPkg short ts) =
+mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html
+mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
htmlModule <+> shortDescr +++ htmlPkg +++ subtree
where
modAttrs = case (ts, leaf) of
@@ -330,14 +332,14 @@ mkNode qual ss p (Node s leaf _pkg srcPkg short ts) =
Nothing -> toHtml s
)
- shortDescr = maybe noHtml (origDocToHtml qual) short
+ shortDescr = maybe noHtml (origDocToHtml pkg qual) short
htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg
subtree =
if null ts then noHtml else
collapseDetails p DetailsOpen (
thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++
- mkNodeList qual (s:ss) p ts
+ mkNodeList pkg qual (s:ss) p ts
)
@@ -350,10 +352,11 @@ ppJsonIndex :: FilePath
-> SourceURLs -- ^ The source URL (--source)
-> WikiURLs -- ^ The wiki URL (--wiki)
-> Bool
+ -> Maybe Package
-> QualOption
-> [Interface]
-> IO ()
-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do
createDirectoryIfMissing True odir
IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do
Builder.hPutBuilder h (encodeToBuilder modules)
@@ -371,7 +374,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]
goExport mdl qual item
- | Just item_html <- processExport True links_info unicode qual item
+ | Just item_html <- processExport True links_info unicode pkg qual item
= [ Object
[ "display_html" .= String (showHtmlFragment item_html)
, "name" .= String (intercalate " " (map nameString names))
@@ -529,11 +532,11 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
-> Maybe String -> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool -> QualOption
+ -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode qual debug iface = do
+ maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
let
mdl = ifaceMod iface
aliases = ifaceModuleAliases iface
@@ -555,7 +558,7 @@ ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
- ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
]
createDirectoryIfMissing True odir
@@ -565,9 +568,9 @@ signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
-ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
- = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
+ = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++
description +++
synopsis +++
divInterface (maybe_doc_hdr +++ bdy +++ orphans)
@@ -585,7 +588,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
description | isNoHtml doc = doc
| otherwise = divDescription $ sectionName << "Description" +++ doc
- where doc = docSection Nothing qual (ifaceRnDoc iface)
+ where doc = docSection Nothing pkg qual (ifaceRnDoc iface)
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -595,7 +598,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
collapseDetails "syn" DetailsClosed (
thesummary << "Synopsis" +++
shortDeclList (
- mapMaybe (processExport True linksInfo unicode qual) exports
+ mapMaybe (processExport True linksInfo unicode pkg qual) exports
) ! collapseToggle "syn" ""
)
@@ -609,19 +612,20 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
bdy =
foldr (+++) noHtml $
- mapMaybe (processExport False linksInfo unicode qual) exports
+ mapMaybe (processExport False linksInfo unicode pkg qual) exports
orphans =
- ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual
+ ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual
linksInfo = (maybe_source_url, maybe_wiki_url)
-ppModuleContents :: Qualification
+ppModuleContents :: Maybe Package -- ^ This package
+ -> Qualification
-> [ExportItem DocNameI]
- -> Bool -- ^ Orphans sections
+ -> Bool -- ^ Orphans sections
-> Html
-ppModuleContents qual exports orphan
+ppModuleContents pkg qual exports orphan
| null sections && not orphan = noHtml
| otherwise = contentsDiv
where
@@ -641,7 +645,7 @@ ppModuleContents qual exports orphan
| otherwise = ( html:secs, rest2 )
where
html = linkedAnchor (groupId id0)
- << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs
+ << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs
(ssecs, rest1) = process lev rest
(secs, rest2) = process n rest1
process n (_ : rest) = process n rest
@@ -661,22 +665,22 @@ numberSectionHeadings = go 1
= other : go n es
-processExport :: Bool -> LinksInfo -> Bool -> Qualification
+processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
-> ExportItem DocNameI -> Maybe Html
-processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
-processExport summary _ _ qual (ExportGroup lev id0 doc)
- = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual
-processExport summary _ _ qual (ExportNoDecl y [])
+processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
+processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
+ = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc)
+processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
+processExport summary _ _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
-processExport summary _ _ qual (ExportNoDecl y subs)
+processExport summary _ _ _ qual (ExportNoDecl y subs)
= processDeclOneLiner summary $
ppDocName qual Prefix True y
+++ parenList (map (ppDocName qual Prefix True) subs)
-processExport summary _ _ qual (ExportDoc doc)
- = nothingIf summary $ docSection_ Nothing qual doc
-processExport summary _ _ _ (ExportModule mdl)
+processExport summary _ _ pkg qual (ExportDoc doc)
+ = nothingIf summary $ docSection_ Nothing pkg qual doc
+processExport summary _ _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
@@ -698,7 +702,8 @@ processDeclOneLiner True = Just
processDeclOneLiner False = Just . divTopDecl . declElem
groupHeading :: Int -> String -> Html -> Html
-groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]
+groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId]
+ where grpId = groupId id0
groupTag :: Int -> Html -> Html
groupTag lev
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8ac3d91b..3fbe6eaf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -52,36 +52,37 @@ ppDecl :: Bool -- ^ print summary info only
-> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls
-> Splice
-> Unicode -- ^ unicode output
+ -> Maybe Package
-> Qualification
-> Html
-ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
- TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
- TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
+ TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
- (hsSigWcType lty) fixities splice unicode qual
+ (hsSigWcType lty) fixities splice unicode pkg qual
SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
- (hsSigType lty) fixities splice unicode qual
- ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ (hsSigType lty) fixities splice unicode pkg qual
+ ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
+ Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
ppFunSig summary links loc doc (map unLoc lnames) lty fixities
- splice unicode qual
+ splice unicode pkg qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
+ Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
- splice unicode qual HideEmptyContexts
+ splice unicode pkg qual HideEmptyContexts
where
pp_typ = ppLType unicode qual HideEmptyContexts typ
@@ -90,25 +91,25 @@ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> [Located DocName] -- ^ names of patterns in declaration
-> LHsType DocNameI -- ^ type of patterns in declaration
-> [(DocName, Fixity)]
- -> Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc doc lnames typ fixities splice unicode qual =
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities
- (unLoc typ, pp_typ) splice unicode qual (patSigContext typ)
+ (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ)
where
pp_typ = ppPatSigType unicode qual typ
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
- Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
- splice unicode qual emptyCtxts =
+ splice unicode pkg qual emptyCtxts =
ppTypeOrFunSig summary links loc docnames typ doc
( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
, (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
- splice unicode qual emptyCtxts
+ splice unicode pkg qual emptyCtxts
where
occnames = map (nameOccName . getName) docnames
addFixities html
@@ -118,13 +119,15 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
-> DocForDecl DocName -> (Html, Html, Html)
- -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts
+ -> Splice -> Unicode -> Maybe Package -> Qualification
+ -> HideEmptyContexts -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
+ splice unicode pkg qual emptyCtxts
| summary = pref1
- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc
+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc
| otherwise = topDeclElem links loc splice docnames pref2
- +++ subArguments qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
- +++ docSection curName qual doc
+ +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
+ +++ docSection curName pkg qual doc
where
curName = getName <$> listToMaybe docnames
@@ -225,23 +228,23 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
- splice unicode qual
- = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
-ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
+ splice unicode pkg qual
+ = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual
+ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
-> DocForDecl DocName -> TyClDecl DocNameI
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype })
- splice unicode qual
+ splice unicode pkg qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
- splice unicode qual ShowEmptyToplevelContexts
+ splice unicode pkg qual ShowEmptyToplevelContexts
where
hdr = hsep ([keyword "type", ppBinder summary occ]
++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
@@ -250,7 +253,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
fixs
| summary = noHtml
| otherwise = ppFixities fixities qual
-ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html
@@ -343,11 +346,13 @@ ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->
[(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
+ FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package ->
+ Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl splice unicode
+ pkg qual
| summary = ppTyFamHeader True associated decl unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit
+ | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit
where
docname = unLoc $ fdLName decl
@@ -358,10 +363,10 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
instancesBit
| FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl
, not summary
- = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
+ = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
| otherwise
- = ppInstances links (OriginFamily docname) instances splice unicode qual
+ = ppInstances links (OriginFamily docname) instances splice unicode pkg qual
-- Individual equation of a closed type family
ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
@@ -391,9 +396,10 @@ ppPseudoFamilyDecl links splice unicode qual
ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI
- -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
-ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
- ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package
+ -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual
--------------------------------------------------------------------------------
@@ -503,22 +509,22 @@ ppFds fds unicode qual =
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan
-> [(DocName, DocForDecl DocName)]
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
, tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
- subdocs splice unicode qual =
+ subdocs splice unicode pkg qual =
if not (any isUserLSig sigs) && null ats
then (if summary then id else topDeclElem links loc splice [nm]) hdr
else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+++ shortSubDecls False
(
- [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
+ [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats
, let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-- ToDo: add associated type defaults
[ ppFunSig summary links loc doc names (hsSigWcType typ)
- [] splice unicode qual
+ [] splice unicode pkg qual
| L _ (TypeSig _ lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
@@ -529,20 +535,20 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
where
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 DocNameI] -> [(DocName, Fixity)]
-> SrcSpan -> Documentation DocName
-> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
, tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
- splice unicode qual
- | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
- | otherwise = classheader +++ docSection Nothing qual d
+ splice unicode pkg qual
+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual
+ | otherwise = classheader +++ docSection Nothing pkg qual d
+++ minimalBit +++ atBit +++ methodBit +++ instancesBit
where
sigs = map unLoc lsigs
@@ -559,20 +565,20 @@ ppClassDecl summary links instances fixities loc d subdocs
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-- ToDo: add assocatied typ defaults
- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual
| at <- ats
, let n = unL . fdLName $ unL at
doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
- methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)
- subfixs splice unicode qual
+ methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)
+ subfixs splice unicode pkg qual
| L _ (ClassOpSig _ _ lnames typ) <- lsigs
- , let doc = lookupAnySubdoc (head names) subdocs
- subfixs = [ f | n <- names
- , f@(n',_) <- fixities
- , n == n' ]
- names = map unLoc lnames ]
+ , name <- map unLoc lnames
+ , let doc = lookupAnySubdoc name subdocs
+ subfixs = [ f | f@(n',_) <- fixities
+ , name == n' ]
+ ]
-- N.B. taking just the first name is ok. Signatures with multiple names
-- are expanded so that each name gets its own signature.
@@ -600,38 +606,38 @@ ppClassDecl summary links instances fixities loc d subdocs
ppMinimal p (Parens x) = ppMinimal p (unLoc x)
instancesBit = ppInstances links (OriginClass nm) instances
- splice unicode qual
+ splice unicode pkg qual
-ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppInstances :: LinksInfo
-> InstOrigin DocName -> [DocInstance DocNameI]
- -> Splice -> Unicode -> Qualification
+ -> Splice -> Unicode -> Maybe Package -> Qualification
-> Html
-ppInstances links origin instances splice unicode qual
- = subInstances qual instName links True (zipWith instDecl [1..] instances)
+ppInstances links origin instances splice unicode pkg qual
+ = subInstances pkg qual instName links True (zipWith instDecl [1..] instances)
-- force Splice = True to use line URLs
where
instName = getOccString origin
instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
- instDecl no (inst, mdoc, loc) =
- ((ppInstHead links splice unicode qual mdoc origin False no inst), loc)
+ instDecl no (inst, mdoc, loc, mdl) =
+ ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc)
ppOrphanInstances :: LinksInfo
-> [DocInstance DocNameI]
- -> Splice -> Unicode -> Qualification
+ -> Splice -> Unicode -> Maybe Package -> Qualification
-> Html
-ppOrphanInstances links instances splice unicode qual
- = subOrphanInstances qual links True (zipWith instDecl [1..] instances)
+ppOrphanInstances links instances splice unicode pkg qual
+ = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances)
where
instOrigin :: InstHead name -> InstOrigin (IdP name)
instOrigin inst = OriginClass (ihdClsName inst)
instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
- instDecl no (inst, mdoc, loc) =
- ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)
+ instDecl no (inst, mdoc, loc, mdl) =
+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc)
ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
@@ -640,13 +646,14 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-> Bool -- ^ Is instance orphan
-> Int -- ^ Normal
-> InstHead DocNameI
+ -> Maybe Module
-> SubDecl
-ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
+ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl =
case ihdInstType of
ClassInst { .. } ->
( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ
, mdoc
- , [subInstDetails iid ats sigs]
+ , [subInstDetails iid ats sigs mname]
)
where
sigs = ppInstanceSigs links splice unicode qual clsiSigs
@@ -654,7 +661,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
TypeInst rhs ->
( subInstHead iid ptype
, mdoc
- , [subFamInstDetails iid prhs]
+ , [subFamInstDetails iid prhs mname]
)
where
ptype = keyword "type" <+> typ
@@ -663,11 +670,12 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
DataInst dd ->
( subInstHead iid pdata
, mdoc
- , [subFamInstDetails iid pdecl])
+ , [subFamInstDetails iid pdecl mname])
where
pdata = keyword "data" <+> typ
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
+ mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
@@ -766,12 +774,12 @@ ppDataDecl :: Bool -> LinksInfo
-> Documentation DocName -- ^ this decl's documentation
-> TyClDecl DocNameI -- ^ this decl
-> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns
- -> Splice -> Unicode -> Qualification -> Html
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
- splice unicode qual
+ splice unicode pkg qual
| summary = ppShortDataDecl summary False dataDecl pats unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
+ | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit
where
docname = tcdName dataDecl
@@ -792,14 +800,14 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
| null cons = keyword "where"
| otherwise = if isH98 then noHtml else keyword "where"
- constrBit = subConstructors qual
- [ ppSideBySideConstr subdocs subfixs unicode qual c
+ constrBit = subConstructors pkg qual
+ [ ppSideBySideConstr subdocs subfixs unicode pkg qual c
| c <- cons
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
(map unLoc (getConNames (unLoc c)))) fixities
]
- patternBit = subPatterns qual
+ patternBit = subPatterns pkg qual
[ ppSideBySidePat subfixs unicode qual lnames typ d
| (SigD _ (PatSynSig _ lnames typ), d) <- pats
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
@@ -807,7 +815,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
]
instancesBit = ppInstances links (OriginData docname) instances
- splice unicode qual
+ splice unicode pkg qual
ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html
@@ -872,10 +880,10 @@ ppShortConstrParts summary dataInst con unicode qual
-- | Pretty print an expanded constructor
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
- -> Unicode -> Qualification
+ -> Unicode -> Maybe Package -> Qualification
-> LConDecl DocNameI -- ^ constructor declaration to print
-> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L _ con)
+ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
= ( decl -- Constructor header (name, fixity)
, mbDoc -- Docs on the whole constructor
, fieldPart -- Information on the fields (or arguments, if they have docs)
@@ -949,10 +957,10 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
_ -> []
- doRecordFields fields = subFields qual
+ doRecordFields fields = subFields pkg qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
- doConstrArgsWithDocs args = subFields qual $ case con of
+ doConstrArgsWithDocs args = subFields pkg qual $ case con of
ConDeclH98{} ->
[ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
| (i, arg) <- zip [0..] args
@@ -1041,7 +1049,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
fieldPart
| not hasArgDocs = []
- | otherwise = [ subFields qual (ppSubSigLike unicode qual (unLoc patTy)
+ | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)
argDocs [] (dcolon unicode)
emptyCtxt) ]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e63667b0..ed323a90 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -73,7 +73,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"),
markupProperty = pre . toHtml,
markupExample = examplesToHtml,
- markupHeader = \(Header l t) -> makeHeader l t
+ markupHeader = \(Header l t) -> makeHeader l t,
+ markupTable = \(Table h r) -> makeTable h r
}
where
makeHeader :: Int -> Html -> Html
@@ -85,6 +86,22 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
makeHeader 6 mkup = h6 mkup
makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
+ makeTable :: [TableRow Html] -> [TableRow Html] -> Html
+ makeTable hs bs = table (concatHtml (hs' ++ bs'))
+ where
+ hs' | null hs = []
+ | otherwise = [thead (concatHtml (map (makeTableRow th) hs))]
+
+ bs' = [tbody (concatHtml (map (makeTableRow td) bs))]
+
+ makeTableRow :: (Html -> Html) -> TableRow Html -> Html
+ makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs))
+
+ makeTableCell :: (Html -> Html) -> TableCell Html -> Html
+ makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j')
+ where
+ i' = if i == 1 then [] else [ colspan i ]
+ j' = if j == 1 then [] else [ rowspan j ]
examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
@@ -154,10 +171,10 @@ flatten x = [x]
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- 'CollapsingHeader', we attach extra info to the generated 'Html'
-- that allows us to expand/collapse the content.
-hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html
-hackMarkup fmt' h' =
+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
+hackMarkup fmt' currPkg h' =
let (html, ms) = hackMarkup' fmt' h'
- in html +++ renderMeta fmt' (metaConcat ms)
+ in html +++ renderMeta fmt' currPkg (metaConcat ms)
where
hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
-> (Html, [Meta])
@@ -176,45 +193,50 @@ hackMarkup fmt' h' =
(y, m') = hackMarkup' fmt d'
in (markupAppend fmt x y, m ++ m')
-renderMeta :: DocMarkup id Html -> Meta -> Html
-renderMeta fmt (Meta { _version = Just x }) =
+renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html
+renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) =
markupParagraph fmt . markupEmphasis fmt . toHtml $
- "Since: " ++ formatVersion x
+ "Since: " ++ formatPkgMaybe pkg ++ formatVersion x
where
formatVersion v = concat . intersperse "." $ map show v
-renderMeta _ _ = noHtml
+ formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"
+ formatPkgMaybe _ = ""
+renderMeta _ _ _ = noHtml
-- | Goes through 'hackMarkup' to generate the 'Html' rather than
-- skipping straight to 'markup': this allows us to employ XHtml
-- specific hacks to the tree first.
markupHacked :: DocMarkup id Html
+ -> Maybe Package -- this package
-> Maybe String
-> MDoc id
-> Html
-markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten
+markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten
-- 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 :: Maybe String -- ^ Name of the thing this doc is for. See
- -- comments on 'toHack' for details.
+docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See
+ -- comments on 'toHack' for details.
+ -> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
-docToHtml n qual = markupHacked fmt n . cleanup
+docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
-docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
+docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
+ -> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
-docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup
+docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
-origDocToHtml :: Qualification -> MDoc Name -> Html
-origDocToHtml qual = markupHacked fmt Nothing . cleanup
+origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
+origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
where fmt = parHtmlMarkup qual True (const $ ppName Raw)
-rdrDocToHtml :: Qualification -> MDoc RdrName -> Html
-rdrDocToHtml qual = markupHacked fmt Nothing . cleanup
+rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
+rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
where fmt = parHtmlMarkup qual True (const ppRdrName)
@@ -226,14 +248,17 @@ docElement el content_ =
docSection :: Maybe Name -- ^ Name of the thing this doc is for
+ -> Maybe Package -- ^ Current package
-> Qualification -> Documentation DocName -> Html
-docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation
+docSection n pkg qual =
+ maybe noHtml (docSection_ n pkg qual) . combineDocumentation
-docSection_ :: Maybe Name -- ^ Name of the thing this doc is for
+docSection_ :: Maybe Name -- ^ Name of the thing this doc is for
+ -> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
-docSection_ n qual =
- (docElement thediv <<) . docToHtml (getOccString <$> n) qual
+docSection_ n pkg qual =
+ (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual
cleanup :: MDoc a -> MDoc a
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index e020b909..501caa4b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -47,7 +47,7 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils (makeAnchorId, nameAnchorId)
import qualified Data.Map as Map
-import Text.XHtml hiding ( name, title, p, quote )
+import Text.XHtml hiding ( name, title, quote )
import FastString ( unpackFS )
import GHC
@@ -128,38 +128,39 @@ divSubDecls cssClass captionName = maybe noHtml wrap
subCaption = paragraph ! [theclass "caption"] << captionName
-subDlist :: Qualification -> [SubDecl] -> Maybe Html
-subDlist _ [] = Nothing
-subDlist qual decls = Just $ ulist << map subEntry decls
+subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
+subDlist _ _ [] = Nothing
+subDlist pkg qual decls = Just $ ulist << map subEntry decls
where
subEntry (decl, mdoc, subs) =
li <<
(define ! [theclass "src"] << decl +++
- docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs))
+ docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs))
-subTable :: Qualification -> [SubDecl] -> Maybe Html
-subTable _ [] = Nothing
-subTable qual decls = Just $ table << aboves (concatMap subRow decls)
+subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
+subTable _ _ [] = Nothing
+subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls)
where
subRow (decl, mdoc, subs) =
(td ! [theclass "src"] << decl
<->
- docElement td << fmap (docToHtml Nothing qual) mdoc)
+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc)
: map (cell . (td <<)) subs
-- | Sub table with source information (optional).
-subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html
-subTableSrc _ _ _ [] = Nothing
-subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
+subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool
+ -> [(SubDecl,Located DocName)] -> Maybe Html
+subTableSrc _ _ _ _ [] = Nothing
+subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
where
subRow ((decl, mdoc, subs),L loc dn) =
(td ! [theclass "src clearfix"] <<
(thespan ! [theclass "inst-left"] << decl)
<+> linkHtml loc dn
<->
- docElement td << fmap (docToHtml Nothing qual) mdoc
+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc
)
: map (cell . (td <<)) subs
linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn
@@ -170,49 +171,49 @@ subBlock [] = Nothing
subBlock hs = Just $ toHtml hs
-subArguments :: Qualification -> [SubDecl] -> Html
-subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
+subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual
subAssociatedTypes :: [Html] -> Html
subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
-subConstructors :: Qualification -> [SubDecl] -> Html
-subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual
-subPatterns :: Qualification -> [SubDecl] -> Html
-subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual
-subFields :: Qualification -> [SubDecl] -> Html
-subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual
-subEquations :: Qualification -> [SubDecl] -> Html
-subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html
+subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual
-- | Generate sub table for instance declarations, with source
-subInstances :: Qualification
+subInstances :: Maybe Package -> Qualification
-> String -- ^ Class name, used for anchor generation
-> LinksInfo -> Bool
-> [(SubDecl,Located DocName)] -> Html
-subInstances qual nm lnks splice = maybe noHtml wrap . instTable
+subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
where
wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))
- instTable = subTableSrc qual lnks splice
+ instTable = subTableSrc pkg qual lnks splice
subSection = thediv ! [theclass "subs instances"]
summary = thesummary << "Instances"
id_ = makeAnchorId $ "i:" ++ nm
-subOrphanInstances :: Qualification
+subOrphanInstances :: Maybe Package -> Qualification
-> LinksInfo -> Bool
-> [(SubDecl,Located DocName)] -> Html
-subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable
+subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable
where
wrap = ((h1 << "Orphan instances") +++)
- instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice
+ instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice
id_ = makeAnchorId $ "orphans"
@@ -228,15 +229,17 @@ subInstHead iid hdr =
subInstDetails :: String -- ^ Instance unique id (for anchor generation)
-> [Html] -- ^ Associated type contents
-> [Html] -- ^ Method contents (pretty-printed signatures)
+ -> Html -- ^ Source module
-> Html
-subInstDetails iid ats mets =
- subInstSection iid << (subAssociatedTypes ats <+> subMethods mets)
+subInstDetails iid ats mets mdl =
+ subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets)
subFamInstDetails :: String -- ^ Instance unique id (for anchor generation)
-> Html -- ^ Type or data family instance
+ -> Html -- ^ Source module TODO: use this
-> Html
-subFamInstDetails iid fi =
- subInstSection iid << thediv ! [theclass "src"] << fi
+subFamInstDetails iid fi mdl =
+ subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi))
subInstSection :: String -- ^ Instance unique id (for anchor generation)
-> Html
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index a84a55e8..574045e0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -22,7 +22,7 @@ import Haddock.GhcUtils
import Haddock.Types
import Haddock.Utils
-import Text.XHtml hiding ( name, title, p, quote )
+import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
import qualified Data.List as List
@@ -147,17 +147,19 @@ linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True
linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc mdl mbName insertAnchors =
if insertAnchors
- then anchor ! [href url]
+ then anchor ! [href url, title ttl]
else id
where
+ ttl = moduleNameString (moduleName mdl)
url = case mbName of
Nothing -> moduleUrl mdl
Just name -> moduleNameUrl mdl name
linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
-linkIdOcc' mdl mbName = anchor ! [href url]
+linkIdOcc' mdl mbName = anchor ! [href url, title ttl]
where
+ ttl = moduleNameString mdl
url = case mbName of
Nothing -> moduleHtmlFile' mdl
Just name -> moduleNameUrl' mdl name