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