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