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