]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Write/HTML5.hs
sourcephile / git / doclang.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Improve checking.
[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 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 module Hdoc.DTC.Write.HTML5
11 ( module Hdoc.DTC.Write.HTML5
12 , module Hdoc.DTC.Write.HTML5.Ident
13 , module Hdoc.DTC.Write.HTML5.Base
14 , module Hdoc.DTC.Write.HTML5.Judgment
15 -- , module Hdoc.DTC.Write.HTML5.Error
16 ) where
17
18 import Control.Applicative (Applicative(..))
19 import Control.Monad (Monad(..), (=<<), forM_, mapM_, sequence_)
20 import Data.Bool
21 import Data.Default.Class (Default(..))
22 import Data.Either (Either(..))
23 import Data.Foldable (Foldable(..), concat, any)
24 import Data.Function (($), (.), const, on)
25 import Data.Functor ((<$>))
26 import Data.Functor.Compose (Compose(..))
27 import Data.IntMap.Strict (IntMap)
28 import Data.List.NonEmpty (NonEmpty(..))
29 import Data.Locale hiding (Index)
30 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList, listToMaybe)
31 import Data.Monoid (Monoid(..))
32 import Data.Ord (Ord(..))
33 import Data.Semigroup (Semigroup(..))
34 import Data.String (String)
35 import Data.TreeSeq.Strict (Tree(..), tree0)
36 import Data.Tuple (snd)
37 import System.FilePath ((</>))
38 import System.IO (IO)
39 import Text.Blaze ((!))
40 import Text.Blaze.Html (Html)
41 import Text.Show (Show(..))
42 import qualified Control.Category as Cat
43 import qualified Control.Monad.Trans.State as S
44 import qualified Data.HashMap.Strict as HM
45 import qualified Data.HashSet as HS
46 import qualified Data.IntMap.Strict as IntMap
47 import qualified Data.List as List
48 import qualified Data.Map.Strict as Map
49 import qualified Data.Sequence as Seq
50 import qualified Data.Strict.Maybe as Strict
51 import qualified Data.Text as Text
52 import qualified Data.Text.Lazy as TL
53 import qualified Data.TreeMap.Strict as TreeMap
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 Hdoc.DTC.Document as DTC
59 import Hdoc.DTC.Write.HTML5.Ident
60 import Hdoc.DTC.Write.Plain (Plainify(..))
61 import Hdoc.DTC.Write.XML ()
62 import Hdoc.Utils
63 import Control.Monad.Utils
64 import Text.Blaze.Utils
65 import qualified Hdoc.DTC.Check as Check
66 import qualified Hdoc.DTC.Collect as Collect
67 import qualified Hdoc.DTC.Index as Index
68 import qualified Hdoc.DTC.Write.Plain as Plain
69 import qualified Hdoc.TCT.Cell as TCT
70 import qualified Hdoc.Utils as FS
71 import qualified Hdoc.XML as XML
72 import qualified Paths_hdoc as Hdoc
73 import Hdoc.DTC.Write.HTML5.Base
74 import Hdoc.DTC.Write.HTML5.Judgment
75 import Hdoc.DTC.Write.HTML5.Error ()
76 import Debug.Trace
77
78 debug :: Show a => String -> a -> a
79 debug msg a = trace (msg<>": "<>show a) a
80 debugOn :: Show b => String -> (a -> b) -> a -> a
81 debugOn msg get a = trace (msg<>": "<>show (get a)) a
82 debugWith :: String -> (a -> String) -> a -> a
83 debugWith msg get a = trace (msg<>": "<>get a) a
84
85 writeHTML5 :: Config -> DTC.Document -> IO Html
86 writeHTML5 conf@Config{..} doc@DTC.Document{..} = do
87 let (checkedBody,checkState) =
88 let state_collect = Collect.collect doc in
89 Check.check body `S.runState` def
90 { Check.state_irefs = foldMap Index.irefsOfTerms $ Collect.all_index state_collect
91 , Check.state_collect
92 }
93 let (html5Body, endState) =
94 let Check.State{..} = checkState in
95 runComposeState def
96 { state_collect
97 , state_indexs =
98 (<$> Collect.all_index state_collect) $ \terms ->
99 (terms,) $
100 TreeMap.intersection const state_irefs $
101 Index.irefsOfTerms terms
102 , state_rrefs
103 , state_notes
104 , state_section = body
105 , state_l10n = loqualize config_locale
106 , state_plainify = def{Plain.state_l10n = loqualize config_locale}
107 } $ do
108 html5Judgments
109 html5ify state_errors
110 html5DocumentHead head
111 html5ify checkedBody
112 html5Head <- writeHTML5Head conf endState head
113 return $ do
114 let State{..} = endState
115 H.docType
116 H.html ! HA.lang (attrify $ countryCode config_locale) $ do
117 html5Head
118 H.body $ do
119 {-
120 unless (null state_scripts) $ do
121 -- NOTE: indicate that JavaScript is active.
122 H.script ! HA.type_ "application/javascript" $
123 "document.body.className = \"script\";"
124 -}
125 html5Body
126
127 writeHTML5Head :: Config -> State -> Head -> IO Html
128 writeHTML5Head Config{..} State{..} Head{DTC.about=About{..}} = do
129 csss :: Html <-
130 -- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do
131 (`foldMap` state_styles) $ \case
132 Left css -> do
133 content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>css)
134 return $ H.style ! HA.type_ "text/css" $
135 H.toMarkup content
136 Right content ->
137 return $ H.style ! HA.type_ "text/css" $
138 -- NOTE: as a special case, H.style wraps its content into an External,
139 -- so it does not HTML-escape its content.
140 H.toMarkup content
141 {-
142 case config_css of
143 Left "" -> mempty
144 Left css ->
145 H.link ! HA.rel "stylesheet"
146 ! HA.type_ "text/css"
147 ! HA.href (attrify css)
148 Right css ->
149 H.style ! HA.type_ "text/css" $
150 H.toMarkup css
151 -}
152 scripts :: Html <-
153 (`foldMap` state_scripts) $ \script -> do
154 content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>script)
155 return $ H.script ! HA.type_ "application/javascript" $
156 H.toMarkup content
157 {-
158 if not (any (\DTC.Link{rel} -> rel == "script") links)
159 then do
160 else
161 mempty
162 case config_js of
163 Left "" -> mempty
164 Left js -> H.script ! HA.src (attrify js)
165 ! HA.type_ "application/javascript"
166 $ mempty
167 Right js -> H.script ! HA.type_ "application/javascript"
168 $ H.toMarkup js
169 -}
170 return $
171 H.head $ do
172 H.meta ! HA.httpEquiv "Content-Type"
173 ! HA.content "text/html; charset=UTF-8"
174 unless (null titles) $ do
175 H.title $
176 H.toMarkup $ Plain.text state_plainify $ List.head titles
177 forM_ links $ \Link{..} ->
178 case rel of
179 "stylesheet" | URL "" <- href ->
180 H.style ! HA.type_ "text/css" $
181 H.toMarkup $ Plain.text def plain
182 _ ->
183 H.link ! HA.rel (attrify rel)
184 ! HA.href (attrify href)
185 forM_ url $ \href ->
186 H.link ! HA.rel "self"
187 ! HA.href (attrify href)
188 unless (TL.null config_generator) $ do
189 H.meta ! HA.name "generator"
190 ! HA.content (attrify config_generator)
191 unless (null tags) $
192 H.meta ! HA.name "keywords"
193 ! HA.content (attrify $ TL.intercalate ", " tags)
194 let chapters =
195 (`mapMaybe` toList state_section) $ \case
196 Tree (BodySection s) _ -> Just s
197 _ -> Nothing
198 forM_ chapters $ \Section{..} ->
199 H.link ! HA.rel "Chapter"
200 ! HA.title (attrify $ plainify section_title)
201 ! HA.href (refIdent $ identify section_posXML)
202 csss
203 scripts
204
205 html5DocumentHead :: Head -> HTML5
206 html5DocumentHead Head{DTC.about=About{..}, judgments} = do
207 st <- liftComposeState S.get
208 unless (null authors) $ do
209 H.div ! HA.class_ "document-head" $$
210 H.table $$ do
211 H.tbody $$ do
212 H.tr $$ do
213 H.td ! HA.class_ "left" $$ docHeaders
214 H.td ! HA.class_ "right" $$ docAuthors
215 unless (null titles) $ do
216 H.div ! HA.class_ "title"
217 ! HA.id "document-title." $$ do
218 forM_ titles $ \title ->
219 H.h1 ! HA.id (attrify $ identifyTitle (Plain.state_l10n $ state_plainify st) title) $$
220 html5ify title
221 do -- judgments
222 let sectionJudgments = HS.fromList judgments
223 let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
224 liftComposeState $ S.modify' $ \s ->
225 s{ state_judgments = sectionJudgments
226 , state_opinions =
227 -- NOTE: drop current opinions of the judgments of this section
228 HM.unionWith (const List.tail)
229 (state_opinions s)
230 opinsBySectionByJudgment
231 }
232 unless (null opinsBySectionByJudgment) $ do
233 let choicesJ = Collect.choicesByJudgment judgments
234 forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},opinsBySection) -> do
235 H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do
236 html5ify judgment
237 { judgment_opinionsByChoice = listToMaybe opinsBySection
238 , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
239 }
240 where
241 docHeaders =
242 H.table ! HA.class_ "document-headers" $$
243 H.tbody $$ do
244 Loqualization l10n <- liftComposeState $ S.gets state_l10n
245 forM_ series $ \s@Serie{id=id_, name} ->
246 header $
247 case urlSerie s of
248 Nothing -> do
249 headerName $ html5ify name
250 headerValue $ html5ify id_
251 Just href -> do
252 headerName $ html5ify name
253 headerValue $
254 H.a ! HA.href (attrify href) $$
255 html5ify id_
256 forM_ links $ \Link{..} ->
257 unless (TL.null $ unName name) $
258 header $ do
259 headerName $ html5ify name
260 headerValue $ html5ify $ Tree PlainEref{eref_href=href} plain
261 forM_ date $ \d ->
262 header $ do
263 headerName $ l10n_Header_Date l10n
264 headerValue $ html5ify d
265 forM_ url $ \href ->
266 header $ do
267 headerName $ l10n_Header_Address l10n
268 headerValue $ html5ify $ tree0 $ PlainEref{eref_href=href}
269 forM_ headers $ \Header{..} ->
270 header $ do
271 headerName $ html5ify name
272 headerValue $ html5ify value
273 docAuthors =
274 H.table ! HA.class_ "document-authors" $$
275 H.tbody $$ do
276 forM_ authors $ \a ->
277 H.tr $$
278 H.td ! HA.class_ "author" $$
279 html5ify a
280 header :: HTML5 -> HTML5
281 header hdr = H.tr ! HA.class_ "header" $$ hdr
282 headerName :: HTML5 -> HTML5
283 headerName hdr =
284 H.td ! HA.class_ "header-name" $$ do
285 hdr
286 Loqualization l10n <- liftComposeState $ S.gets state_l10n
287 Plain.l10n_Colon l10n
288 headerValue :: HTML5 -> HTML5
289 headerValue hdr =
290 H.td ! HA.class_ "header-value" $$ do
291 hdr
292
293 -- 'Html5ify' instances
294 instance Html5ify TCT.Location where
295 html5ify = \case
296 s:|[] ->
297 H.span ! HA.class_ "tct-location" $$
298 html5ify $ show s
299 ss -> do
300 H.ul ! HA.class_ "tct-location" $$
301 forM_ ss $ \s ->
302 H.li $$
303 html5ify $ show s
304 instance Html5ify Body where
305 html5ify body = do
306 liftComposeState $ S.modify' $ \s -> s{state_section = body}
307 mapM_ html5ify body
308 case Seq.viewr body of
309 _ Seq.:> Tree BodyBlock{} _ -> do
310 notes <- liftComposeState $ S.gets state_notes
311 maybe mempty html5Notes $
312 Map.lookup mempty notes
313 _ -> mempty
314 instance Html5ify (Tree BodyNode) where
315 html5ify (Tree b bs) =
316 case b of
317 BodyBlock blk -> html5ify blk
318 BodySection Section{..} -> do
319 st@State{state_collect=Collect.All{..}} <- liftComposeState S.get
320 liftComposeState $ S.modify' $ \s -> s{state_section = bs}
321 do -- notes
322 let mayNotes = do
323 sectionPosPath <- XML.ancestors $ XML.pos_ancestors section_posXML
324 let (sectionNotes, notes) = Map.updateLookupWithKey (\_ _ -> Nothing) sectionPosPath $ state_notes st
325 (,notes) <$> sectionNotes
326 case mayNotes of
327 Nothing -> mempty
328 Just (sectionNotes, state_notes) -> do
329 liftComposeState $ S.modify' $ \s -> s{state_notes}
330 html5Notes sectionNotes
331 html5CommonAttrs section_attrs{classes="section":classes section_attrs, id=Nothing} $
332 H.section ! HA.id (attrify $ identify section_posXML) $$ do
333 forM_ section_aliases html5ify
334 do -- judgments
335 let sectionJudgments = state_judgments st `HS.union` HS.fromList section_judgments
336 let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
337 let dropChildrenBlocksJudgments =
338 -- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's
339 -- directly children of this 'BodySection'.
340 if (`any`bs) $ \case
341 Tree BodyBlock{} _ -> True
342 _ -> False
343 then List.tail
344 else Cat.id
345 liftComposeState $ S.modify' $ \s ->
346 s{ state_judgments = sectionJudgments
347 , state_opinions =
348 -- NOTE: drop current opinions of the judgments of this section
349 HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
350 (state_opinions s)
351 opinsBySectionByJudgment
352 }
353 unless (null opinsBySectionByJudgment) $ do
354 liftComposeState $ S.modify' $ \s -> s
355 { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
356 H.aside ! HA.class_ "aside" $$ do
357 let choicesJ = Collect.choicesByJudgment section_judgments
358 forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{..},opinsBySection) -> do
359 H.div ! HA.class_ "judgment section-judgment" $$ do
360 html5ify judgment
361 { judgment_opinionsByChoice = listToMaybe opinsBySection
362 , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
363 }
364 let mayId =
365 case toList <$> HM.lookup section_title all_section of
366 Just [_] -> Just $ identifyTitle (Plain.state_l10n $ state_plainify st) section_title
367 _ -> Nothing
368 H.table
369 ! HA.class_ "section-header"
370 !?? mayAttr HA.id mayId $$
371 H.tbody $$
372 H.tr $$ do
373 H.td ! HA.class_ "section-number" $$ do
374 html5SectionNumber $ XML.pos_ancestors section_posXML
375 H.td ! HA.class_ "section-title" $$ do
376 (case List.length $ XML.pos_ancestors section_posXML of
377 0 -> H.h1
378 1 -> H.h2
379 2 -> H.h3
380 3 -> H.h4
381 4 -> H.h5
382 5 -> H.h6
383 _ -> H.h6) $$
384 html5ify section_title
385 forM_ bs html5ify
386 do -- judgments
387 liftComposeState $ S.modify' $ \s ->
388 s{ state_judgments = state_judgments st }
389 do -- notes
390 notes <- liftComposeState $ S.gets state_notes
391 maybe mempty html5Notes $
392 Map.lookup (XML.pos_ancestors section_posXML) notes
393 liftComposeState $ S.modify' $ \s -> s{state_section = state_section st}
394 instance Html5ify Block where
395 html5ify = \case
396 BlockPara para -> html5ify para
397 BlockBreak{..} ->
398 html5CommonAttrs attrs
399 { classes = "page-break":"print-only":classes attrs } $
400 H.div $$
401 H.p $$ " " -- NOTE: force page break
402 BlockToC{..} ->
403 H.nav ! HA.class_ "toc"
404 ! HA.id (attrify $ identify posXML) $$ do
405 H.span ! HA.class_ "toc-name" $$
406 H.a ! HA.href (refIdent $ identify posXML) $$ do
407 Loqualization l10n <- liftComposeState $ S.gets state_l10n
408 Plain.l10n_Table_of_Contents l10n
409 H.ul $$ do
410 State{state_section} <- liftComposeState S.get
411 forM_ state_section $ html5ifyToC depth
412 BlockToF{..} -> do
413 H.nav ! HA.class_ "tof"
414 ! HA.id (attrify $ identify posXML) $$
415 H.table ! HA.class_ "tof" $$
416 H.tbody $$
417 html5ifyToF types
418 BlockAside{..} ->
419 html5CommonAttrs attrs $
420 H.aside ! HA.class_ "aside" $$ do
421 forM_ blocks html5ify
422 BlockFigure{..} ->
423 html5CommonAttrs attrs
424 { classes = "figure":("figure-"<>type_):classes attrs
425 , DTC.id = Just $ identify $ XML.pos_ancestorsWithFigureNames posXML
426 } $
427 H.div $$ do
428 H.table ! HA.class_ "figure-caption" $$
429 H.tbody $$
430 H.tr $$ do
431 if TL.null type_
432 then H.a ! HA.href (refIdent $ identify posXML) $$ mempty
433 else
434 H.td ! HA.class_ "figure-number" $$ do
435 H.a ! HA.href (refIdent $ identify $ XML.pos_ancestorsWithFigureNames posXML) $$ do
436 html5ify type_
437 html5ify $ XML.pos_ancestorsWithFigureNames posXML
438 forM_ mayTitle $ \title -> do
439 H.td ! HA.class_ "figure-colon" $$ do
440 unless (TL.null type_) $ do
441 Loqualization l10n <- liftComposeState $ S.gets state_l10n
442 Plain.l10n_Colon l10n
443 H.td ! HA.class_ "figure-title" $$ do
444 html5ify title
445 H.div ! HA.class_ "figure-content" $$ do
446 html5ify paras
447 BlockIndex{posXML} -> do
448 st@State{..} <- liftComposeState S.get
449 liftComposeState $ S.put st
450 { state_styles = HS.insert (Left "dtc-index.css") state_styles }
451 let (allTerms,refsByTerm) = state_indexs Map.!posXML
452 let chars = Index.termsByChar allTerms
453 H.div ! HA.class_ "index"
454 ! HA.id (attrify $ identify posXML) $$ do
455 H.nav ! HA.class_ "index-nav" $$ do
456 forM_ (Map.keys chars) $ \char ->
457 H.a ! HA.href (refIdent (identify posXML <> "." <> identify char)) $$
458 html5ify char
459 H.dl ! HA.class_ "index-chars" $$
460 forM_ (Map.toList chars) $ \(char,terms) -> do
461 H.dt $$ do
462 let i = identify posXML <> "." <> identify char
463 H.a ! HA.id (attrify i)
464 ! HA.href (refIdent i) $$
465 html5ify char
466 H.dd $$
467 H.dl ! HA.class_ "index-term" $$ do
468 forM_ terms $ \aliases -> do
469 H.dt $$
470 H.ul ! HA.class_ "index-aliases" $$
471 forM_ (List.take 1 aliases) $ \term -> do
472 H.li ! HA.id (attrify $ identifyIref term) $$
473 html5ify term
474 H.dd $$
475 let anchs =
476 List.sortBy (compare `on` anchor_section . snd) $
477 (`foldMap` aliases) $ \words ->
478 fromJust $ do
479 path <- Index.pathFromWords words
480 Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
481 TreeMap.lookup path refsByTerm in
482 html5CommasDot $
483 (<$> anchs) $ \(term,Anchor{..}) ->
484 H.a ! HA.class_ "index-iref"
485 ! HA.href (refIdent $ identifyIrefCount term anchor_count) $$
486 html5ify $ XML.pos_ancestors anchor_section
487 BlockReferences{..} ->
488 html5CommonAttrs attrs
489 { classes = "references":classes attrs
490 , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors posXML
491 } $
492 H.div $$ do
493 H.table $$
494 forM_ refs html5ify
495 BlockGrades{..} ->
496 html5CommonAttrs attrs
497 { classes = "grades":classes attrs
498 , DTC.id = Just $ Ident $ Plain.text def $ XML.pos_ancestors posXML
499 } $
500 H.div $$ do
501 -- let dg = List.head $ List.filter default_ scale
502 -- let sc = MJ.Scale (Set.fromList scale) dg
503 -- o :: Map choice grade
504 -- os :: Opinions (Map judge (Opinion choice grade))
505 mempty
506 -- html5ify $ show b
507 BlockJudges js -> html5ify js
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_ posXML
519 } $
520 H.div $$
521 forM_ items $ \item ->
522 html5AttrClass (cls item) $
523 html5ify item
524 where
525 id_ = Just . Ident . Plain.text def . XML.pos_ancestors
526 cls = \case
527 ParaPlain{} -> []
528 ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
529 ParaQuote{..} -> ["quote", "quote-"<>type_]
530 ParaComment{} -> []
531 ParaOL{} -> ["ol"]
532 ParaUL{} -> ["ul"]
533 ParaJudgment Judgment{..} -> ["judgment"] <> when (null judgment_opinionsByChoice) ["judgment-error"]
534 instance Html5ify ParaItem where
535 html5ify = \case
536 ParaPlain p -> H.p $$ html5ify p
537 ParaArtwork{..} -> H.pre $$ do html5ify text
538 ParaQuote{..} -> H.div $$ do html5ify paras
539 ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
540 ParaOL items ->
541 H.table $$ do
542 H.tbody $$
543 forM_ items $ \ListItem{..} -> do
544 H.tr $$ do
545 H.td ! HA.class_ "name" $$ do
546 html5ify name
547 "."::HTML5
548 H.td ! HA.class_ "value" $$
549 html5ify paras
550 ParaUL items ->
551 H.dl $$ do
552 forM_ items $ \item -> do
553 H.dt $$ "—"
554 H.dd $$ html5ify item
555 ParaJudgment j -> html5ify j
556 instance Html5ify [Para] where
557 html5ify = mapM_ html5ify
558 instance Html5ify Plain where
559 html5ify ps =
560 case Seq.viewl ps of
561 Seq.EmptyL -> mempty
562 curr Seq.:< next ->
563 case curr of
564 -- NOTE: gather adjacent PlainNotes
565 Tree PlainNote{} _
566 | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
567 H.sup ! HA.class_ "note-numbers" $$ do
568 html5ify curr
569 forM_ notes $ \note -> do
570 ", "::HTML5
571 html5ify note
572 " "::HTML5
573 html5ify rest
574 --
575 _ -> do
576 html5ify curr
577 html5ify next
578 instance Html5ify (Tree PlainNode)
579 where html5ify (Tree n ls) =
580 case n of
581 PlainBreak -> html5ify H.br
582 PlainText t -> html5ify t
583 PlainGroup -> html5ify ls
584 PlainB -> H.strong $$ html5ify ls
585 PlainCode -> H.code $$ html5ify ls
586 PlainDel -> H.del $$ html5ify ls
587 PlainI -> do
588 i <- liftComposeState $ do
589 i <- S.gets $ Plain.state_italic . state_plainify
590 S.modify $ \s ->
591 s{state_plainify=
592 (state_plainify s){Plain.state_italic=
593 not i}}
594 return i
595 H.em ! HA.class_ (if i then "even" else "odd") $$
596 html5ify ls
597 liftComposeState $
598 S.modify $ \s ->
599 s{state_plainify=
600 (state_plainify s){Plain.state_italic=i}}
601 PlainSpan{..} ->
602 html5CommonAttrs attrs $
603 H.span $$ html5ify ls
604 PlainSub -> H.sub $$ html5ify ls
605 PlainSup -> H.sup $$ html5ify ls
606 PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
607 PlainU -> H.span ! HA.class_ "underline" $$ html5ify ls
608 PlainNote{..} ->
609 case note_number of
610 Nothing -> mempty
611 Just num ->
612 H.a ! HA.class_ "note-ref"
613 ! HA.id ("note-ref."<>attrify num)
614 ! HA.href ("#note."<>attrify num) $$
615 html5ify num
616 PlainQ -> do
617 H.span ! HA.class_ "q" $$ do
618 Loqualization l10n <- liftComposeState $ S.gets state_l10n
619 Plain.l10n_Quote (html5ify $ Tree PlainI ls) l10n
620 PlainEref{..} ->
621 H.a ! HA.class_ "eref"
622 ! HA.href (attrify eref_href) $$
623 if null ls
624 then html5ify $ unURL eref_href
625 else html5ify ls
626 PlainIref{..} ->
627 case iref_anchor of
628 Nothing -> html5ify ls
629 Just Anchor{..} ->
630 H.span ! HA.class_ "iref"
631 ! HA.id (attrify $ identifyIrefCount iref_term anchor_count) $$
632 html5ify ls
633 PlainTag{..} -> do
634 st <- liftComposeState S.get
635 let l10n = Plain.state_l10n $ state_plainify st
636 case tag_error of
637 Nothing ->
638 H.a ! HA.class_ "tag"
639 ! HA.href (refIdent $ identifyTitle l10n $ Title ls) $$
640 html5ify ls
641 Just (ErrorTarget_Unknown num) ->
642 H.span ! HA.class_ "tag tag-unknown"
643 ! HA.id (attrify $ identifyTag "-unknown" l10n ls (Just num)) $$
644 html5ify ls
645 Just (ErrorTarget_Ambiguous num) ->
646 H.span ! HA.class_ "tag tag-ambiguous"
647 ! HA.id (attrify $ identifyTag "-ambiguous" l10n ls num) $$
648 html5ify ls
649 PlainRref{..} -> do
650 case rref_error of
651 Nothing ->
652 let ref = do
653 "["::HTML5
654 H.a ! HA.class_ "reference"
655 ! HA.href (refIdent $ identifyReference "" rref_to Nothing)
656 ! HA.id (attrify $ identifyReference "" rref_to rref_number) $$
657 html5ify rref_to
658 "]" in
659 case toList ls of
660 [] -> ref
661 [Tree (PlainText "") _] -> do
662 refs <- liftComposeState $ S.gets $ Collect.all_reference . state_collect
663 case toList <$> HM.lookup rref_to refs of
664 Just [Reference{reference_about=About{..}}] -> do
665 forM_ (List.take 1 titles) $ \(Title title) -> do
666 html5ify $ Tree PlainQ $
667 case url of
668 Nothing -> title
669 Just u -> pure $ Tree (PlainEref u) title
670 " "::HTML5
671 ref
672 _ -> mempty
673 _ -> do
674 H.a ! HA.class_ "reference"
675 ! HA.href (refIdent $ identifyReference "" rref_to Nothing)
676 ! HA.id (attrify $ identifyReference "" rref_to rref_number) $$
677 html5ify ls
678 H.span ! HA.class_ "print-only" $$ do
679 " "::HTML5
680 ref
681 Just (ErrorTarget_Unknown num) -> do
682 "["::HTML5
683 H.span ! HA.class_ "reference reference-unknown"
684 ! HA.id (attrify $ identifyReference "-unknown" rref_to $ Just num) $$
685 html5ify rref_to
686 "]"
687 Just (ErrorTarget_Ambiguous num) -> do
688 case toList ls of
689 [] -> mempty
690 [Tree (PlainText "") _] -> mempty
691 _ -> do
692 html5ify ls
693 " "::HTML5
694 "["::HTML5
695 H.span ! HA.class_ "reference reference-ambiguous"
696 !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" rref_to . Just <$> num) $$
697 html5ify rref_to
698 "]"
699 instance Html5ify [Title] where
700 html5ify =
701 html5ify . fold . List.intersperse sep . toList
702 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
703 instance Html5ify Title where
704 html5ify (Title t) = html5ify t
705 instance Html5ify About where
706 html5ify About{..} = do
707 html5Lines
708 [ html5CommasDot $ concat $
709 [ html5Titles titles
710 , html5ify <$> authors
711 , html5ify <$> maybeToList date
712 , html5ify <$> maybeToList editor
713 , html5ify <$> series
714 ]
715 , forM_ url $ \u ->
716 H.span ! HA.class_ "print-only" $$ do
717 "<"::HTML5
718 html5ify u
719 ">"
720 ]
721 where
722 html5Titles :: [Title] -> [HTML5]
723 html5Titles ts | null ts = []
724 html5Titles ts = [html5Title $ joinTitles ts]
725 where
726 joinTitles = fold . List.intersperse sep . toList
727 sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
728 html5Title (Title title) =
729 html5ify $ Tree PlainQ $
730 case url of
731 Nothing -> title
732 Just u -> pure $ Tree (PlainEref u) title
733 instance Html5ify Serie where
734 html5ify s@Serie{id=id_, name} = do
735 Loqualization l10n <- liftComposeState $ S.gets state_l10n
736 case urlSerie s of
737 Nothing -> do
738 html5ify name
739 Plain.l10n_Colon l10n :: HTML5
740 html5ify id_
741 Just href -> do
742 html5ify $
743 Tree PlainEref{eref_href=href} $
744 Seq.fromList
745 [ tree0 $ PlainText $ unName name
746 , tree0 $ PlainText $ Plain.l10n_Colon l10n
747 , tree0 $ PlainText id_
748 ]
749 instance Html5ify Entity where
750 html5ify Entity{..} = do
751 case () of
752 _ | not (TL.null email) -> do
753 H.span ! HA.class_ "no-print" $$
754 html5ify $
755 Tree (PlainEref $ URL $ "mailto:"<>email) $
756 pure $ tree0 $ PlainText name
757 H.span ! HA.class_ "print-only" $$
758 html5ify $
759 Tree PlainGroup $ Seq.fromList
760 [ tree0 $ PlainText name
761 , tree0 $ PlainText " <"
762 , Tree (PlainEref $ URL $ "mailto:"<>email) $
763 pure $ tree0 $ PlainText email
764 , tree0 $ PlainText ">"
765 ]
766 _ | Just u <- url ->
767 html5ify $
768 Tree (PlainEref u) $
769 pure $ tree0 $ PlainText name
770 _ ->
771 html5ify $
772 tree0 $ PlainText name
773 forM_ org $ \o -> do
774 " ("::HTML5
775 html5ify o
776 ")"::HTML5
777 instance Html5ify Words where
778 html5ify = html5ify . Index.plainifyWords
779 instance Html5ify Alias where
780 html5ify Alias{..} = do
781 st@State{state_collect=Collect.All{..}} <- liftComposeState S.get
782 let l10n = Plain.state_l10n $ state_plainify st
783 case toList <$> HM.lookup title all_section of
784 Just [_] ->
785 H.a ! HA.class_ "alias"
786 ! HA.id (attrify $ identifyTitle l10n title) $$
787 mempty
788 _ -> mempty
789 instance Html5ify URL where
790 html5ify (URL url) =
791 H.a ! HA.class_ "eref"
792 ! HA.href (attrify url) $$
793 html5ify url
794 instance Html5ify Date where
795 html5ify date = do
796 Loqualization l10n <- liftComposeState $ S.gets state_l10n
797 Plain.l10n_Date date l10n
798 instance Html5ify Reference where
799 html5ify Reference{..} =
800 H.tr $$ do
801 H.td ! HA.class_ "reference-key" $$
802 html5ify $ tree0 PlainRref
803 { rref_number = Nothing
804 , rref_locTCT = def
805 , rref_to = reference_id
806 , rref_error = (<$> reference_error) $ \case
807 ErrorAnchor_Ambiguous num -> ErrorTarget_Ambiguous (Just num)
808 }
809 H.td ! HA.class_ "reference-content" $$ do
810 html5ify reference_about
811 rrefs <- liftComposeState $ S.gets state_rrefs
812 case HM.lookup reference_id rrefs of
813 Nothing -> pure ()
814 Just anchs ->
815 H.span ! HA.class_ "reference-rrefs" $$
816 html5CommasDot $
817 (<$> List.reverse anchs) $ \(maySection,num) ->
818 H.a ! HA.class_ "reference-rref"
819 ! HA.href (refIdent $ identifyReference "" reference_id $ Just num) $$
820 case maySection of
821 Nothing -> "0"::HTML5
822 Just Section{section_posXML=posSection} -> html5ify $ XML.pos_ancestors posSection
823 instance Html5ify XML.Ancestors where
824 html5ify ancs =
825 case toList ancs of
826 [(_n,c)] -> do
827 html5ify $ show c
828 html5ify '.'
829 as ->
830 html5ify $
831 Text.intercalate "." $
832 Text.pack . show . snd <$> as
833 instance Html5ify Plain.Plain where
834 html5ify p = do
835 sp <- liftComposeState $ S.gets state_plainify
836 let (t,sp') = Plain.runPlain p sp
837 html5ify t
838 liftComposeState $ S.modify $ \s -> s{state_plainify=sp'}
839 {-
840 instance Html5ify SVG.Element where
841 html5ify svg =
842 html5ify $
843 B.preEscapedLazyText $
844 SVG.renderText svg
845 instance Semigroup SVG.Element where
846 (<>) = mappend
847 -}
848
849 html5CommasDot :: [HTML5] -> HTML5
850 html5CommasDot [] = pure ()
851 html5CommasDot hs = do
852 sequence_ $ List.intersperse ", " hs
853 "."
854
855 html5Lines :: [HTML5] -> HTML5
856 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs
857
858 html5Words :: [HTML5] -> HTML5
859 html5Words hs = sequence_ $ List.intersperse " " hs
860
861 html5SectionNumber :: XML.Ancestors -> HTML5
862 html5SectionNumber = go mempty
863 where
864 go :: XML.Ancestors -> XML.Ancestors -> HTML5
865 go prev next =
866 case Seq.viewl next of
867 Seq.EmptyL -> pure ()
868 a@(_n,rank) Seq.:< as -> do
869 H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$
870 html5ify $ show rank
871 when (not (null as) || null prev) $ do
872 html5ify '.'
873 go (prev Seq.|>a) as
874
875 html5SectionRef :: XML.Ancestors -> HTML5
876 html5SectionRef as =
877 H.a ! HA.href (refIdent $ identify as) $$
878 html5ify as
879
880 html5Notes :: IntMap [Para] -> HTML5
881 html5Notes notes =
882 H.aside ! HA.class_ "notes" $$ do
883 Compose $ pure H.hr
884 H.table $$
885 H.tbody $$
886 forM_ (IntMap.toList notes) $ \(number,content) ->
887 H.tr $$ do
888 H.td ! HA.class_ "note-ref" $$ do
889 H.a ! HA.class_ "note-number"
890 ! HA.id ("note."<>attrify number)
891 ! HA.href ("#note."<>attrify number) $$ do
892 html5ify number
893 ". "::HTML5
894 H.a ! HA.href ("#note-ref."<>attrify number) $$ do
895 "↑"
896 H.td $$
897 html5ify content
898
899 html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5
900 html5ifyToC depth (Tree b bs) =
901 case b of
902 BodySection Section{..} -> do
903 H.li $$ do
904 H.table ! HA.class_ "toc-entry" $$
905 H.tbody $$
906 H.tr $$ do
907 H.td ! HA.class_ "section-number" $$
908 html5SectionRef $ XML.pos_ancestors section_posXML
909 H.td ! HA.class_ "section-title" $$
910 html5ify $ cleanPlain $ unTitle section_title
911 when (maybe True (> Nat 1) depth && not (null sections)) $
912 H.ul $$
913 forM_ sections $
914 html5ifyToC (depth >>= predNat)
915 _ -> mempty
916 where
917 sections =
918 (`Seq.filter` bs) $ \case
919 Tree BodySection{} _ -> True
920 _ -> False
921
922 html5ifyToF :: [TL.Text] -> HTML5
923 html5ifyToF types = do
924 figuresByType <- liftComposeState $ S.gets $ Collect.all_figure . state_collect
925 let figures =
926 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
927 if null types
928 then figuresByType
929 else
930 Map.intersection figuresByType $
931 Map.fromList [(ty,()) | ty <- types]
932 forM_ (Map.toList figures) $ \(posXML, (type_, title)) ->
933 H.tr $$ do
934 H.td ! HA.class_ "figure-number" $$
935 H.a ! HA.href (refIdent $ identify posXML) $$ do
936 html5ify type_
937 html5ify $ XML.pos_ancestors posXML
938 forM_ title $ \ti ->
939 H.td ! HA.class_ "figure-title" $$
940 html5ify $ cleanPlain $ unTitle ti
941
942 -- 'Attrify'
943 instance Attrify Plain.Plain where
944 attrify p = attrify t
945 where (t,_) = Plain.runPlain p def
Tools for writing technical documents