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