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