1----------------------------------------------------------------------------- 2-- | 3-- Module : Haddock.Backends.Html.Util 4-- Copyright : (c) Simon Marlow 2003-2006, 5-- David Waern 2006-2009, 6-- Mark Lentczner 2010 7-- License : BSD-like 8-- 9-- Maintainer : haddock@projects.haskell.org 10-- Stability : experimental 11-- Portability : portable 12----------------------------------------------------------------------------- 13module Haddock.Backends.Xhtml.Utils ( 14 renderToString, 15 16 namedAnchor, linkedAnchor, 17 spliceURL, spliceURL', 18 groupId, 19 20 (<+>), (<=>), char, 21 keyword, punctuate, 22 23 braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, 24 arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, 25 atSign, 26 27 hsep, vcat, 28 29 DetailsState(..), collapseDetails, thesummary, 30 collapseToggle, collapseControl, 31) where 32 33 34import Haddock.Utils 35 36import Data.Maybe 37 38import Text.XHtml hiding ( name, title, p, quote ) 39import qualified Text.XHtml as XHtml 40 41import GHC ( SrcSpan(..), srcSpanStartLine, Name ) 42import Module ( Module, ModuleName, moduleName, moduleNameString ) 43import Name ( getOccString, nameOccName, isValOcc ) 44 45 46-- | Replace placeholder string elements with provided values. 47-- 48-- Used to generate URL for customized external paths, usually provided with 49-- @--source-module@, @--source-entity@ and related command-line arguments. 50-- 51-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}" 52-- "output/Foo.hs#foo" 53spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> 54 Maybe SrcSpan -> String -> String 55spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) 56 57 58-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'. 59spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> 60 Maybe SrcSpan -> String -> String 61spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run 62 where 63 file = fromMaybe "" maybe_file 64 mdl = case maybe_mod of 65 Nothing -> "" 66 Just m -> moduleNameString m 67 68 (name, kind) = 69 case maybe_name of 70 Nothing -> ("","") 71 Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") 72 | otherwise -> (escapeStr (getOccString n), "t") 73 74 line = case maybe_loc of 75 Nothing -> "" 76 Just span_ -> 77 case span_ of 78 RealSrcSpan span__ -> 79 show $ srcSpanStartLine span__ 80 UnhelpfulSpan _ -> "" 81 82 run "" = "" 83 run ('%':'M':rest) = mdl ++ run rest 84 run ('%':'F':rest) = file ++ run rest 85 run ('%':'N':rest) = name ++ run rest 86 run ('%':'K':rest) = kind ++ run rest 87 run ('%':'L':rest) = line ++ run rest 88 run ('%':'%':rest) = '%' : run rest 89 90 run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest 91 run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest 92 run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest 93 run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest 94 95 run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = 96 map (\x -> if x == '.' then c else x) mdl ++ run rest 97 98 run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = 99 map (\x -> if x == '/' then c else x) file ++ run rest 100 101 run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest 102 103 run (c:rest) = c : run rest 104 105 106renderToString :: Bool -> Html -> String 107renderToString debug html 108 | debug = renderHtml html 109 | otherwise = showHtml html 110 111 112hsep :: [Html] -> Html 113hsep [] = noHtml 114hsep htmls = foldr1 (<+>) htmls 115 116-- | Concatenate a series of 'Html' values vertically, with linebreaks in between. 117vcat :: [Html] -> Html 118vcat [] = noHtml 119vcat htmls = foldr1 (\a b -> a+++br+++b) htmls 120 121 122infixr 8 <+> 123(<+>) :: Html -> Html -> Html 124a <+> b = a +++ sep +++ b 125 where 126 sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " 127 128-- | Join two 'Html' values together with a linebreak in between. 129-- Has 'noHtml' as left identity. 130infixr 8 <=> 131(<=>) :: Html -> Html -> Html 132a <=> b = a +++ sep +++ b 133 where 134 sep = if isNoHtml a then noHtml else br 135 136 137keyword :: String -> Html 138keyword s = thespan ! [theclass "keyword"] << toHtml s 139 140 141equals, comma :: Html 142equals = char '=' 143comma = char ',' 144 145 146char :: Char -> Html 147char c = toHtml [c] 148 149 150quote :: Html -> Html 151quote h = char '`' +++ h +++ '`' 152 153 154-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@). 155promoQuote :: Html -> Html 156promoQuote h = char '\'' +++ h 157 158 159parens, brackets, pabrackets, braces :: Html -> Html 160parens h = char '(' +++ h +++ char ')' 161brackets h = char '[' +++ h +++ char ']' 162pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" 163braces h = char '{' +++ h +++ char '}' 164 165 166punctuate :: Html -> [Html] -> [Html] 167punctuate _ [] = [] 168punctuate h (d0:ds) = go d0 ds 169 where 170 go d [] = [d] 171 go d (e:es) = (d +++ h) : go e es 172 173 174parenList :: [Html] -> Html 175parenList = parens . hsep . punctuate comma 176 177 178ubxParenList :: [Html] -> Html 179ubxParenList = ubxparens . hsep . punctuate comma 180 181 182ubxSumList :: [Html] -> Html 183ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") 184 185 186ubxparens :: Html -> Html 187ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" 188 189 190dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html 191dcolon unicode = toHtml (if unicode then "∷" else "::") 192arrow unicode = toHtml (if unicode then "→" else "->") 193darrow unicode = toHtml (if unicode then "⇒" else "=>") 194forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" 195atSign unicode = toHtml (if unicode then "@" else "@") 196 197dot :: Html 198dot = toHtml "." 199 200 201-- | Generate a named anchor 202namedAnchor :: String -> Html -> Html 203namedAnchor n = anchor ! [XHtml.identifier n] 204 205 206linkedAnchor :: String -> Html -> Html 207linkedAnchor n = anchor ! [href ('#':n)] 208 209 210-- | generate an anchor identifier for a group 211groupId :: String -> String 212groupId g = makeAnchorId ("g:" ++ g) 213 214-- 215-- A section of HTML which is collapsible. 216-- 217 218data DetailsState = DetailsOpen | DetailsClosed 219 220collapseDetails :: String -> DetailsState -> Html -> Html 221collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) 222 where openAttrs = case state of { DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] } 223 224thesummary :: Html -> Html 225thesummary = tag "summary" 226 227-- | Attributes for an area that toggles a collapsed area 228collapseToggle :: String -> String -> [HtmlAttr] 229collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] 230 where cs = unwords (words classes ++ ["details-toggle"]) 231 232-- | Attributes for an area that toggles a collapsed area, 233-- and displays a control. 234collapseControl :: String -> String -> [HtmlAttr] 235collapseControl id_ classes = collapseToggle id_ cs 236 where cs = unwords (words classes ++ ["details-toggle-control"]) 237