]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/HTML5.hs
sourcephile / git / doclang.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Add BlockBreak.
[doclang.git] / Language / DTC / Write / HTML5.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DuplicateRecordFields #-}
3 {-# LANGUAGE ExistentialQuantification #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE MultiParamTypeClasses #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE TypeApplications #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-}
11 module Language.DTC.Write.HTML5 where
12
13 import Control.Applicative (Applicative(..))
14 import Control.Category as Cat
15 import Control.Monad
16 import Data.Bool
17 import Data.Char (Char)
18 import Data.Default.Class (Default(..))
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import Data.Foldable (Foldable(..), concat, any)
22 import Data.Function (($), const, on)
23 import Data.Functor ((<$>))
24 import Data.Functor.Compose (Compose(..))
25 import Data.Int (Int)
26 import Data.Map.Strict (Map)
27 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
28 import Data.Monoid (Monoid(..))
29 import Data.Ord (Ord(..))
30 import Data.Semigroup (Semigroup(..))
31 import Data.String (String, IsString(..))
32 import Data.Text (Text)
33 import Data.TreeSeq.Strict (Tree(..), tree0)
34 import Data.Tuple (snd)
35 import Prelude (mod)
36 import System.FilePath (FilePath)
37 import Text.Blaze ((!))
38 import Text.Blaze.Html (Html)
39 import Text.Show (Show(..))
40 import qualified Control.Monad.Trans.State as S
41 import qualified Data.List as List
42 import qualified Data.Map.Strict as Map
43 import qualified Data.Sequence as Seq
44 import qualified Data.Strict.Maybe as Strict
45 import qualified Data.Text as Text
46 import qualified Data.Text.Lazy as TL
47 import qualified Data.TreeMap.Strict as TreeMap
48 import qualified Data.TreeSeq.Strict.Zipper as Tree
49 import qualified Text.Blaze.Html5 as H
50 import qualified Text.Blaze.Html5.Attributes as HA
51 import qualified Text.Blaze.Internal as H
52
53 import Text.Blaze.Utils
54 import Data.Locale hiding (Index)
55
56 import Language.DTC.Document as DTC
57 import Language.DTC.Write.Plain (Plainify(..))
58 import Language.DTC.Write.XML ()
59 import qualified Language.DTC.Anchor as Anchor
60 import qualified Language.DTC.Write.Plain as Plain
61
62 writeHTML5 :: Config -> DTC.Document -> Html
63 writeHTML5 conf@Config{..} DTC.Document{..} = do
64 let Keys{..} = keys body `S.execState` def
65 let (body',state_rrefs,state_notes,state_indexs) =
66 let irefs = foldMap Anchor.irefsOfTerms keys_index in
67 let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) =
68 Anchor.anchorify body `S.runState`
69 def{Anchor.state_irefs=irefs} in
70 (body0,rrefs,notes,) $
71 (<$> keys_index) $ \terms ->
72 (terms,) $
73 TreeMap.intersection const state_irefs $
74 Anchor.irefsOfTerms terms
75 let state_plainify = def{ Plain.state_l10n = loqualize config_locale}
76 let (html5Body, endState) =
77 runStateMarkup def
78 { state_indexs
79 , state_rrefs
80 , state_notes
81 , state_figures = keys_figure
82 , state_references = keys_reference
83 , state_plainify
84 , state_l10n = loqualize config_locale
85 } $ do
86 html5DocumentHead head
87 html5ify body'
88 H.docType
89 H.html ! HA.lang (attrify $ countryCode config_locale) $ do
90 html5Head conf endState head body
91 H.body $ html5Body
92
93 html5Head :: Config -> State -> Head -> Body -> Html
94 html5Head Config{..} State{..} Head{DTC.about=About{..}} body = do
95 H.head $ do
96 H.meta ! HA.httpEquiv "Content-Type"
97 ! HA.content "text/html; charset=UTF-8"
98 unless (null titles) $ do
99 H.title $
100 H.toMarkup $ Plain.text state_plainify $ List.head titles
101 forM_ links $ \Link{rel, href} ->
102 H.link ! HA.rel (attrify rel)
103 ! HA.href (attrify href)
104 forM_ url $ \href ->
105 H.link ! HA.rel "self"
106 ! HA.href (attrify href)
107 unless (TL.null config_generator) $ do
108 H.meta ! HA.name "generator"
109 ! HA.content (attrify config_generator)
110 unless (null tags) $
111 H.meta ! HA.name "keywords"
112 ! HA.content (attrify $ TL.intercalate ", " tags)
113 let chapters =
114 (`mapMaybe` toList body) $ \case
115 Tree k@BodySection{} _ -> Just k
116 _ -> Nothing
117 forM_ chapters $ \case
118 BodySection{..} ->
119 H.link ! HA.rel "Chapter"
120 ! HA.title (attrify $ plainify title)
121 ! HA.href ("#"<>attrify pos)
122 _ -> mempty
123 unless (any (\DTC.Link{rel} -> rel == "stylesheet") links) $ do
124 case config_css of
125 Left "" -> mempty
126 Left css ->
127 H.link ! HA.rel "stylesheet"
128 ! HA.type_ "text/css"
129 ! HA.href (attrify css)
130 Right css ->
131 H.style ! HA.type_ "text/css" $
132 -- NOTE: as a special case, H.style wraps its content into an External,
133 -- so it does not HTML-escape its content.
134 H.toMarkup css
135 forM_ state_styles $ \style ->
136 H.style ! HA.type_ "text/css" $
137 H.toMarkup style
138 unless (any (\DTC.Link{rel} -> rel == "script") links) $ do
139 forM_ state_scripts $ \script ->
140 H.script ! HA.type_ "application/javascript" $
141 H.toMarkup script
142
143 html5DocumentHead :: Head -> Html5
144 html5DocumentHead Head{DTC.about=About{..}} = do
145 H.div ! HA.class_ "document-head" $$
146 H.table $$ do
147 H.tbody $$ do
148 H.tr $$ do
149 H.td ! HA.class_ "left" $$ docHeaders
150 H.td ! HA.class_ "right" $$ docAuthors
151 unless (null titles) $
152 H.div ! HA.class_ "title" $$ do
153 forM_ titles $ \title ->
154 H.h1 $$ html5ify title
155 where
156 docHeaders =
157 H.table ! HA.class_ "document-headers" $$
158 H.tbody $$ do
159 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
160 forM_ series $ \s@Serie{id=id_, name} ->
161 header $
162 case urlSerie s of
163 Nothing -> do
164 headerName $ html5ify name
165 headerValue $ html5ify id_
166 Just href -> do
167 headerName $ html5ify name
168 headerValue $
169 H.a ! HA.href (attrify href) $$
170 html5ify id_
171 forM_ date $ \d ->
172 header $ do
173 headerName $ l10n_Header_Date loc
174 headerValue $ html5ify d
175 forM_ url $ \href ->
176 header $ do
177 headerName $ l10n_Header_Address loc
178 headerValue $ html5ify $ tree0 $ PlainEref{href}
179 forM_ links $ \Link{..} ->
180 unless (TL.null name) $
181 header $ do
182 headerName $ html5ify name
183 headerValue $ html5ify $ Tree PlainEref{href} plain
184 forM_ headers $ \Header{..} ->
185 header $ do
186 headerName $ html5ify name
187 headerValue $ html5ify value
188 docAuthors =
189 H.table ! HA.class_ "document-authors" $$
190 H.tbody $$ do
191 forM_ authors $ \a ->
192 H.tr $$
193 H.td ! HA.class_ "author" $$
194 html5ify a
195 header :: Html5 -> Html5
196 header h = H.tr ! HA.class_ "header" $$ h
197 headerName :: Html5 -> Html5
198 headerName h =
199 H.td ! HA.class_ "header-name" $$ do
200 h
201 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
202 Plain.l10n_Colon loc
203 headerValue :: Html5 -> Html5
204 headerValue h =
205 H.td ! HA.class_ "header-value" $$ do
206 h
207
208 -- * Type 'Config'
209 data Config
210 = forall locales.
211 ( Locales locales
212 , Loqualize locales (L10n Html5)
213 , Loqualize locales (Plain.L10n Plain.Plain)
214 ) =>
215 Config
216 { config_css :: Either FilePath TL.Text
217 , config_locale :: LocaleIn locales
218 , config_generator :: TL.Text
219 }
220 instance Default Config where
221 def = Config
222 { config_css = Right "style/dtc-html5.css"
223 , config_locale = LocaleIn @'[EN] en_US
224 , config_generator = "https://hackage.haskell.org/package/hdoc"
225 }
226
227 -- * Type 'Html5'
228 type Html5 = StateMarkup State ()
229 instance IsString Html5 where
230 fromString = html5ify
231
232 -- * Type 'State'
233 data State
234 = State
235 { state_styles :: Map FilePath TL.Text
236 , state_scripts :: Map FilePath TL.Text
237 , state_indexs :: Map DTC.Pos (Terms, Anchor.Irefs)
238 , state_rrefs :: Anchor.Rrefs
239 , state_figures :: Map TL.Text (Map DTC.Pos (Maybe Title))
240 , state_references :: Map Ident About
241 , state_notes :: Anchor.Notes
242 , state_plainify :: Plain.State
243 , state_l10n :: Loqualization (L10n Html5)
244 }
245 instance Default State where
246 def = State
247 { state_styles = def
248 , state_scripts = def
249 , state_indexs = def
250 , state_rrefs = def
251 , state_figures = def
252 , state_references = def
253 , state_notes = def
254 , state_plainify = def
255 , state_l10n = Loqualization EN_US
256 }
257
258 -- * Type 'Keys'
259 data Keys
260 = Keys
261 { keys_index :: Map DTC.Pos Terms
262 , keys_figure :: Map TL.Text (Map DTC.Pos (Maybe Title))
263 , keys_reference :: Map Ident About
264 } deriving (Show)
265 instance Default Keys where
266 def = Keys mempty mempty mempty
267
268 -- ** Class 'KeysOf'
269 class KeysOf a where
270 keys :: a -> S.State Keys ()
271 instance KeysOf Body where
272 keys = mapM_ keys
273 instance KeysOf (Tree BodyNode) where
274 keys (Tree n ts) =
275 case n of
276 BodySection{..} -> keys ts
277 BodyBlock b -> keys b
278 instance KeysOf DTC.Block where
279 keys = \case
280 BlockPara{} -> return ()
281 BlockBreak{} -> return ()
282 BlockToC{} -> return ()
283 BlockToF{} -> return ()
284 BlockIndex{..} ->
285 S.modify $ \s -> s{keys_index=
286 Map.insert pos terms $ keys_index s}
287 BlockFigure{..} ->
288 S.modify $ \s -> s{keys_figure=
289 Map.insertWith (<>)
290 type_ (Map.singleton pos mayTitle) $
291 keys_figure s}
292 BlockReferences{..} ->
293 S.modify $ \s -> s{keys_reference=
294 foldr
295 (\r -> Map.insert
296 (DTC.id (r::DTC.Reference))
297 (DTC.about (r::DTC.Reference)))
298 (keys_reference s)
299 refs}
300
301 -- * Class 'Html5ify'
302 class Html5ify a where
303 html5ify :: a -> Html5
304 instance Html5ify H.Markup where
305 html5ify = Compose . return
306 instance Html5ify Char where
307 html5ify = html5ify . H.toMarkup
308 instance Html5ify Text where
309 html5ify = html5ify . H.toMarkup
310 instance Html5ify TL.Text where
311 html5ify = html5ify . H.toMarkup
312 instance Html5ify String where
313 html5ify = html5ify . H.toMarkup
314 instance Html5ify Title where
315 html5ify (Title t) = html5ify t
316 instance Html5ify Ident where
317 html5ify (Ident i) = html5ify i
318 instance Html5ify Int where
319 html5ify = html5ify . show
320 instance Html5ify Nat where
321 html5ify (Nat n) = html5ify n
322 instance Html5ify Nat1 where
323 html5ify (Nat1 n) = html5ify n
324 instance Html5ify a => Html5ify (Maybe a) where
325 html5ify = foldMap html5ify
326
327 -- * Type 'BodyCursor'
328 -- | Cursor to navigate within a 'Body' according to many axis (like in XSLT).
329 type BodyCursor = Tree.Zipper BodyNode
330 instance Html5ify Body where
331 html5ify body =
332 forM_ (Tree.zippers body) $ \z ->
333 forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
334 html5ify
335 instance Html5ify BodyCursor
336 where html5ify z =
337 let Tree n _ts = Tree.current z in
338 case n of
339 BodyBlock BlockToC{..} -> do
340 H.nav ! HA.class_ "toc"
341 ! HA.id (attrify pos) $$ do
342 H.span ! HA.class_ "toc-name" $$
343 H.a ! HA.href (attrify pos) $$ do
344 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
345 Plain.l10n_Table_of_Contents loc
346 H.ul $$
347 forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
348 html5ifyToC depth
349 BodyBlock b -> html5ify b
350 BodySection{..} -> do
351 do
352 notes <- liftStateMarkup $ S.gets state_notes
353 let mayNotes = do
354 p <- posParent $ posAncestors pos
355 let (ns, as) = Map.updateLookupWithKey (\_ _ -> Nothing) p notes
356 (,as) <$> ns
357 case mayNotes of
358 Nothing -> mempty
359 Just (secNotes, state_notes) -> do
360 liftStateMarkup $ S.modify' $ \s -> s{state_notes}
361 html5ify secNotes
362 H.section ! HA.class_ "section"
363 ! HA.id (attrify pos) $$ do
364 forM_ aliases html5ify
365 html5CommonAttrs attrs{classes="section-header":classes attrs} $
366 H.table $$
367 H.tbody $$
368 H.tr $$ do
369 H.td ! HA.class_ "section-number" $$ do
370 html5SectionNumber $ DTC.posAncestors pos
371 H.td ! HA.class_ "section-title" $$ do
372 (case List.length $ DTC.posAncestors pos of
373 0 -> H.h1
374 1 -> H.h2
375 2 -> H.h3
376 3 -> H.h4
377 4 -> H.h5
378 5 -> H.h6
379 _ -> H.h6) $$
380 html5ify title
381 forM_ (Tree.axis_child `Tree.runAxis` z) $
382 html5ify
383 notes <- liftStateMarkup $ S.gets state_notes
384 html5ify $ Map.lookup (posAncestors pos) notes
385 instance Html5ify [Anchor.Note] where
386 html5ify notes =
387 H.aside ! HA.class_ "notes" $$ do
388 Compose $ pure H.hr
389 H.table $$
390 H.tbody $$
391 forM_ (List.reverse notes) $ \Anchor.Note{..} ->
392 H.tr $$ do
393 H.td ! HA.class_ "note-ref" $$ do
394 H.a ! HA.class_ "note-number"
395 ! HA.id ("note."<>attrify note_number)
396 ! HA.href ("#note."<>attrify note_number) $$ do
397 html5ify note_number
398 ". "::Html5
399 H.a ! HA.href ("#note-ref."<>attrify note_number) $$ do
400 "↑"
401 H.td $$
402 html5ify note_content
403 instance Html5ify Block where
404 html5ify = \case
405 BlockPara para -> html5ify para
406 BlockBreak{..} ->
407 html5CommonAttrs attrs
408 { classes = "page-break":"print-only":classes attrs } $
409 H.div $$
410 H.p $$ " " -- NOTE: force page break
411 BlockToC{..} -> mempty -- NOTE: done in Html5ify BodyCursor
412 BlockToF{..} -> do
413 H.nav ! HA.class_ "tof"
414 ! HA.id (attrify pos) $$
415 H.table ! HA.class_ "tof" $$
416 H.tbody $$
417 html5ifyToF types
418 BlockFigure{..} ->
419 html5CommonAttrs attrs
420 { classes = "figure":("figure-"<>type_):classes attrs
421 , DTC.id = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
422 } $
423 H.div $$ do
424 H.table ! HA.class_ "figure-caption" $$
425 H.tbody $$
426 H.tr $$ do
427 if TL.null type_
428 then H.a ! HA.href ("#"<>attrify pos) $$ mempty
429 else
430 H.td ! HA.class_ "figure-number" $$ do
431 H.a ! HA.href ("#"<>attrify (DTC.posAncestorsWithFigureNames pos)) $$ do
432 html5ify type_
433 html5ify $ DTC.posAncestorsWithFigureNames pos
434 forM_ mayTitle $ \title -> do
435 H.td ! HA.class_ "figure-colon" $$ do
436 unless (TL.null type_) $ do
437 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
438 Plain.l10n_Colon loc
439 H.td ! HA.class_ "figure-title" $$ do
440 html5ify title
441 H.div ! HA.class_ "figure-content" $$ do
442 html5ify paras
443 BlockIndex{pos} -> do
444 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs
445 let chars = Anchor.termsByChar allTerms
446 H.div ! HA.class_ "index"
447 ! HA.id (attrify pos) $$ do
448 H.nav ! HA.class_ "index-nav" $$ do
449 forM_ (Map.keys chars) $ \char ->
450 H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
451 html5ify char
452 H.dl ! HA.class_ "index-chars" $$
453 forM_ (Map.toList chars) $ \(char,terms) -> do
454 H.dt $$
455 let i = attrify pos <> "." <> attrify char in
456 H.a ! HA.id i
457 ! HA.href ("#"<>i) $$
458 html5ify char
459 H.dd $$
460 H.dl ! HA.class_ "index-term" $$ do
461 forM_ terms $ \aliases -> do
462 H.dt $$
463 H.ul ! HA.class_ "index-aliases" $$
464 forM_ (List.take 1 aliases) $ \term ->
465 H.li ! HA.id (attrifyIref term) $$
466 html5ify term
467 H.dd $$
468 let anchs =
469 List.sortBy (compare `on` DTC.section . snd) $
470 (`foldMap` aliases) $ \words ->
471 fromJust $ do
472 path <- Anchor.pathFromWords words
473 Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
474 TreeMap.lookup path refsByTerm in
475 html5CommasDot $
476 (<$> anchs) $ \(term,DTC.Anchor{..}) ->
477 H.a ! HA.class_ "index-iref"
478 ! HA.href ("#"<>attrifyIrefCount term count) $$
479 html5ify $ DTC.posAncestors section
480 BlockReferences{..} ->
481 html5CommonAttrs attrs
482 { classes = "references":classes attrs
483 , DTC.id = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
484 } $
485 H.div $$ do
486 H.table $$
487 forM_ refs html5ify
488
489 html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
490 html5ifyToC depth z =
491 let Tree n _ts = Tree.current z in
492 case n of
493 BodySection{..} -> do
494 H.li $$ do
495 H.table ! HA.class_ "toc-entry" $$
496 H.tbody $$
497 H.tr $$ do
498 H.td ! HA.class_ "section-number" $$
499 html5SectionRef $ DTC.posAncestors pos
500 H.td ! HA.class_ "section-title" $$
501 html5ify $ cleanPlain $ unTitle title
502 when (maybe True (> Nat 1) depth && not (null sections)) $
503 H.ul $$
504 forM_ sections $
505 html5ifyToC (depth >>= predNat)
506 _ -> pure ()
507 where
508 sections =
509 (`Tree.runAxis` z) $
510 Tree.axis_child
511 `Tree.axis_filter_current` \case
512 Tree BodySection{} _ -> True
513 _ -> False
514
515 html5ifyToF :: [TL.Text] -> Html5
516 html5ifyToF types = do
517 figsByType <- liftStateMarkup $ S.gets state_figures
518 let figs =
519 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
520 if null types
521 then figsByType
522 else
523 Map.intersection figsByType $
524 Map.fromList [(ty,()) | ty <- types]
525 forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
526 H.tr $$ do
527 H.td ! HA.class_ "figure-number" $$
528 H.a ! HA.href ("#"<>attrify pos) $$ do
529 html5ify type_
530 html5ify $ DTC.posAncestors pos
531 forM_ title $ \ti ->
532 H.td ! HA.class_ "figure-title" $$
533 html5ify $ cleanPlain $ unTitle ti
534
535 cleanPlain :: Plain -> Plain
536 cleanPlain ps =
537 ps >>= \case
538 Tree PlainIref{} ls -> cleanPlain ls
539 Tree PlainNote{} _ -> mempty
540 Tree n ts -> pure $ Tree n $ cleanPlain ts
541
542 instance Html5ify Para where
543 html5ify = \case
544 ParaItem{..} ->
545 html5CommonAttrs def
546 { classes="para":cls item
547 } $
548 html5ify item
549 ParaItems{..} ->
550 html5CommonAttrs attrs
551 { classes = "para":classes attrs
552 , DTC.id = id_ pos
553 } $
554 H.div $$
555 forM_ items $ \item ->
556 html5AttrClass (cls item) $
557 html5ify item
558 where
559 id_ = Just . Ident . Plain.text def . DTC.posAncestors
560 cls = \case
561 ParaPlain{} -> []
562 ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
563 ParaQuote{..} -> ["quote", "quote-"<>type_]
564 ParaComment{} -> []
565 ParaOL{} -> ["ol"]
566 ParaUL{} -> ["ul"]
567 instance Html5ify ParaItem where
568 html5ify = \case
569 ParaPlain p -> H.p $$ html5ify p
570 ParaArtwork{..} -> H.pre $$ do html5ify text
571 ParaQuote{..} -> H.div $$ do html5ify paras
572 ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
573 ParaOL items ->
574 H.table $$ do
575 H.tbody $$
576 forM_ items $ \ListItem{..} -> do
577 H.tr $$ do
578 H.td ! HA.class_ "name" $$ do
579 html5ify name
580 "."::Html5
581 H.td ! HA.class_ "value" $$
582 html5ify paras
583 ParaUL items ->
584 H.dl $$ do
585 forM_ items $ \item -> do
586 H.dt $$ "—"
587 H.dd $$ html5ify item
588 instance Html5ify [Para] where
589 html5ify = mapM_ html5ify
590
591 instance Html5ify Plain where
592 html5ify ps =
593 case Seq.viewl ps of
594 Seq.EmptyL -> mempty
595 curr Seq.:< next ->
596 case curr of
597 -- NOTE: gather adjacent PlainNotes
598 Tree PlainNote{} _
599 | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
600 H.sup ! HA.class_ "note-numbers" $$ do
601 html5ify curr
602 forM_ notes $ \note -> do
603 ", "::Html5
604 html5ify note
605 " "::Html5
606 html5ify rest
607 --
608 _ -> do
609 html5ify curr
610 html5ify next
611 instance Html5ify (Tree PlainNode)
612 where html5ify (Tree n ls) =
613 case n of
614 PlainBreak -> html5ify H.br
615 PlainText t -> html5ify t
616 PlainGroup -> html5ify ls
617 PlainB -> H.strong $$ html5ify ls
618 PlainCode -> H.code $$ html5ify ls
619 PlainDel -> H.del $$ html5ify ls
620 PlainI -> do
621 i <- liftStateMarkup $ do
622 i <- S.gets $ Plain.state_italic . state_plainify
623 S.modify $ \s ->
624 s{state_plainify=
625 (state_plainify s){Plain.state_italic=
626 not i}}
627 return i
628 H.em ! HA.class_ (if i then "even" else "odd") $$
629 html5ify ls
630 liftStateMarkup $
631 S.modify $ \s ->
632 s{state_plainify=
633 (state_plainify s){Plain.state_italic=i}}
634 PlainSub -> H.sub $$ html5ify ls
635 PlainSup -> H.sup $$ html5ify ls
636 PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
637 PlainU -> H.span ! HA.class_ "underline" $$ html5ify ls
638 PlainNote{..} ->
639 case number of
640 Nothing -> mempty
641 Just num ->
642 H.a ! HA.class_ "note-ref"
643 ! HA.id ("note-ref."<>attrify num)
644 ! HA.href ("#note."<>attrify num) $$
645 html5ify num
646 PlainQ -> do
647 H.span ! HA.class_ "q" $$ do
648 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
649 Plain.l10n_Quote (html5ify $ Tree PlainI ls) loc
650 PlainEref{..} ->
651 H.a ! HA.class_ "eref"
652 ! HA.href (attrify href) $$
653 if null ls
654 then html5ify $ unURL href
655 else html5ify ls
656 PlainIref{..} ->
657 case anchor of
658 Nothing -> html5ify ls
659 Just Anchor{..} ->
660 H.span ! HA.class_ "iref"
661 ! HA.id (attrifyIrefCount term count) $$
662 html5ify ls
663 PlainRef{..} ->
664 H.a ! HA.class_ "ref"
665 ! HA.href ("#"<>attrify to) $$
666 if null ls
667 then html5ify to
668 else html5ify ls
669 PlainRref{..} -> do
670 refs <- liftStateMarkup $ S.gets state_references
671 case Map.lookup to refs of
672 Nothing -> do
673 "["::Html5
674 H.span ! HA.class_ "rref-broken" $$
675 html5ify to
676 "]"
677 Just About{..} -> do
678 unless (null ls) $
679 forM_ (List.take 1 titles) $ \(Title title) -> do
680 html5ify $ Tree PlainQ $
681 case url of
682 Nothing -> title
683 Just u -> pure $ Tree (PlainEref u) title
684 " "::Html5
685 "["::Html5
686 H.a ! HA.class_ "rref"
687 ! HA.href ("#rref."<>attrify to)
688 ! HA.id ("rref."<>attrify to<>maybe "" (\Anchor{..} -> "."<>attrify count) anchor) $$
689 html5ify to
690 "]"
691
692 instance Html5ify [Title] where
693 html5ify =
694 html5ify . fold . List.intersperse sep . toList
695 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
696 instance Html5ify About where
697 html5ify About{..} =
698 html5CommasDot $ concat $
699 [ html5Titles titles
700 , html5ify <$> authors
701 , html5ify <$> maybeToList date
702 , html5ify <$> maybeToList editor
703 , html5ify <$> series
704 ]
705 where
706 html5Titles :: [Title] -> [Html5]
707 html5Titles ts | null ts = []
708 html5Titles ts = [html5Title $ joinTitles ts]
709 where
710 joinTitles = fold . List.intersperse sep . toList
711 sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
712 html5Title (Title title) =
713 html5ify $ Tree PlainQ $
714 case url of
715 Nothing -> title
716 Just u -> pure $ Tree (PlainEref u) title
717 instance Html5ify Serie where
718 html5ify s@Serie{id=id_, name} = do
719 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
720 case urlSerie s of
721 Nothing -> do
722 html5ify name
723 Plain.l10n_Colon loc :: Html5
724 html5ify id_
725 Just href -> do
726 html5ify $
727 Tree PlainEref{href} $
728 Seq.fromList
729 [ tree0 $ PlainText $ name
730 , tree0 $ PlainText $ Plain.l10n_Colon loc
731 , tree0 $ PlainText id_
732 ]
733 instance Html5ify Entity where
734 html5ify Entity{..} = do
735 html5ify $
736 case () of
737 _ | not (TL.null email) ->
738 Tree (PlainEref $ URL $ "mailto:"<>email) $
739 pure $ tree0 $ PlainText name
740 _ | Just u <- url ->
741 Tree (PlainEref u) $
742 pure $ tree0 $ PlainText name
743 _ -> tree0 $ PlainText name
744 forM_ org $ \o -> do
745 " ("::Html5
746 html5ify o
747 ")"::Html5
748 instance Html5ify Words where
749 html5ify = html5ify . Anchor.plainifyWords
750 instance Html5ify Alias where
751 html5ify Alias{id=id_, ..} = do
752 H.a ! HA.class_ "alias"
753 ! HA.id (attrify id_) $$
754 mempty
755 instance Html5ify URL where
756 html5ify (URL url) =
757 H.a ! HA.class_ "eref"
758 ! HA.href (attrify url) $$
759 html5ify url
760 instance Html5ify Date where
761 html5ify date = do
762 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
763 Plain.l10n_Date date loc
764 instance Html5ify Reference where
765 html5ify Reference{id=id_, ..} =
766 H.tr $$ do
767 H.td ! HA.class_ "reference-key" $$
768 html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty
769 H.td ! HA.class_ "reference-content" $$ do
770 html5ify about
771 rrefs <- liftStateMarkup $ S.gets state_rrefs
772 case Map.lookup id_ rrefs of
773 Nothing -> pure ()
774 Just anchs ->
775 H.span ! HA.class_ "reference-rrefs" $$
776 html5CommasDot $
777 (<$> List.reverse anchs) $ \Anchor{..} ->
778 H.a ! HA.class_ "reference-rref"
779 ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
780 html5ify $ DTC.posAncestors section
781 instance Html5ify PosPath where
782 html5ify ancs =
783 case toList ancs of
784 [(_n,c)] -> do
785 html5ify $ show c
786 html5ify '.'
787 as ->
788 html5ify $
789 Text.intercalate "." $
790 Text.pack . show . snd <$> as
791 instance Html5ify Plain.Plain where
792 html5ify p = do
793 sp <- liftStateMarkup $ S.gets state_plainify
794 let (t,sp') = Plain.runPlain p sp
795 html5ify t
796 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
797
798 html5CommasDot :: [Html5] -> Html5
799 html5CommasDot [] = pure ()
800 html5CommasDot hs = do
801 sequence_ $ List.intersperse ", " hs
802 "."
803
804 html5AttrClass :: [TL.Text] -> Html5 -> Html5
805 html5AttrClass = \case
806 [] -> Cat.id
807 cls ->
808 Compose .
809 (H.AddCustomAttribute "class"
810 (H.String $ TL.unpack $ TL.unwords cls) <$>) .
811 getCompose
812
813 html5AttrId :: Ident -> Html5 -> Html5
814 html5AttrId (Ident id_) =
815 Compose .
816 (H.AddCustomAttribute "id"
817 (H.String $ TL.unpack id_) <$>) .
818 getCompose
819
820 html5CommonAttrs :: CommonAttrs -> Html5 -> Html5
821 html5CommonAttrs CommonAttrs{id=id_, ..} =
822 html5AttrClass classes .
823 maybe Cat.id html5AttrId id_
824
825 html5SectionNumber :: PosPath -> Html5
826 html5SectionNumber = go mempty
827 where
828 go :: PosPath -> PosPath -> Html5
829 go prev next =
830 case Seq.viewl next of
831 Seq.EmptyL -> pure ()
832 a@(_n,rank) Seq.:< as -> do
833 H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
834 html5ify $ show rank
835 when (not (null as) || null prev) $ do
836 html5ify '.'
837 go (prev Seq.|>a) as
838
839 html5SectionRef :: PosPath -> Html5
840 html5SectionRef as =
841 H.a ! HA.href ("#"<>attrify as) $$
842 html5ify as
843
844 -- * 'Attrify'
845 instance Attrify Anchor where
846 attrify Anchor{..} = attrify section <> "." <> attrify count
847 instance Attrify Plain.Plain where
848 attrify p = attrify t
849 where (t,_) = Plain.runPlain p def
850 instance Attrify PosPath where
851 attrify = attrify . plainify
852 instance Attrify DTC.Pos where
853 attrify = attrify . DTC.posAncestors
854
855 attrifyIref :: Words -> H.AttributeValue
856 attrifyIref term =
857 "iref" <> "." <> attrify (Anchor.plainifyWords term)
858 attrifyIrefCount :: Words -> Nat1 -> H.AttributeValue
859 attrifyIrefCount term count =
860 "iref"
861 <> "." <> attrify (Anchor.plainifyWords term)
862 <> "." <> attrify count
863
864 -- * Class 'L10n'
865 class
866 ( Plain.L10n msg lang
867 , Plain.L10n TL.Text lang
868 ) => L10n msg lang where
869 l10n_Header_Address :: FullLocale lang -> msg
870 l10n_Header_Date :: FullLocale lang -> msg
871 l10n_Header_Version :: FullLocale lang -> msg
872 l10n_Header_Origin :: FullLocale lang -> msg
873 l10n_Header_Source :: FullLocale lang -> msg
874 instance L10n Html5 EN where
875 l10n_Header_Address _loc = "Address"
876 l10n_Header_Date _loc = "Date"
877 l10n_Header_Origin _loc = "Origin"
878 l10n_Header_Source _loc = "Source"
879 l10n_Header_Version _loc = "Version"
880 instance L10n Html5 FR where
881 l10n_Header_Address _loc = "Adresse"
882 l10n_Header_Date _loc = "Date"
883 l10n_Header_Origin _loc = "Origine"
884 l10n_Header_Source _loc = "Source"
885 l10n_Header_Version _loc = "Version"
886
887 instance Plain.L10n Html5 EN where
888 l10n_Colon loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
889 l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
890 l10n_Date date loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
891 l10n_Quote msg _loc = do
892 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
893 let (o,c) :: (Html5, Html5) =
894 case unNat depth `mod` 3 of
895 0 -> ("“","”")
896 1 -> ("« "," »")
897 _ -> ("‟","„")
898 o
899 setDepth $ succNat depth
900 msg
901 setDepth $ depth
902 c
903 where
904 setDepth d =
905 liftStateMarkup $ S.modify' $ \s ->
906 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
907 instance Plain.L10n Html5 FR where
908 l10n_Colon loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
909 l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
910 l10n_Date date loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
911 l10n_Quote msg _loc = do
912 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
913 let (o,c) :: (Html5, Html5) =
914 case unNat depth `mod` 3 of
915 0 -> ("« "," »")
916 1 -> ("“","”")
917 _ -> ("‟","„")
918 o
919 setDepth $ succNat depth
920 msg
921 setDepth $ depth
922 c
923 where
924 setDepth d =
925 liftStateMarkup $ S.modify' $ \s ->
926 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
Tools for writing technical documents