From 25013f63b6df88db06c8ee126686dbfe4655cd5c Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 21 Jul 2010 14:17:32 +0000 Subject: More style police --- src/Haddock/Backends/Xhtml/Names.hs | 10 +++++++++- src/Haddock/Backends/Xhtml/Types.hs | 1 + src/Haddock/Backends/Xhtml/Utils.hs | 21 +++++++++++++++++++-- 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 0c7df9a8..068fc0f7 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -17,6 +17,7 @@ module Haddock.Backends.Xhtml.Names ( linkId ) where + import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types @@ -28,21 +29,26 @@ import GHC import Name import RdrName + ppOccName :: OccName -> Html ppOccName = toHtml . occNameString + ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc + ppLDocName :: Located DocName -> Html ppLDocName (L _ d) = ppDocName d + ppDocName :: DocName -> Html ppDocName (Documented name mdl) = linkIdOcc mdl (Just occName) << ppOccName occName where occName = nameOccName name ppDocName (Undocumented name) = toHtml (getOccString name) + ppName :: Name -> Html ppName name = toHtml (getOccString name) @@ -72,13 +78,15 @@ linkIdOcc mdl mbName = anchor ! [href url] Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name + ppModule :: Module -> Html ppModule mdl = anchor ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) + ppModuleRef :: Module -> String -> Html ppModuleRef mdl ref = anchor ! [href (moduleUrl mdl ++ ref)] << toHtml (moduleString mdl) - -- NB: The ref paramaeter already includes the '#'. + -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used. diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs index aff47131..4e23f469 100644 --- a/src/Haddock/Backends/Xhtml/Types.hs +++ b/src/Haddock/Backends/Xhtml/Types.hs @@ -20,5 +20,6 @@ module Haddock.Backends.Xhtml.Types ( type SourceURLs = (Maybe String, Maybe String, Maybe String) type WikiURLs = (Maybe String, Maybe String, Maybe String) + -- The URL for source and wiki links, and the current module type LinksInfo = (SourceURLs, WikiURLs) diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index 78754138..443cb459 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Utils ( cssFiles, styleSheet, stylePickers, styleMenu ) where + import Haddock.GhcUtils import Haddock.Utils @@ -89,25 +90,31 @@ renderToString :: Html -> String renderToString = showHtml -- for production --renderToString = prettyHtml -- for debugging + hsep :: [Html] -> Html hsep [] = noHtml hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + infixr 8 <+> (<+>) :: Html -> Html -> Html a <+> b = a +++ toHtml " " +++ b + keyword :: String -> Html keyword s = thespan ! [theclass "keyword"] << toHtml s + equals, comma :: Html equals = char '=' comma = char ',' + char :: Char -> Html char c = toHtml [c] --- | ensure content contains at least something (a non-breaking space) + +-- | Ensure content contains at least something (a non-breaking space) nonEmpty :: (HTML a) => a -> Html nonEmpty a = if isNoHtml h then spaceHtml else h where h = toHtml a @@ -123,6 +130,7 @@ brackets h = char '[' +++ h +++ char ']' pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" braces h = char '{' +++ h +++ char '}' + punctuate :: Html -> [Html] -> [Html] punctuate _ [] = [] punctuate h (d0:ds) = go d0 ds @@ -130,12 +138,15 @@ punctuate h (d0:ds) = go d0 ds go d [] = [d] go d (e:es) = (d +++ h) : go e es + parenList :: [Html] -> Html parenList = parens . hsep . punctuate comma + ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma + ubxparens :: Html -> Html ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" @@ -155,14 +166,15 @@ dot :: Html dot = toHtml "." - -- | Generate a named anchor namedAnchor :: String -> Html -> Html namedAnchor n = anchor ! [XHtml.name n] + linkedAnchor :: String -> Html -> Html linkedAnchor n = anchor ! [href ('#':n)] + -- -- A section of HTML which is collapsible via a +/- button. -- @@ -175,6 +187,7 @@ collapsebutton :: String -> Html collapsebutton id_ = image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] + -- A quote is a valid part of a Haskell identifier, but it would interfere with -- the ECMA script string delimiter used in collapsebutton above. collapseId :: Name -> String @@ -189,9 +202,11 @@ cssThemes = [ ("Snappy", "shaddock.css") ] + cssFiles :: [String] cssFiles = map snd cssThemes + styleSheet :: Html styleSheet = toHtml $ zipWith mkLink cssThemes rels where @@ -199,6 +214,7 @@ styleSheet = toHtml $ zipWith mkLink cssThemes rels mkLink (aTitle, aFile) aRel = (thelink ! [href aFile, rel aRel, thetype "text/css", XHtml.title aTitle]) noHtml + stylePickers :: [Html] stylePickers = map mkPicker cssThemes where @@ -206,6 +222,7 @@ stylePickers = map mkPicker cssThemes let js = "setActiveStyleSheet('" ++ aFile ++ "'); return false;" in anchor ! [href "#", onclick js] << aTitle + styleMenu :: Html styleMenu = thediv ! [identifier "style-menu-holder"] << [ anchor ! [ href "#", onclick js ] << "Style\9662", -- cgit v1.2.3