]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/HTML5.hs
Add golden tests.
[doclang.git] / Language / DTC / Write / HTML5.hs
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeApplications #-}
8 {-# LANGUAGE ViewPatterns #-}
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 module Language.DTC.Write.HTML5 where
11
12 -- import Control.Monad.Trans.Class (MonadTrans(..))
13 -- import Data.Functor.Identity (Identity(..))
14 -- import Data.Sequence (Seq)
15 -- import Data.Set (Set)
16 -- import Data.Traversable (Traversable(..))
17 -- import qualified Data.Sequence as Seq
18 -- import qualified Data.TreeSeq.Strict as Tree
19 import Control.Applicative (Applicative(..))
20 import Control.Category
21 import Control.Monad
22 import Data.Bool
23 import Data.Char (Char)
24 import Data.Default.Class (Default(..))
25 import Data.Foldable (Foldable(..), concat)
26 import Data.Function (($), const, flip, on)
27 import Data.Functor (Functor(..), (<$>))
28 import Data.Functor.Compose (Compose(..))
29 import Data.Int (Int)
30 import Data.Map.Strict (Map)
31 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
32 import Data.Monoid (Monoid(..))
33 import Data.Ord (Ord(..))
34 import Data.Semigroup (Semigroup(..))
35 import Data.String (String)
36 import Data.Text (Text)
37 import Data.TreeSeq.Strict (Tree(..), Trees)
38 import Data.Tuple (snd)
39 import System.FilePath (FilePath)
40 import Text.Blaze ((!))
41 import Text.Blaze.Html (Html)
42 import Text.Show (Show(..))
43 import qualified Control.Monad.Trans.State as S
44 import qualified Data.Char as Char
45 import qualified Data.List as List
46 import qualified Data.Map.Strict as Map
47 import qualified Data.Sequence as Seq
48 import qualified Data.Strict.Maybe as Strict
49 import qualified Data.Text as Text
50 import qualified Data.Text.Lazy as TL
51 import qualified Data.TreeMap.Strict as TreeMap
52 import qualified Data.TreeSeq.Strict as Tree
53 import qualified Data.TreeSeq.Strict.Zipper as Tree
54 import qualified Text.Blaze.Html5 as H
55 import qualified Text.Blaze.Html5.Attributes as HA
56 import qualified Text.Blaze.Internal as H
57
58 import Text.Blaze.Utils
59 import Data.Locale hiding (localize, Index)
60 import qualified Data.Locale as Locale
61
62 import Language.DTC.Write.XML ()
63 import Language.DTC.Write.Plain (Plain, Plainify(..))
64 import qualified Language.DTC.Write.Plain as Plain
65 import qualified Language.DTC.Document as DTC
66 import qualified Language.DTC.Anchor as Anchor
67
68 (<&>) :: Functor f => f a -> (a -> b) -> f b
69 (<&>) = flip (<$>)
70 infixl 4 <&>
71
72 -- * Type 'Html5'
73 type Html5 = StateMarkup State ()
74
75 -- * Type 'State'
76 data State
77 = State
78 { state_styles :: Map FilePath CSS
79 , state_scripts :: Map FilePath Script
80 , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
81 , state_rrefs :: Anchor.Rrefs
82 , state_figures :: Map Text (Map DTC.Pos (Maybe DTC.Title))
83 , state_references :: Map DTC.Ident DTC.About
84 , state_notes :: Anchor.Notes
85 , state_plainify :: Plain.State
86 }
87 instance Default State where
88 def = State
89 { state_styles = mempty
90 , state_scripts = mempty
91 , state_indexs = mempty
92 , state_rrefs = mempty
93 , state_figures = mempty
94 , state_references = mempty
95 , state_notes = mempty
96 , state_plainify = def
97 }
98 type CSS = Text
99 type Script = Text
100
101 -- * Type 'Keys'
102 data Keys
103 = Keys
104 { keys_index :: Map DTC.Pos DTC.Terms
105 , keys_figure :: Map Text (Map DTC.Pos (Maybe DTC.Title))
106 , keys_reference :: Map DTC.Ident DTC.About
107 } deriving (Show)
108 instance Default Keys where
109 def = Keys mempty mempty mempty
110
111 -- ** Class 'KeysOf'
112 class KeysOf a where
113 keys :: a -> S.State Keys ()
114 instance KeysOf (Trees DTC.BodyKey DTC.BodyValue) where
115 keys = mapM_ keys
116 instance KeysOf (Tree DTC.BodyKey DTC.BodyValue) where
117 keys = \case
118 TreeN k ts ->
119 case k of
120 DTC.Section{..} ->
121 keys ts
122 Tree0 v ->
123 case v of
124 DTC.Index{..} ->
125 S.modify $ \s -> s{keys_index=
126 Map.insert pos terms $ keys_index s}
127 DTC.Figure{..} ->
128 S.modify $ \s -> s{keys_figure=
129 Map.insertWith (<>)
130 type_ (Map.singleton pos title) $
131 keys_figure s}
132 DTC.References{..} ->
133 S.modify $ \s -> s{keys_reference=
134 foldr
135 (\r -> Map.insert
136 (DTC.id (r::DTC.Reference))
137 (DTC.about (r::DTC.Reference)))
138 (keys_reference s)
139 refs}
140 DTC.ToC{} -> return ()
141 DTC.ToF{} -> return ()
142 DTC.Block{} -> return ()
143
144 -- * Class 'Html5ify'
145 class Html5ify a where
146 html5ify :: a -> Html5
147 instance Html5ify Char where
148 html5ify = html5ify . H.toMarkup
149 instance Html5ify Text where
150 html5ify = html5ify . H.toMarkup
151 instance Html5ify TL.Text where
152 html5ify = html5ify . H.toMarkup
153 instance Html5ify String where
154 html5ify = html5ify . H.toMarkup
155 instance Html5ify H.Markup where
156 html5ify = Compose . return
157 instance Html5ify DTC.Title where
158 html5ify (DTC.Title t) = html5ify t
159 instance Html5ify DTC.Para where
160 html5ify = mapM_ html5ify
161 instance Html5ify DTC.Ident where
162 html5ify (DTC.Ident i) = html5ify i
163 instance Html5ify Int where
164 html5ify = html5ify . show
165 instance Html5ify DTC.Nat where
166 html5ify (DTC.Nat n) = html5ify n
167 instance Html5ify DTC.Nat1 where
168 html5ify (DTC.Nat1 n) = html5ify n
169
170 html5Document ::
171 Localize ls Plain Plain.L10n =>
172 Locales ls =>
173 LocaleIn ls -> DTC.Document -> Html
174 html5Document locale DTC.Document{..} = do
175 let Keys{..} = keys body `S.execState` def
176 let (body',state_rrefs,state_notes,state_indexs) =
177 let irefs = foldMap Anchor.irefsOfTerms keys_index in
178 let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) =
179 Anchor.anchorify body `S.runState`
180 def{Anchor.state_irefs=irefs} in
181 (body0,rrefs,notes,) $
182 (<$> keys_index) $ \terms ->
183 (terms,) $
184 TreeMap.intersection const state_irefs $
185 Anchor.irefsOfTerms terms
186 let state_plainify = def
187 { Plain.state_localize = Locale.localize locale }
188 let (html5Body, State{state_styles,state_scripts}) =
189 runStateMarkup def
190 { state_indexs
191 , state_rrefs
192 , state_notes
193 , state_figures = keys_figure
194 , state_references = keys_reference
195 , state_plainify
196 } $ html5ify body'
197
198 H.docType
199 H.html ! HA.lang (attrify $ countryCode locale) $ do
200 H.head $ do
201 H.meta ! HA.httpEquiv "Content-Type"
202 ! HA.content "text/html; charset=UTF-8"
203 whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
204 H.title $
205 H.toMarkup $ Plain.text state_plainify $ List.head ts
206 forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} ->
207 H.link ! HA.rel (attrify rel)
208 ! HA.href (attrify href)
209 H.meta ! HA.name "generator"
210 ! HA.content "tct"
211 let chapters =
212 (`mapMaybe` toList body) $ \case
213 TreeN k@DTC.Section{} _ -> Just k
214 _ -> Nothing
215 forM_ chapters $ \DTC.Section{..} ->
216 H.link ! HA.rel "Chapter"
217 ! HA.title (attrify $ plainify title)
218 ! HA.href ("#"<>attrify pos)
219 H.link ! HA.rel "stylesheet"
220 ! HA.type_ "text/css"
221 ! HA.href "style/dtc-html5.css"
222 forM_ state_styles $ \style ->
223 H.style ! HA.type_ "text/css" $
224 H.toMarkup style
225 forM_ state_scripts $ \script ->
226 H.script ! HA.type_ "application/javascript" $
227 H.toMarkup script
228 H.body
229 html5Body
230
231 -- * Type 'BodyCursor'
232 -- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
233 type BodyCursor = Tree.Zipper DTC.BodyKey DTC.BodyValue
234 instance Html5ify DTC.Body where
235 html5ify body =
236 forM_ (Tree.zippers body) $ \z ->
237 forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
238 html5ify
239 instance Html5ify BodyCursor
240 where html5ify z =
241 case Tree.current z of
242 TreeN k _ts ->
243 case k of
244 DTC.Section{..} ->
245 H.section ! HA.class_ "section"
246 ! HA.id (attrify pos) $$ do
247 html5CommonAttrs attrs $
248 H.table ! HA.class_ "section-header" $$
249 H.tbody $$
250 H.tr $$ do
251 H.td ! HA.class_ "section-number" $$ do
252 html5SectionNumber $ DTC.posAncestors pos
253 H.td ! HA.class_ "section-title" $$ do
254 (case List.length $ DTC.posAncestors pos of
255 0 -> H.h1
256 1 -> H.h2
257 2 -> H.h3
258 3 -> H.h4
259 4 -> H.h5
260 5 -> H.h6
261 _ -> H.h6) $$
262 html5ify title
263 forM_ (Tree.axis_child `Tree.runAxis` z) $
264 html5ify
265 notes <- liftStateMarkup $ S.gets state_notes
266 case Map.lookup pos notes of
267 Nothing -> return ()
268 Just ns ->
269 H.aside ! HA.class_ "notes" $$ do
270 Compose $ pure H.hr
271 H.table $$
272 H.tbody $$
273 forM_ ns $ \(num,para) ->
274 H.tr $$ do
275 H.td ! HA.class_ "note-ref" $$ do
276 H.a ! HA.class_ "note-number"
277 ! HA.id ("note."<>attrify num)
278 ! HA.href ("#note."<>attrify num) $$ do
279 html5ify num
280 ". "::Html5
281 H.a ! HA.href ("#note-ref."<>attrify num) $$ do
282 "↑"
283 H.td $$
284 html5ify para
285 Tree0 v ->
286 case v of
287 DTC.Block b -> html5ify b
288 DTC.ToC{..} -> do
289 H.nav ! HA.class_ "toc"
290 ! HA.id (attrify pos) $$ do
291 H.span ! HA.class_ "toc-name" $$
292 H.a ! HA.href (attrify pos) $$
293 html5ify Plain.L10n_Table_of_Contents
294 H.ul $$
295 forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
296 html5ifyToC depth
297 DTC.ToF{..} -> do
298 H.nav ! HA.class_ "tof"
299 ! HA.id (attrify pos) $$
300 H.table ! HA.class_ "tof" $$
301 H.tbody $$
302 html5ifyToF types
303 DTC.Figure{..} ->
304 html5CommonAttrs attrs $
305 H.div ! HA.class_ ("figure " <> attrify ("figure-"<>type_))
306 ! HA.id (attrify pos) $$ do
307 H.table ! HA.class_ "figure-caption" $$
308 H.tbody $$
309 H.tr $$ do
310 H.td ! HA.class_ "figure-number" $$ do
311 H.a ! HA.href ("#"<>attrify pos) $$ do
312 html5ify type_
313 html5ify $ DTC.posAncestors pos
314 forM_ title $ \ti ->
315 H.td ! HA.class_ "figure-title" $$ do
316 html5ify $ Plain.L10n_Colon
317 html5ify ti
318 H.div ! HA.class_ "figure-content" $$ do
319 html5ify blocks
320 DTC.Index{pos} -> do
321 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs
322 let chars = Anchor.termsByChar allTerms
323 H.div ! HA.class_ "index"
324 ! HA.id (attrify pos) $$ do
325 H.nav ! HA.class_ "index-nav" $$ do
326 forM_ (Map.keys chars) $ \char ->
327 H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
328 html5ify char
329 H.dl ! HA.class_ "index-chars" $$
330 forM_ (Map.toList chars) $ \(char,terms) -> do
331 H.dt $$
332 let i = attrify pos <> "." <> attrify char in
333 H.a ! HA.id i
334 ! HA.href ("#"<>i) $$
335 html5ify char
336 H.dd $$
337 H.dl ! HA.class_ "index-term" $$ do
338 forM_ terms $ \aliases -> do
339 H.dt $$
340 H.ul ! HA.class_ "index-aliases" $$
341 forM_ (List.take 1 aliases) $ \term ->
342 H.li ! HA.id (attrifyIref term) $$
343 html5ify term
344 H.dd $$
345 let anchs =
346 List.sortBy (compare `on` DTC.section . snd) $
347 (`foldMap` aliases) $ \words ->
348 fromJust $ do
349 path <- Anchor.pathFromWords words
350 Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
351 TreeMap.lookup path refsByTerm in
352 html5CommasDot $
353 (<$> anchs) $ \(term,DTC.Anchor{..}) ->
354 H.a ! HA.class_ "index-iref"
355 ! HA.href ("#"<>attrifyIrefCount term count) $$
356 html5ify $ DTC.posAncestors section
357 DTC.References{..} ->
358 html5CommonAttrs attrs $
359 H.div ! HA.class_ "references"
360 ! HA.id (attrify pos) $$ do
361 H.table $$
362 forM_ refs html5ify
363 instance Html5ify DTC.Words where
364 html5ify = html5ify . Anchor.plainifyWords
365
366 cleanPara :: DTC.Para -> DTC.Para
367 cleanPara p =
368 p >>= (`Tree.bindTrees` \case
369 TreeN DTC.Iref{} ls -> ls
370 TreeN DTC.Note{} _ -> mempty
371 h -> pure h)
372
373 html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
374 html5ifyToC depth z =
375 case Tree.current z of
376 TreeN DTC.Section{..} _ts -> do
377 H.li $$ do
378 H.table ! HA.class_ "toc-entry" $$
379 H.tbody $$
380 H.tr $$ do
381 H.td ! HA.class_ "section-number" $$
382 html5SectionRef $ DTC.posAncestors pos
383 H.td ! HA.class_ "section-title" $$
384 html5ify $ cleanPara $ DTC.unTitle title
385 when (maybe True (> DTC.Nat 1) depth && not (null sections)) $
386 H.ul $$
387 forM_ sections $
388 html5ifyToC (depth >>= DTC.predNat)
389 _ -> pure ()
390 where
391 sections =
392 (`Tree.runAxis` z) $
393 Tree.axis_child
394 `Tree.axis_filter_current` \case
395 TreeN DTC.Section{} _ -> True
396 _ -> False
397
398 html5ifyToF :: [Text] -> Html5
399 html5ifyToF types = do
400 figsByType <- liftStateMarkup $ S.gets state_figures
401 let figs =
402 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
403 if null types
404 then figsByType
405 else
406 Map.intersection figsByType $
407 Map.fromList [(ty,()) | ty <- types]
408 forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
409 H.tr $$ do
410 H.td ! HA.class_ "figure-number" $$
411 H.a ! HA.href ("#"<>attrify pos) $$ do
412 html5ify type_
413 html5ify $ DTC.posAncestors pos
414 forM_ title $ \ti ->
415 H.td ! HA.class_ "figure-title" $$
416 html5ify $ cleanPara $ DTC.unTitle ti
417
418 instance Html5ify [DTC.Block] where
419 html5ify = mapM_ html5ify
420 instance Html5ify DTC.Block where
421 html5ify = \case
422 DTC.Para{..} ->
423 html5CommonAttrs attrs $
424 H.p ! HA.class_ "para"
425 ! HA.id (attrify pos) $$ do
426 html5ify para
427 DTC.OL{..} ->
428 html5CommonAttrs attrs $
429 H.ol ! HA.class_ "ol"
430 ! HA.id (attrify pos) $$ do
431 forM_ items $ \item ->
432 H.li $$ html5ify item
433 DTC.UL{..} ->
434 html5CommonAttrs attrs $
435 H.ul ! HA.class_ "ul"
436 ! HA.id (attrify pos) $$ do
437 forM_ items $ \item ->
438 H.li $$ html5ify item
439 DTC.Comment t ->
440 html5ify $ H.Comment (H.Text t) ()
441 instance Html5ify DTC.Lines where
442 html5ify = \case
443 Tree0 v ->
444 case v of
445 DTC.BR -> html5ify H.br
446 DTC.Plain t -> html5ify t
447 TreeN k ls ->
448 case k of
449 DTC.B -> H.strong $$ html5ify ls
450 DTC.Code -> H.code $$ html5ify ls
451 DTC.Del -> H.del $$ html5ify ls
452 DTC.I -> do
453 i <- liftStateMarkup $ do
454 i <- S.gets $ Plain.state_italic . state_plainify
455 S.modify $ \s ->
456 s{state_plainify=
457 (state_plainify s){Plain.state_italic=
458 not i}}
459 return i
460 H.em ! HA.class_ (if i then "even" else "odd") $$
461 html5ify ls
462 liftStateMarkup $
463 S.modify $ \s ->
464 s{state_plainify=
465 (state_plainify s){Plain.state_italic=i}}
466 DTC.Sub -> H.sub $$ html5ify ls
467 DTC.Sup -> H.sup $$ html5ify ls
468 DTC.SC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
469 DTC.U -> H.span ! HA.class_ "underline" $$ html5ify ls
470 DTC.Note{..} ->
471 case number of
472 Nothing -> ""
473 Just num ->
474 H.sup ! HA.class_ "note-number" $$
475 H.a ! HA.class_ "note-ref"
476 ! HA.id ("note-ref."<>attrify num)
477 ! HA.href ("#note."<>attrify num) $$
478 html5ify num
479 DTC.Q -> do
480 depth <- liftStateMarkup $ do
481 depth <- S.gets $ Plain.state_quote . state_plainify
482 S.modify $ \s -> s{state_plainify=
483 (state_plainify s){Plain.state_quote=
484 DTC.succNat depth}}
485 return depth
486 H.span ! HA.class_ "q" $$ do
487 html5ify $ Plain.L10n_QuoteOpen depth
488 html5ify $ TreeN DTC.I ls
489 html5ify $ Plain.L10n_QuoteClose depth
490 liftStateMarkup $
491 S.modify $ \s ->
492 s{state_plainify=
493 (state_plainify s){Plain.state_quote = depth}}
494 DTC.Eref{..} ->
495 H.a ! HA.class_ "eref"
496 ! HA.href (attrify href) $$
497 if null ls
498 then html5ify $ DTC.unURL href
499 else html5ify ls
500 DTC.Iref{..} ->
501 case anchor of
502 Nothing -> html5ify ls
503 Just DTC.Anchor{..} ->
504 H.span ! HA.class_ "iref"
505 ! HA.id (attrifyIrefCount term count) $$
506 html5ify ls
507 DTC.Ref{..} ->
508 H.a ! HA.class_ "ref"
509 ! HA.href ("#"<>attrify to) $$
510 if null ls
511 then html5ify to
512 else html5ify ls
513 DTC.Rref{..} -> do
514 refs <- liftStateMarkup $ S.gets state_references
515 case Map.lookup to refs of
516 Nothing -> do
517 "["::Html5
518 H.span ! HA.class_ "rref-broken" $$
519 html5ify to
520 "]"
521 Just DTC.About{..} -> do
522 when (not $ null ls) $
523 forM_ (List.take 1 titles) $ \(DTC.Title title) -> do
524 html5ify $ TreeN DTC.Q $
525 case url of
526 Nothing -> title
527 Just u -> pure $ TreeN (DTC.Eref u) title
528 " "::Html5
529 "["::Html5
530 H.a ! HA.class_ "rref"
531 ! HA.href ("#rref."<>attrify to)
532 ! HA.id ("rref."<>attrify to<>maybe "" (\DTC.Anchor{..} -> "."<>attrify count) anchor) $$
533 html5ify to
534 "]"
535 instance Html5ify DTC.URL where
536 html5ify (DTC.URL url) =
537 H.a ! HA.class_ "eref"
538 ! HA.href (attrify url) $$
539 html5ify url
540 instance Html5ify DTC.Date where
541 html5ify = html5ify . Plain.L10n_Date
542 instance Html5ify DTC.About where
543 html5ify DTC.About{..} =
544 html5CommasDot $ concat $
545 [ html5Titles titles
546 , html5Entity <$> authors
547 , html5ify <$> maybeToList date
548 , html5Entity <$> maybeToList editor
549 , html5Serie <$> series
550 ]
551 where
552 html5Titles :: [DTC.Title] -> [Html5]
553 html5Titles ts | null ts = []
554 html5Titles ts = [html5Title $ fold $ List.intersperse t $ toList ts]
555 where t = DTC.Title $ Seq.singleton $ Tree0 $ DTC.Plain " — "
556 html5Title (DTC.Title title) =
557 html5ify $ TreeN DTC.Q $
558 case url of
559 Nothing -> title
560 Just u -> pure $ TreeN (DTC.Eref u) title
561 html5SerieHref href DTC.Serie{..} = do
562 sp <- liftStateMarkup $ S.gets state_plainify
563 html5ify $
564 TreeN DTC.Eref{href} $
565 Seq.fromList
566 [ Tree0 $ DTC.Plain $ name
567 , Tree0 $ DTC.Plain $ TL.toStrict $ Plain.text sp Plain.L10n_Colon
568 , Tree0 $ DTC.Plain key
569 ]
570 html5Serie s@DTC.Serie{name="RFC", key} | Text.all Char.isDigit key =
571 html5SerieHref (DTC.URL $ "https://tools.ietf.org/html/rfc"<>key) s
572 html5Serie s@DTC.Serie{name="DOI", key} =
573 html5SerieHref (DTC.URL $ "https://dx.doi.org/"<>key) s
574 html5Serie DTC.Serie{..} = do
575 html5ify name
576 html5ify Plain.L10n_Colon
577 html5ify key
578 html5Entity DTC.Entity{url=mu, ..} = do
579 html5ify @DTC.Lines $
580 case () of
581 _ | not (Text.null email) ->
582 TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $
583 pure $ Tree0 $ DTC.Plain name
584 _ | Just u <- mu ->
585 TreeN (DTC.Eref u) $
586 pure $ Tree0 $ DTC.Plain name
587 _ -> Tree0 $ DTC.Plain name
588 forM_ org $ \o -> do
589 " ("::Html5
590 html5Entity o
591 ")"::Html5
592 instance Html5ify DTC.Reference where
593 html5ify DTC.Reference{id=id_, ..} =
594 H.tr $$ do
595 H.td ! HA.class_ "reference-key" $$
596 html5ify @DTC.Lines $ TreeN DTC.Rref{anchor=Nothing, to=id_} Seq.empty
597 H.td ! HA.class_ "reference-content" $$ do
598 html5ify about
599 rrefs <- liftStateMarkup $ S.gets state_rrefs
600 case Map.lookup id_ rrefs of
601 Nothing -> pure ()
602 Just anchs ->
603 H.span ! HA.class_ "reference-rrefs" $$
604 html5CommasDot $
605 (<$> List.reverse anchs) $ \DTC.Anchor{..} ->
606 H.a ! HA.class_ "reference-rref"
607 ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
608 html5ify $ DTC.posAncestors section
609 instance Html5ify DTC.PosPath where
610 html5ify ancs =
611 case toList ancs of
612 [(_n,c)] -> do
613 html5ify $ show c
614 html5ify '.'
615 as ->
616 html5ify $
617 Text.intercalate "." $
618 Text.pack . show . snd <$> as
619 instance Html5ify Plain where
620 html5ify p = do
621 sp <- liftStateMarkup $ S.gets state_plainify
622 let (t,sp') = Plain.runPlain p sp
623 html5ify t
624 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
625
626 html5CommasDot :: [Html5] -> Html5
627 html5CommasDot [] = pure ()
628 html5CommasDot hs = do
629 sequence_ $ List.intersperse ", " hs
630 "."
631
632 html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
633 html5CommonAttrs DTC.CommonAttrs{id=id_, ..} =
634 Compose . (addClass . addId <$>) . getCompose
635 where
636 addClass =
637 case classes of
638 [] -> id
639 _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
640 addId = maybe id (\(DTC.Ident i) ->
641 H.AddCustomAttribute "id" (H.Text i)) id_
642
643 html5SectionNumber :: DTC.PosPath -> Html5
644 html5SectionNumber = go mempty
645 where
646 go :: DTC.PosPath -> DTC.PosPath -> Html5
647 go prev next =
648 case Seq.viewl next of
649 Seq.EmptyL -> pure ()
650 a@(_n,rank) Seq.:< as -> do
651 H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
652 html5ify $ show rank
653 when (not (null as) || null prev) $ do
654 html5ify '.'
655 go (prev Seq.|>a) as
656
657 html5SectionRef :: DTC.PosPath -> Html5
658 html5SectionRef as =
659 H.a ! HA.href ("#"<>attrify as) $$
660 html5ify as
661
662
663 -- * 'Attrify'
664 instance Attrify DTC.Anchor where
665 attrify DTC.Anchor{..} =
666 attrify section
667 <> "." <> attrify count
668 instance Attrify Plain where
669 attrify p =
670 let (t,_) = Plain.runPlain p def in
671 attrify t
672 instance Attrify DTC.PosPath where
673 attrify = attrify . plainify
674 instance Attrify DTC.Pos where
675 attrify = attrify . DTC.posAncestors
676
677 attrifyIref :: DTC.Words -> H.AttributeValue
678 attrifyIref term =
679 "iref" <> "." <> attrify (Anchor.plainifyWords term)
680 attrifyIrefCount :: DTC.Words -> DTC.Nat1 -> H.AttributeValue
681 attrifyIrefCount term count =
682 "iref"
683 <> "." <> attrify (Anchor.plainifyWords term)
684 <> "." <> attrify count
685
686 -- * Type 'L10n'
687 instance Html5ify Plain.L10n where
688 html5ify = html5ify . plainify
689 instance Localize ls Plain Plain.L10n => Localize ls Html5 Plain.L10n where
690 localize loc a = html5ify (Locale.localize loc a::Plain)
691 instance LocalizeIn FR Html5 Plain.L10n where
692 localizeIn loc = html5ify @Plain . localizeIn loc
693 instance LocalizeIn EN Html5 Plain.L10n where
694 localizeIn loc = html5ify @Plain . localizeIn loc