diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 5 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 8 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 152 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 11 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Meta.hs | 2 |
8 files changed, 130 insertions, 59 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 221580cc..582c535d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -353,7 +353,7 @@ markupTag dflags = Markup { markupMathInline = const $ str "<math>", markupMathDisplay = const $ str "<math>", markupUnorderedList = box (TagL 'u'), - markupOrderedList = box (TagL 'o'), + markupOrderedList = box (TagL 'o') . map snd, markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel), diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index d77990d1..7fa5a443 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -142,8 +141,8 @@ richToken srcs details Token{..} contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details - -- pick an arbitary non-evidence identifier to hyperlink with - identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details + -- pick an arbitrary non-evidence identifier to hyperlink with + identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details notEvidence = not . any isEvidenceContext . identInfo -- If we have name information, we can make links diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 349c6e8e..faa23d6a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1265,7 +1265,7 @@ latexMarkup = Markup , markupPic = \p _ -> inlineElem (markupPic p) , markupMathInline = \p _ -> inlineElem (markupMathInline p) , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) - , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p)) , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) @@ -1301,7 +1301,7 @@ latexMarkup = Markup Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) - -- Is there a better way of doing this? Just a space is an aribtrary choice. + -- Is there a better way of doing this? Just a space is an arbitrary choice. markupPic (Picture uri title) = parens (imageText title) where imageText Nothing = beg @@ -1333,7 +1333,7 @@ rdrDocToLaTeX doc = markup latexMarkup doc Plain empty data StringContext = Plain -- ^ all special characters have to be escape - | Mono -- ^ on top of special characters, escape space chraacters + | Mono -- ^ on top of special characters, escape space characters | Verb -- ^ don't escape anything @@ -1394,7 +1394,7 @@ bold ltx = text "\\textbf" <> braces ltx -- TODO: @verbatim@ is too much since -- --- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX +-- * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX -- representing that markup gets printed verbatim -- * Verbatim environments are not supported everywhere (example: not nested -- inside a @tabulary@ environment) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index b7674b24..4cc6aa77 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -28,7 +28,9 @@ import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Themes import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils +import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo) import Haddock.ModuleTree +import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Version import Haddock.Utils @@ -78,6 +80,7 @@ ppHtml :: UnitState -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) -> Maybe String -- ^ Package name + -> PackageInfo -- ^ Package info -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> Bool -- ^ Also write Quickjump index @@ -86,7 +89,7 @@ ppHtml :: UnitState ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url maybe_contents_url maybe_index_url unicode - pkg qual debug withQuickjump = do + pkg packageInfo qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -94,13 +97,20 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue when (isNothing maybe_contents_url) $ ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces ++ reexported_ifaces) + withQuickjump + [PackageInterfaces + { piPackageInfo = packageInfo + , piVisibility = Visible + , piInstalledInterfaces = map toInstalledIface visible_ifaces + ++ reexported_ifaces + }] False -- we don't want to display the packages in a single-package contents prologue debug pkg (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url + withQuickjump (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug when withQuickjump $ @@ -109,7 +119,8 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url - maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces + maybe_contents_url maybe_index_url withQuickjump + unicode pkg qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () @@ -155,6 +166,15 @@ headHtml docTitle themes mathjax_url base_url = , "}" , "});" ] +quickJumpButtonLi :: Bool -- ^ With Quick Jump? + -> Maybe Html +-- The TypeScript should replace this <li> element, given its id. However, in +-- case it does not, the element is given content here too. +quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"] + << anchor ! [href "#"] << "Quick Jump" + +quickJumpButtonLi False = Nothing + srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = Just (anchor ! [href src_base_url] << "Source") @@ -193,20 +213,18 @@ indexButton maybe_index_url bodyHtml :: String -> Maybe Interface -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String + -> Bool -- ^ With Quick Jump? -> Html -> Html bodyHtml doctitle iface maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url + withQuickjump pageContent = body << [ divPackageHeader << [ nonEmptySectionName << doctitle, - unordList (catMaybes [ - srcButton maybe_source_url iface, - wikiButton maybe_wiki_url (ifaceMod <$> iface), - contentsButton maybe_contents_url, - indexButton maybe_index_url]) - ! [theclass "links", identifier "page-menu"] + ulist ! [theclass "links", identifier "page-menu"] + << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis) ], divContent << pageContent, divFooter << paragraph << ( @@ -215,6 +233,13 @@ bodyHtml doctitle iface (" version " ++ projectVersion) ) ] + where + otherButtonLis = (fmap . fmap) (li <<) + [ srcButton maybe_source_url iface + , wikiButton maybe_wiki_url (ifaceMod <$> iface) + , contentsButton maybe_contents_url + , indexButton maybe_index_url + ] moduleInfo :: Interface -> Html moduleInfo iface = @@ -277,30 +302,44 @@ ppHtmlContents -> Maybe String -> SourceURLs -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) + -> Bool -- ^ With Quick Jump? + -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents state odir doctitle _maybe_package themes mathjax_url maybe_index_url - maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do - let tree = mkModuleTree state showPkgs - [(instMod iface, toInstalledDescription iface) - | iface <- ifaces - , not (instIsSig iface)] - sig_tree = mkModuleTree state showPkgs - [(instMod iface, toInstalledDescription iface) - | iface <- ifaces - , instIsSig iface] + maybe_source_url maybe_wiki_url withQuickjump + packages showPkgs prologue debug pkg qual = do + let trees = + [ ( piPackageInfo pinfo + , mkModuleTree state showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- piInstalledInterfaces pinfo + , not (instIsSig iface) + ] + ) + | pinfo <- packages + ] + sig_trees = + [ ( piPackageInfo pinfo + , mkModuleTree state showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- piInstalledInterfaces pinfo + , instIsSig iface + ] + ) + | pinfo <- packages + ] html = headHtml doctitle themes mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url - Nothing maybe_index_url << [ + Nothing maybe_index_url withQuickjump << [ ppPrologue pkg qual doctitle prologue, - ppSignatureTree pkg qual sig_tree, - ppModuleTree pkg qual tree + ppSignatureTrees pkg qual sig_trees, + ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) @@ -315,17 +354,37 @@ ppPrologue _ _ _ Nothing = noHtml ppPrologue pkg qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) - -ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html -ppSignatureTree _ _ [] = mempty -ppSignatureTree pkg qual ts = - divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) - - -ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html -ppModuleTree _ _ [] = mempty -ppModuleTree pkg qual ts = - divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts) +ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html +ppSignatureTrees _ _ tss | all (null . snd) tss = mempty +ppSignatureTrees pkg qual [(info, ts)] = + divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) +ppSignatureTrees pkg qual tss = + divModuleList << + (sectionName << "Signatures" + +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts + | (i, (info, ts)) <- zip [(1::Int)..] tss + ]) + +ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html +ppSignatureTree _ _ _ _ [] = mempty +ppSignatureTree pkg qual p info ts = + divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) + +ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html +ppModuleTrees _ _ tss | all (null . snd) tss = mempty +ppModuleTrees pkg qual [(info, ts)] = + divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts) +ppModuleTrees pkg qual tss = + divPackageList << + (sectionName << "Packages" + +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts + | (i, (info, ts)) <- zip [(1::Int)..] tss + ]) + +ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html +ppModuleTree _ _ _ _ [] = mempty +ppModuleTree pkg qual p info ts = + divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html @@ -418,11 +477,16 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins (errors, installedIndexes) <- partitionEithers <$> traverse - (\ifaceFile -> + (\ifaceFile -> do let indexFile = takeDirectory ifaceFile - FilePath.</> "doc-index.json" in - bimap (indexFile,) (map (fixLink ifaceFile)) - <$> eitherDecodeFile @[JsonIndexEntry] indexFile) + FilePath.</> "doc-index.json" + a <- doesFileExist indexFile + if a then + bimap (indexFile,) (map (fixLink ifaceFile)) + <$> eitherDecodeFile @[JsonIndexEntry] indexFile + else + return (Right []) + ) installedIfacesPaths traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err) errors @@ -486,11 +550,12 @@ ppHtmlIndex :: FilePath -> Maybe String -> SourceURLs -> WikiURLs + -> Bool -- ^ With Quick Jump? -> [InstalledInterface] -> Bool -> IO () ppHtmlIndex odir doctitle _maybe_package themes - maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do let html = indexPage split_indices Nothing (if split_indices then [] else index) @@ -509,7 +574,7 @@ ppHtmlIndex odir doctitle _maybe_package themes headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url - maybe_contents_url Nothing << [ + maybe_contents_url Nothing withQuickjump << [ if showLetters then indexInitialLetterLinks else noHtml, if null items then noHtml else divIndex << [sectionName << indexName ch, buildIndex items] @@ -607,11 +672,14 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL - -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption + -> Maybe String -> Maybe String + -> Bool -- ^ With Quick Jump? + -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url - maybe_contents_url maybe_index_url unicode pkg qual debug iface = do + maybe_contents_url maybe_index_url withQuickjump + unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface @@ -631,7 +699,7 @@ ppHtmlModule odir doctitle themes headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url << [ + maybe_contents_url maybe_index_url withQuickjump << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a54bb0aa..3dea1012 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -727,7 +727,7 @@ ppInstanceSigs links splice unicode qual sigs = do L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index b8f5ac0f..91a5b120 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -46,7 +46,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \(ModLink m lbl) -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style + -- Accommodate for old style -- foo\#bar anchors mdl' = case reverse mdl of '\\':_ -> init mdl @@ -57,7 +57,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupBold = strong, markupMonospaced = thecode, markupUnorderedList = unordList, - markupOrderedList = ordList, + markupOrderedList = makeOrdList, markupDefList = defList, markupCodeBlock = pre, markupHyperlink = \(Hyperlink url mLabel) @@ -112,9 +112,12 @@ parHtmlMarkup qual insertAnchors ppId = Markup { htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + makeOrdList :: HTML a => [(Int, a)] -> Html + makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items + -- | We use this intermediate type to transform the input 'Doc' tree -- in an arbitrary way before rendering, such as grouping some --- elements. This is effectivelly a hack to prevent the 'Doc' type +-- elements. This is effectively a hack to prevent the 'Doc' type -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id = @@ -277,5 +280,5 @@ cleanup = overDoc (markup fmtUnParagraphLists) fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, - markupOrderedList = DocOrderedList . map unParagraph + markupOrderedList = DocOrderedList . map (\(index, a) -> (index, unParagraph a)) } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 8f04a21f..575249ad 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.Layout ( divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList, divContentsList, + divIndex, divAlphabet, divPackageList, divModuleList, divContentsList, sectionName, nonEmptySectionName, @@ -81,7 +81,7 @@ nonEmptySectionName c divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList, divContentsList + divIndex, divAlphabet, divPackageList, divModuleList, divContentsList :: Html -> Html divPackageHeader = sectionDiv "package-header" @@ -96,6 +96,7 @@ divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" divModuleList = sectionDiv "module-list" +divPackageList = sectionDiv "module-list" -------------------------------------------------------------------------------- @@ -219,7 +220,7 @@ subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice - id_ = makeAnchorId $ "orphans" + id_ = makeAnchorId "orphans" subInstHead :: String -- ^ Instance unique id (for anchor generation) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs index 621bdd41..540885ac 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs @@ -14,7 +14,7 @@ quickjumpVersion = 1 -- | Writes a json encoded file containing additional -- information about the generated documentation. This --- is useful for external tools (e.g. hackage). +-- is useful for external tools (e.g., Hackage). writeHaddockMeta :: FilePath -> Bool -> IO () writeHaddockMeta odir withQuickjump = do let |