From 9467493f0656f06773d75f1cd633294631dff083 Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Mon, 19 Jul 2010 06:56:15 +0000 Subject: rename Haddock.Backends.Xhtml.Util to Utils --- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 2 +- src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- src/Haddock/Backends/Xhtml/Layout.hs | 2 +- src/Haddock/Backends/Xhtml/Names.hs | 2 +- src/Haddock/Backends/Xhtml/Util.hs | 216 -------------------------------- src/Haddock/Backends/Xhtml/Utils.hs | 216 ++++++++++++++++++++++++++++++++ 7 files changed, 221 insertions(+), 221 deletions(-) delete mode 100644 src/Haddock/Backends/Xhtml/Util.hs create mode 100644 src/Haddock/Backends/Xhtml/Utils.hs (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index a8e2e8e0..0359c583 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -27,7 +27,7 @@ import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Util +import Haddock.Backends.Xhtml.Utils import Haddock.ModuleTree import Haddock.Types import Haddock.Version diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index d9cd4d5d..8ebe8f6b 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -21,7 +21,7 @@ import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Util +import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 42fc39ca..cb1377dc 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,7 +19,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( ) where import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Util +import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Utils diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index ade5a266..321d2f66 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -37,7 +37,7 @@ module Haddock.Backends.Xhtml.Layout ( import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Util +import Haddock.Backends.Xhtml.Utils import Haddock.Types import Text.XHtml hiding ( name, title, p, quote ) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 59ac2a3e..5b61f63f 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Names ( linkId ) where -import Haddock.Backends.Xhtml.Util +import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Utils diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs deleted file mode 100644 index 20b246d1..00000000 --- a/src/Haddock/Backends/Xhtml/Util.hs +++ /dev/null @@ -1,216 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Util --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Util ( - renderToString, - - namedAnchor, linkedAnchor, - spliceURL, - - (<+>), char, nonEmpty, - keyword, punctuate, - - braces, brackets, pabrackets, parens, parenList, ubxParenList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, - - hsep, - - collapsebutton, collapseId, - - cssFiles, styleSheet, stylePickers, styleMenu -) where - -import Haddock.GhcUtils -import Haddock.Utils - -import Data.Maybe - -import Text.XHtml hiding ( name, title, p, quote ) -import qualified Text.XHtml as XHtml - -import GHC ( SrcSpan, srcSpanStartLine, Name ) -import Module ( Module ) -import Name ( getOccString, nameOccName, isValOcc ) - - -spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> - Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url - where - file = fromMaybe "" maybe_file - mdl = case maybe_mod of - Nothing -> "" - Just m -> moduleString m - - (name, kind) = - case maybe_name of - Nothing -> ("","") - Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") - | otherwise -> (escapeStr (getOccString n), "t") - - line = case maybe_loc of - Nothing -> "" - Just span_ -> show $ srcSpanStartLine span_ - - run "" = "" - run ('%':'M':rest) = mdl ++ run rest - run ('%':'F':rest) = file ++ run rest - run ('%':'N':rest) = name ++ run rest - run ('%':'K':rest) = kind ++ run rest - run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = "%" ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest - run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest - run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest - run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = - map (\x -> if x == '.' then c else x) mdl ++ run rest - - run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = - map (\x -> if x == '/' then c else x) file ++ run rest - - run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest - - run (c:rest) = c : run rest - - -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) -nonEmpty :: (HTML a) => a -> Html -nonEmpty a = if isNoHtml h then spaceHtml else h - where h = toHtml a - - -quote :: Html -> Html -quote h = char '`' +++ h +++ '`' - - -parens, brackets, pabrackets, braces :: Html -> Html -parens h = char '(' +++ h +++ char ')' -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 - where - 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 "#)" - - -onclick :: String -> HtmlAttr -onclick = strAttr "onclick" - - -dcolon, arrow, darrow, forallSymbol :: Bool -> Html -dcolon unicode = toHtml (if unicode then "∷" else "::") -arrow unicode = toHtml (if unicode then "→" else "->") -darrow unicode = toHtml (if unicode then "⇒" else "=>") -forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" - - -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. --- - --- TODO: Currently the initial state is non-collapsed. Change the 'minusFile' --- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we --- use cookies from JavaScript to have a more persistent state. - -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 -collapseId nm = "i:" ++ escapeStr (getOccString nm) - - --- Standard set of style sheets, first is the preferred -cssThemes :: [(String, String)] -cssThemes = [ - ("Classic", "xhaddock.css"), - ("Tibbe", "thaddock.css"), - ("Snappy", "shaddock.css") - ] - -cssFiles :: [String] -cssFiles = map snd cssThemes - -styleSheet :: Html -styleSheet = toHtml $ zipWith mkLink cssThemes rels - where - rels = ("stylesheet" : repeat "alternate stylesheet") - mkLink (aTitle, aFile) aRel = - (thelink ! [href aFile, rel aRel, thetype "text/css", XHtml.title aTitle]) noHtml - -stylePickers :: [Html] -stylePickers = map mkPicker cssThemes - where - mkPicker (aTitle, aFile) = - 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", - unordList stylePickers ! [ identifier "style-menu", theclass "hide" ] - ] - where - js = "styleMenu(); return false;" - \ No newline at end of file diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs new file mode 100644 index 00000000..30e0cc09 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -0,0 +1,216 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Util +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Utils ( + renderToString, + + namedAnchor, linkedAnchor, + spliceURL, + + (<+>), char, nonEmpty, + keyword, punctuate, + + braces, brackets, pabrackets, parens, parenList, ubxParenList, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + + hsep, + + collapsebutton, collapseId, + + cssFiles, styleSheet, stylePickers, styleMenu +) where + +import Haddock.GhcUtils +import Haddock.Utils + +import Data.Maybe + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as XHtml + +import GHC ( SrcSpan, srcSpanStartLine, Name ) +import Module ( Module ) +import Name ( getOccString, nameOccName, isValOcc ) + + +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url + where + file = fromMaybe "" maybe_file + mdl = case maybe_mod of + Nothing -> "" + Just m -> moduleString m + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + line = case maybe_loc of + Nothing -> "" + Just span_ -> show $ srcSpanStartLine span_ + + run "" = "" + run ('%':'M':rest) = mdl ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + run ('%':'L':rest) = line ++ run rest + run ('%':'%':rest) = "%" ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest + run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest + run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest + run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = + map (\x -> if x == '.' then c else x) mdl ++ run rest + + run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = + map (\x -> if x == '/' then c else x) file ++ run rest + + run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest + + run (c:rest) = c : run rest + + +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) +nonEmpty :: (HTML a) => a -> Html +nonEmpty a = if isNoHtml h then spaceHtml else h + where h = toHtml a + + +quote :: Html -> Html +quote h = char '`' +++ h +++ '`' + + +parens, brackets, pabrackets, braces :: Html -> Html +parens h = char '(' +++ h +++ char ')' +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 + where + 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 "#)" + + +onclick :: String -> HtmlAttr +onclick = strAttr "onclick" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon unicode = toHtml (if unicode then "∷" else "::") +arrow unicode = toHtml (if unicode then "→" else "->") +darrow unicode = toHtml (if unicode then "⇒" else "=>") +forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" + + +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. +-- + +-- TODO: Currently the initial state is non-collapsed. Change the 'minusFile' +-- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we +-- use cookies from JavaScript to have a more persistent state. + +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 +collapseId nm = "i:" ++ escapeStr (getOccString nm) + + +-- Standard set of style sheets, first is the preferred +cssThemes :: [(String, String)] +cssThemes = [ + ("Classic", "xhaddock.css"), + ("Tibbe", "thaddock.css"), + ("Snappy", "shaddock.css") + ] + +cssFiles :: [String] +cssFiles = map snd cssThemes + +styleSheet :: Html +styleSheet = toHtml $ zipWith mkLink cssThemes rels + where + rels = ("stylesheet" : repeat "alternate stylesheet") + mkLink (aTitle, aFile) aRel = + (thelink ! [href aFile, rel aRel, thetype "text/css", XHtml.title aTitle]) noHtml + +stylePickers :: [Html] +stylePickers = map mkPicker cssThemes + where + mkPicker (aTitle, aFile) = + 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", + unordList stylePickers ! [ identifier "style-menu", theclass "hide" ] + ] + where + js = "styleMenu(); return false;" + \ No newline at end of file -- cgit v1.2.3