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