]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Write/HTML5.hs
Add error support in HTML5.
[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 {-# LANGUAGE TypeApplications #-}
10 {-# LANGUAGE ViewPatterns #-}
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module Hdoc.DTC.Write.HTML5 where
13
14 -- import Control.Arrow (first)
15 import Control.Applicative (Applicative(..))
16 import Control.Monad (Monad(..), join, (=<<), forM, forM_, mapM_, sequence_)
17 import Data.Bool
18 import Data.Char (Char)
19 import Data.Default.Class (Default(..))
20 import Data.Either (Either(..))
21 import Data.Eq (Eq(..))
22 import Data.Foldable (Foldable(..), concat, any)
23 import Data.Function (($), (.), const, on)
24 import Data.Functor ((<$>))
25 import Data.Functor.Compose (Compose(..))
26 import Data.Int (Int)
27 import Data.IntMap.Strict (IntMap)
28 import Data.List.NonEmpty (NonEmpty(..))
29 import Data.Locale hiding (Index)
30 import Data.Map.Strict (Map)
31 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList, listToMaybe, fromMaybe, isJust)
32 import Data.Monoid (Monoid(..))
33 import Data.Ord (Ord(..))
34 import Data.Semigroup (Semigroup(..))
35 import Data.String (String, IsString(..))
36 import Data.Text (Text)
37 import Data.TreeSeq.Strict (Tree(..), tree0)
38 import Data.Tuple (fst, snd)
39 import Prelude (mod, (*), Fractional(..), Double, toRational, RealFrac(..))
40 import System.FilePath (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.State as S
47 import qualified Data.Char as Char
48 import qualified Data.HashMap.Strict as HM
49 import qualified Data.HashSet as HS
50 import qualified Data.IntMap.Strict as IntMap
51 import qualified Data.List as List
52 import qualified Data.Map.Strict as Map
53 import qualified Data.Sequence as Seq
54 import qualified Data.Set as Set
55 import qualified Data.Strict.Maybe as Strict
56 import qualified Data.Text as Text
57 import qualified Data.Text.Lazy as TL
58 import qualified Data.Tree as Tree
59 import qualified Data.TreeMap.Strict as TreeMap
60 import qualified Data.TreeSeq.Strict as TreeSeq
61 import qualified Hjugement as MJ
62 import qualified Prelude (error)
63 import qualified Text.Blaze.Html5 as H
64 import qualified Text.Blaze.Html5.Attributes as HA
65 import qualified Text.Blaze.Internal as H
66
67 import Text.Blaze.Utils
68
69 import Hdoc.TCT.Cell as TCT
70 import Hdoc.DTC.Document as DTC
71 import Hdoc.DTC.Write.HTML5.Ident
72 import Hdoc.DTC.Write.Plain (Plainify(..))
73 import Hdoc.DTC.Write.XML ()
74 import Hdoc.Utils
75 import qualified Hdoc.DTC.Check as Check
76 import qualified Hdoc.DTC.Collect as Collect
77 import qualified Hdoc.DTC.Index as Index
78 import qualified Hdoc.DTC.Write.Plain as Plain
79 import qualified Hdoc.Utils as FS
80 import qualified Paths_hdoc as Hdoc
81 import Debug.Trace
82
83 debug :: Show a => String -> a -> a
84 debug msg a = trace (msg<>": "<>show a) a
85 debugOn :: Show b => String -> (a -> b) -> a -> a
86 debugOn msg get a = trace (msg<>": "<>show (get a)) a
87 debugWith :: String -> (a -> String) -> a -> a
88 debugWith msg get a = trace (msg<>": "<>get a) a
89
90 showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
91 showJudgments js =
92 Tree.drawForest $
93 ((show <$>) <$>) $
94 -- Tree.Node (Left ("","",Nothing)) $
95 (<$> HM.toList js) $ \((j,g,q),ts) ->
96 Tree.Node
97 (Left (unIdent j,unIdent g,Plain.text def <$> q))
98 ((Right <$>) <$> ts)
99
100 -- * Type 'HTML5'
101 type HTML5 = StateMarkup State ()
102 instance IsString HTML5 where
103 fromString = html5ify
104
105 -- ** Type 'Config'
106 data Config =
107 forall locales.
108 ( Locales locales
109 , Loqualize locales (L10n HTML5)
110 , Loqualize locales (Plain.L10n Plain.Plain)
111 ) =>
112 Config
113 { config_css :: Either FilePath TL.Text
114 , config_js :: Either FilePath TL.Text
115 , config_locale :: LocaleIn locales
116 , config_generator :: TL.Text
117 }
118 instance Default Config where
119 def = Config
120 { config_css = Right "style/dtc-html5.css"
121 , config_js = Right "style/dtc-html5.js"
122 , config_locale = LocaleIn @'[EN] en_US
123 , config_generator = "https://hackage.haskell.org/package/hdoc"
124 }
125
126 -- ** Type 'State'
127 data State = State
128 -- RW
129 { state_styles :: HS.HashSet (Either FilePath TL.Text)
130 , state_scripts :: HS.HashSet FilePath
131 , state_notes :: Check.NotesBySection
132 , state_judgments :: HS.HashSet Judgment
133 , state_opinions :: HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
134 -- RO
135 , state_section :: TreeSeq.Trees BodyNode
136 , state_collect :: Collect.All
137 , state_indexs :: Map XmlPos (Terms, Index.Irefs) -- TODO: could be a list
138 , state_rrefs :: HM.HashMap Ident [(Maybe Section,Nat1)]
139 , state_plainify :: Plain.State
140 , state_l10n :: Loqualization (L10n HTML5)
141 }
142 instance Default State where
143 def = State
144 { state_styles = HS.fromList [Left "dtc-html5.css"]
145 , state_scripts = def
146 , state_section = def
147 , state_collect = def
148 , state_indexs = def
149 , state_rrefs = def
150 , state_notes = def
151 , state_plainify = def
152 , state_l10n = Loqualization EN_US
153 , state_judgments = HS.empty
154 , state_opinions = def
155 }
156
157 writeHTML5 :: Config -> DTC.Document -> IO Html
158 writeHTML5 conf@Config{..} doc@DTC.Document{..} = do
159 let collect@Collect.All{..} = Collect.collect doc
160 let (checkedBody,checkState) =
161 Check.check body `S.runState` def
162 { Check.state_irefs = foldMap Index.irefsOfTerms all_index
163 , Check.state_collect = collect
164 }
165 let (html5Body, endState) =
166 let Check.State{..} = checkState in
167 runStateMarkup def
168 { state_collect
169 , state_indexs =
170 (<$> all_index) $ \terms ->
171 (terms,) $
172 TreeMap.intersection const state_irefs $
173 Index.irefsOfTerms terms
174 , state_rrefs
175 , state_notes
176 , state_section = body
177 , state_l10n = loqualize config_locale
178 , state_plainify = def{Plain.state_l10n = loqualize config_locale}
179 } $ do
180 html5Judgments
181 html5ify state_errors
182 html5DocumentHead head
183 html5ify checkedBody
184 html5Head <- writeHTML5Head conf endState head
185 return $ do
186 let State{..} = endState
187 H.docType
188 H.html ! HA.lang (attrify $ countryCode config_locale) $ do
189 html5Head
190 H.body $ do
191 {-
192 unless (null state_scripts) $ do
193 -- NOTE: indicate that JavaScript is active.
194 H.script ! HA.type_ "application/javascript" $
195 "document.body.className = \"script\";"
196 -}
197 html5Body
198
199 writeHTML5Head :: Config -> State -> Head -> IO Html
200 writeHTML5Head Config{..} State{..} Head{DTC.about=About{..}} = do
201 csss :: Html <-
202 -- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do
203 (`foldMap` state_styles) $ \case
204 Left css -> do
205 content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>css)
206 return $ H.style ! HA.type_ "text/css" $
207 H.toMarkup content
208 Right content ->
209 return $ H.style ! HA.type_ "text/css" $
210 -- NOTE: as a special case, H.style wraps its content into an External,
211 -- so it does not HTML-escape its content.
212 H.toMarkup content
213 {-
214 case config_css of
215 Left "" -> mempty
216 Left css ->
217 H.link ! HA.rel "stylesheet"
218 ! HA.type_ "text/css"
219 ! HA.href (attrify css)
220 Right css ->
221 H.style ! HA.type_ "text/css" $
222 H.toMarkup css
223 -}
224 scripts :: Html <-
225 (`foldMap` state_scripts) $ \script -> do
226 content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>script)
227 return $ H.script ! HA.type_ "application/javascript" $
228 H.toMarkup content
229 {-
230 if not (any (\DTC.Link{rel} -> rel == "script") links)
231 then do
232 else
233 mempty
234 case config_js of
235 Left "" -> mempty
236 Left js -> H.script ! HA.src (attrify js)
237 ! HA.type_ "application/javascript"
238 $ mempty
239 Right js -> H.script ! HA.type_ "application/javascript"
240 $ H.toMarkup js
241 -}
242 return $
243 H.head $ do
244 H.meta ! HA.httpEquiv "Content-Type"
245 ! HA.content "text/html; charset=UTF-8"
246 unless (null titles) $ do
247 H.title $
248 H.toMarkup $ Plain.text state_plainify $ List.head titles
249 forM_ links $ \Link{..} ->
250 case rel of
251 "stylesheet" | URL "" <- href ->
252 H.style ! HA.type_ "text/css" $
253 H.toMarkup $ Plain.text def plain
254 _ ->
255 H.link ! HA.rel (attrify rel)
256 ! HA.href (attrify href)
257 forM_ url $ \href ->
258 H.link ! HA.rel "self"
259 ! HA.href (attrify href)
260 unless (TL.null config_generator) $ do
261 H.meta ! HA.name "generator"
262 ! HA.content (attrify config_generator)
263 unless (null tags) $
264 H.meta ! HA.name "keywords"
265 ! HA.content (attrify $ TL.intercalate ", " tags)
266 let chapters =
267 (`mapMaybe` toList state_section) $ \case
268 Tree (BodySection s) _ -> Just s
269 _ -> Nothing
270 forM_ chapters $ \Section{..} ->
271 H.link ! HA.rel "Chapter"
272 ! HA.title (attrify $ plainify title)
273 ! HA.href (refIdent $ identify xmlPos)
274 csss
275 scripts
276
277 html5DocumentHead :: Head -> HTML5
278 html5DocumentHead Head{DTC.about=About{..}, judgments} = do
279 st <- liftStateMarkup S.get
280 unless (null authors) $ do
281 H.div ! HA.class_ "document-head" $$
282 H.table $$ do
283 H.tbody $$ do
284 H.tr $$ do
285 H.td ! HA.class_ "left" $$ docHeaders
286 H.td ! HA.class_ "right" $$ docAuthors
287 unless (null titles) $ do
288 H.div ! HA.class_ "title"
289 ! HA.id "document-title." $$ do
290 forM_ titles $ \title ->
291 H.h1 ! HA.id (attrify $ identifyTitle (Plain.state_l10n $ state_plainify st) title) $$
292 html5ify title
293 do -- judgments
294 let sectionJudgments = HS.fromList judgments
295 let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
296 liftStateMarkup $ S.modify' $ \s ->
297 s{ state_judgments = sectionJudgments
298 , state_opinions =
299 -- NOTE: drop current opinions of the judgments of this section
300 HM.unionWith (const List.tail)
301 (state_opinions s)
302 opinsBySectionByJudgment
303 }
304 unless (null opinsBySectionByJudgment) $ do
305 let choicesJ = Collect.choicesByJudgment judgments
306 forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
307 H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do
308 let choices = maybe [] snd $ HM.lookup judgment choicesJ
309 let opins = List.head opinsBySection
310 html5Judgment question choices opins
311 where
312 docHeaders =
313 H.table ! HA.class_ "document-headers" $$
314 H.tbody $$ do
315 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
316 forM_ series $ \s@Serie{id=id_, name} ->
317 header $
318 case urlSerie s of
319 Nothing -> do
320 headerName $ html5ify name
321 headerValue $ html5ify id_
322 Just href -> do
323 headerName $ html5ify name
324 headerValue $
325 H.a ! HA.href (attrify href) $$
326 html5ify id_
327 forM_ links $ \Link{..} ->
328 unless (TL.null $ unName name) $
329 header $ do
330 headerName $ html5ify name
331 headerValue $ html5ify $ Tree PlainEref{href} plain
332 forM_ date $ \d ->
333 header $ do
334 headerName $ l10n_Header_Date l10n
335 headerValue $ html5ify d
336 forM_ url $ \href ->
337 header $ do
338 headerName $ l10n_Header_Address l10n
339 headerValue $ html5ify $ tree0 $ PlainEref{href}
340 forM_ headers $ \Header{..} ->
341 header $ do
342 headerName $ html5ify name
343 headerValue $ html5ify value
344 docAuthors =
345 H.table ! HA.class_ "document-authors" $$
346 H.tbody $$ do
347 forM_ authors $ \a ->
348 H.tr $$
349 H.td ! HA.class_ "author" $$
350 html5ify a
351 header :: HTML5 -> HTML5
352 header hdr = H.tr ! HA.class_ "header" $$ hdr
353 headerName :: HTML5 -> HTML5
354 headerName hdr =
355 H.td ! HA.class_ "header-name" $$ do
356 hdr
357 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
358 Plain.l10n_Colon l10n
359 headerValue :: HTML5 -> HTML5
360 headerValue hdr =
361 H.td ! HA.class_ "header-value" $$ do
362 hdr
363
364 -- * Class 'Html5ify'
365 class Html5ify a where
366 html5ify :: a -> HTML5
367 instance Html5ify H.Markup where
368 html5ify = Compose . return
369 instance Html5ify Char where
370 html5ify = html5ify . H.toMarkup
371 instance Html5ify Text where
372 html5ify = html5ify . H.toMarkup
373 instance Html5ify TL.Text where
374 html5ify = html5ify . H.toMarkup
375 instance Html5ify String where
376 html5ify = html5ify . H.toMarkup
377 instance Html5ify Title where
378 html5ify (Title t) = html5ify t
379 instance Html5ify Ident where
380 html5ify (Ident i) = html5ify i
381 instance Html5ify Int where
382 html5ify = html5ify . show
383 instance Html5ify Name where
384 html5ify (Name i) = html5ify i
385 instance Html5ify Nat where
386 html5ify (Nat n) = html5ify n
387 instance Html5ify Nat1 where
388 html5ify (Nat1 n) = html5ify n
389 instance Html5ify a => Html5ify (Maybe a) where
390 html5ify = foldMap html5ify
391 instance Html5ify TCT.Spans where
392 html5ify = \case
393 s:|[] ->
394 H.span ! HA.class_ "tct-position" $$
395 html5ify $ show s
396 ss -> do
397 H.ul ! HA.class_ "tct-position" $$
398 forM_ ss $ \s ->
399 H.li $$
400 html5ify $ show s
401 instance Html5ify Check.Errors where
402 html5ify Check.Errors{..} = do
403 st@State
404 { state_collect = Collect.All{..}
405 , state_l10n = Loqualization (l10n::FullLocale lang)
406 , ..
407 } <- liftStateMarkup S.get
408 let errors :: [ ( Int{-errKind-}
409 , HTML5{-errKindDescr-}
410 , [(Plain{-errTypeKey-}, [(Spans{-errPos-}, Ident{-errId-})])]
411 ) ] =
412 List.zipWith
413 (\errKind (errKindDescr, errByPosByKey) ->
414 (errKind, errKindDescr l10n, errByPosByKey))
415 [1::Int ..]
416 [ (l10n_Error_Tag_unknown , errorTag st "-unknown" errors_tag_unknown)
417 , (l10n_Error_Tag_ambiguous , errorTag st "-ambiguous" errors_tag_ambiguous)
418 , (l10n_Error_Rref_unknown , errorReference "-unknown" errors_rref_unknown)
419 , (l10n_Error_Reference_ambiguous, errorReference "-ambiguous" errors_reference_ambiguous)
420 ]
421 let numErrors = Nat $ sum $ (<$> errors) $ \(_typ, _descr, errByPosByKey) ->
422 sum $ length . snd <$> errByPosByKey
423 when (numErrors > Nat 0) $ do
424 liftStateMarkup $ S.put st
425 { state_styles =
426 HS.insert (Left "dtc-errors.css") $
427 HS.insert (Right $
428 -- NOTE: Implement a CSS-powered show/hide logic, using :target
429 "\n@media screen {" <>
430 "\n\t.error-filter:target .errors-list > li {display:none;}" <>
431 (`foldMap` errors) (\(num, _description, errs) ->
432 if null errs then "" else
433 let err = "error-type"<>TL.pack (show num)<>"\\." in
434 "\n\t.error-filter#"<>err<>":target .errors-list > li."<>err
435 <>" {display:list-item}" <>
436 "\n\t.error-filter#"<>err<>":target .errors-nav > ul > li."<>err
437 <>" {list-style-type:disc;}"
438 ) <>
439 "\n}"
440 )
441 state_styles
442 }
443 filterIds errors $ H.div ! HA.class_ "document-errors" ! HA.id "document-errors." $$ do
444 H.nav ! HA.class_ "errors-nav" $$ do
445 H.p $$
446 H.a ! HA.class_ "errors-all" ! HA.href (refIdent "document-errors.") $$ do
447 l10n_Errors_All l10n numErrors :: HTML5
448 H.ul $$
449 forM_ errors $
450 \(errKind, errKindDescr, errs) -> do
451 unless (null errs) $ do
452 H.li ! HA.class_ (attrify $ errorType errKind) $$ do
453 H.a ! HA.href (refIdent $ errorType errKind) $$ do
454 errKindDescr
455 " ("::HTML5
456 html5ify $ sum $ length . snd <$> errs
457 ")"
458 H.ol ! HA.class_ "errors-list" $$ do
459 let errByPosByKey :: Map Spans{-errPos-} ( Int{-errKind-}
460 , HTML5{-errKindDescr-}
461 , Plain{-errKey-}
462 , [(Spans{-errPos-}, Ident{-errId-})] ) =
463 (`foldMap`errors) $ \(errKind, errKindDescr, errByKey) ->
464 (`foldMap`errByKey) $ \(errKey, errByPos) ->
465 Map.singleton
466 (fst $ List.head errByPos)
467 -- NOTE: sort using the first position of this errKind with this errKey.
468 (errKind, errKindDescr, errKey, errByPos)
469 forM_ errByPosByKey $
470 \(errKind, errKindDescr, errKey, errByPos) -> do
471 H.li ! HA.class_ (attrify $ errorType errKind) $$ do
472 H.span ! HA.class_ "error-message" $$ do
473 H.span ! HA.class_ "error-kind" $$ do
474 errKindDescr
475 Plain.l10n_Colon l10n :: HTML5
476 html5ify errKey
477 H.ol ! HA.class_ "error-position" $$
478 forM_ errByPos $ \(errPos, errId) ->
479 H.li $$
480 H.a ! HA.href (refIdent errId) $$
481 html5ify errPos
482 where
483 errorType num = identify $ "error-type"<>show num<>"."
484 -- | Nest error id= to enable showing/hidding errors using :target pseudo-class.
485 filterIds [] h = h
486 filterIds ((num, _description, errs):es) h =
487 if null errs
488 then filterIds es h
489 else do
490 H.div ! HA.class_ "error-filter"
491 ! HA.id (attrify $ errorType num) $$
492 filterIds es h
493 errorTag :: State -> Ident -> HM.HashMap Title (Seq.Seq TCT.Spans) -> [(Plain, [(TCT.Spans,Ident)])]
494 errorTag State{state_plainify=Plain.State{state_l10n}} suffix errs =
495 (<$> HM.toList errs) $ \(Title tag, errPositions) ->
496 ( tag
497 , List.zipWith
498 (\num -> (,identifyTag suffix state_l10n tag (Just $ Nat1 num)))
499 [1::Int ..] (toList errPositions)
500 )
501 errorReference :: Ident -> HM.HashMap Ident (Seq.Seq TCT.Spans) -> [(Plain, [(TCT.Spans,Ident)])]
502 errorReference suffix errs =
503 (<$> HM.toList errs) $ \(id, errPositions) ->
504 ( pure $ tree0 $ PlainText $ unIdent id
505 , List.zipWith
506 (\num -> (,identifyReference suffix id (Just $ Nat1 num)))
507 [1::Int ..] (toList errPositions)
508 )
509 instance Html5ify Body where
510 html5ify body = do
511 liftStateMarkup $ S.modify' $ \s -> s{state_section = body}
512 mapM_ html5ify body
513 case Seq.viewr body of
514 _ Seq.:> Tree BodyBlock{} _ -> do
515 notes <- liftStateMarkup $ S.gets state_notes
516 maybe mempty html5Notes $
517 Map.lookup mempty notes
518 _ -> mempty
519 instance Html5ify (Tree BodyNode) where
520 html5ify (Tree b bs) =
521 case b of
522 BodyBlock blk -> html5ify blk
523 BodySection Section{..} -> do
524 st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
525 liftStateMarkup $ S.modify' $ \s -> s{state_section = bs}
526 do -- notes
527 let mayNotes = do
528 sectionPosPath <- dropSelfPosPath $ xmlPos_Ancestors xmlPos
529 let (sectionNotes, notes) = Map.updateLookupWithKey (\_ _ -> Nothing) sectionPosPath $ state_notes st
530 (,notes) <$> sectionNotes
531 case mayNotes of
532 Nothing -> mempty
533 Just (sectionNotes, state_notes) -> do
534 liftStateMarkup $ S.modify' $ \s -> s{state_notes}
535 html5Notes sectionNotes
536 html5CommonAttrs attrs{classes="section":classes attrs, id=Nothing} $
537 H.section ! HA.id (attrify $ identify xmlPos) $$ do
538 forM_ aliases html5ify
539 do -- judgments
540 let sectionJudgments = state_judgments st `HS.union` HS.fromList judgments
541 let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
542 let dropChildrenBlocksJudgments =
543 -- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's
544 -- directly children of this 'BodySection'.
545 if (`any`bs) $ \case
546 Tree BodyBlock{} _ -> True
547 _ -> False
548 then List.tail
549 else Cat.id
550 liftStateMarkup $ S.modify' $ \s ->
551 s{ state_judgments = sectionJudgments
552 , state_opinions =
553 -- NOTE: drop current opinions of the judgments of this section
554 HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
555 (state_opinions s)
556 opinsBySectionByJudgment
557 }
558 unless (null opinsBySectionByJudgment) $ do
559 liftStateMarkup $ S.modify' $ \s -> s
560 { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
561 H.aside ! HA.class_ "aside" $$ do
562 let choicesJ = Collect.choicesByJudgment judgments
563 forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
564 H.div ! HA.class_ "judgment section-judgment" $$ do
565 let choices = maybe [] snd $ HM.lookup judgment choicesJ
566 let opins = List.head opinsBySection
567 html5Judgment question choices opins
568 let mayId =
569 case toList <$> HM.lookup title all_section of
570 Just [_] -> Just $ identifyTitle (Plain.state_l10n $ state_plainify st) title
571 _ -> Nothing
572 H.table
573 ! HA.class_ "section-header"
574 !?? mayAttr HA.id mayId $$
575 H.tbody $$
576 H.tr $$ do
577 H.td ! HA.class_ "section-number" $$ do
578 html5SectionNumber $ xmlPos_Ancestors xmlPos
579 H.td ! HA.class_ "section-title" $$ do
580 (case List.length $ xmlPos_Ancestors xmlPos of
581 0 -> H.h1
582 1 -> H.h2
583 2 -> H.h3
584 3 -> H.h4
585 4 -> H.h5
586 5 -> H.h6
587 _ -> H.h6) $$
588 html5ify title
589 forM_ bs html5ify
590 do -- judgments
591 liftStateMarkup $ S.modify' $ \s ->
592 s{ state_judgments = state_judgments st }
593 do -- notes
594 notes <- liftStateMarkup $ S.gets state_notes
595 maybe mempty html5Notes $
596 Map.lookup (xmlPos_Ancestors xmlPos) notes
597 liftStateMarkup $ S.modify' $ \s -> s{state_section = state_section st}
598 instance Html5ify Block where
599 html5ify = \case
600 BlockPara para -> html5ify para
601 BlockBreak{..} ->
602 html5CommonAttrs attrs
603 { classes = "page-break":"print-only":classes attrs } $
604 H.div $$
605 H.p $$ " " -- NOTE: force page break
606 BlockToC{..} ->
607 H.nav ! HA.class_ "toc"
608 ! HA.id (attrify $ identify xmlPos) $$ do
609 H.span ! HA.class_ "toc-name" $$
610 H.a ! HA.href (refIdent $ identify xmlPos) $$ do
611 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
612 Plain.l10n_Table_of_Contents l10n
613 H.ul $$ do
614 State{state_section} <- liftStateMarkup S.get
615 forM_ state_section $ html5ifyToC depth
616 BlockToF{..} -> do
617 H.nav ! HA.class_ "tof"
618 ! HA.id (attrify $ identify xmlPos) $$
619 H.table ! HA.class_ "tof" $$
620 H.tbody $$
621 html5ifyToF types
622 BlockAside{..} ->
623 html5CommonAttrs attrs $
624 H.aside ! HA.class_ "aside" $$ do
625 forM_ blocks html5ify
626 BlockFigure{..} ->
627 html5CommonAttrs attrs
628 { classes = "figure":("figure-"<>type_):classes attrs
629 , DTC.id = Just $ Ident $ Plain.text def $ xmlPos_AncestorsWithFigureNames xmlPos
630 } $
631 H.div $$ do
632 H.table ! HA.class_ "figure-caption" $$
633 H.tbody $$
634 H.tr $$ do
635 if TL.null type_
636 then H.a ! HA.href (refIdent $ identify xmlPos) $$ mempty
637 else
638 H.td ! HA.class_ "figure-number" $$ do
639 H.a ! HA.href (refIdent $ identify $ xmlPos_AncestorsWithFigureNames xmlPos) $$ do
640 html5ify type_
641 html5ify $ xmlPos_AncestorsWithFigureNames xmlPos
642 forM_ mayTitle $ \title -> do
643 H.td ! HA.class_ "figure-colon" $$ do
644 unless (TL.null type_) $ do
645 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
646 Plain.l10n_Colon l10n
647 H.td ! HA.class_ "figure-title" $$ do
648 html5ify title
649 H.div ! HA.class_ "figure-content" $$ do
650 html5ify paras
651 BlockIndex{xmlPos} -> do
652 st@State{..} <- liftStateMarkup S.get
653 liftStateMarkup $ S.put st
654 { state_styles = HS.insert (Left "dtc-index.css") state_styles }
655 let (allTerms,refsByTerm) = state_indexs Map.!xmlPos
656 let chars = Index.termsByChar allTerms
657 H.div ! HA.class_ "index"
658 ! HA.id (attrify $ identify xmlPos) $$ do
659 H.nav ! HA.class_ "index-nav" $$ do
660 forM_ (Map.keys chars) $ \char ->
661 H.a ! HA.href (refIdent (identify xmlPos <> "." <> identify char)) $$
662 html5ify char
663 H.dl ! HA.class_ "index-chars" $$
664 forM_ (Map.toList chars) $ \(char,terms) -> do
665 H.dt $$ do
666 let i = identify xmlPos <> "." <> identify char
667 H.a ! HA.id (attrify i)
668 ! HA.href (refIdent i) $$
669 html5ify char
670 H.dd $$
671 H.dl ! HA.class_ "index-term" $$ do
672 forM_ terms $ \aliases -> do
673 H.dt $$
674 H.ul ! HA.class_ "index-aliases" $$
675 forM_ (List.take 1 aliases) $ \term -> do
676 H.li ! HA.id (attrify $ identifyIref term) $$
677 html5ify term
678 H.dd $$
679 let anchs =
680 List.sortBy (compare `on` DTC.section . snd) $
681 (`foldMap` aliases) $ \words ->
682 fromJust $ do
683 path <- Index.pathFromWords words
684 Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
685 TreeMap.lookup path refsByTerm in
686 html5CommasDot $
687 (<$> anchs) $ \(term,Anchor{..}) ->
688 H.a ! HA.class_ "index-iref"
689 ! HA.href (refIdent $ identifyIrefCount term count) $$
690 html5ify $ xmlPos_Ancestors section
691 BlockReferences{..} ->
692 html5CommonAttrs attrs
693 { classes = "references":classes attrs
694 , DTC.id = Just $ Ident $ Plain.text def $ xmlPos_Ancestors xmlPos
695 } $
696 H.div $$ do
697 H.table $$
698 forM_ refs html5ify
699 BlockGrades{..} ->
700 html5CommonAttrs attrs
701 { classes = "grades":classes attrs
702 , DTC.id = Just $ Ident $ Plain.text def $ xmlPos_Ancestors xmlPos
703 } $
704 H.div $$ do
705 -- let dg = List.head $ List.filter default_ scale
706 -- let sc = MJ.Scale (Set.fromList scale) dg
707 -- o :: Map choice grade
708 -- os :: Opinions (Map judge (Opinion choice grade))
709 mempty
710 -- html5ify $ show b
711 BlockJudges{..} ->
712 html5CommonAttrs attrs
713 { classes = "judges":classes attrs
714 , DTC.id = Just $ Ident $ Plain.text def $ xmlPos_Ancestors xmlPos
715 } $
716 H.div $$ do
717 mempty
718 instance Html5ify Para where
719 html5ify = \case
720 ParaItem{..} ->
721 html5CommonAttrs def
722 { classes="para":cls item
723 } $
724 html5ify item
725 ParaItems{..} ->
726 html5CommonAttrs attrs
727 { classes = "para":classes attrs
728 , DTC.id = id_ xmlPos
729 } $
730 H.div $$
731 forM_ items $ \item ->
732 html5AttrClass (cls item) $
733 html5ify item
734 where
735 id_ = Just . Ident . Plain.text def . xmlPos_Ancestors
736 cls = \case
737 ParaPlain{} -> []
738 ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
739 ParaQuote{..} -> ["quote", "quote-"<>type_]
740 ParaComment{} -> []
741 ParaOL{} -> ["ol"]
742 ParaUL{} -> ["ul"]
743 ParaJudgment{} -> ["judgment"]
744 instance Html5ify ParaItem where
745 html5ify = \case
746 ParaPlain p -> H.p $$ html5ify p
747 ParaArtwork{..} -> H.pre $$ do html5ify text
748 ParaQuote{..} -> H.div $$ do html5ify paras
749 ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
750 ParaOL items ->
751 H.table $$ do
752 H.tbody $$
753 forM_ items $ \ListItem{..} -> do
754 H.tr $$ do
755 H.td ! HA.class_ "name" $$ do
756 html5ify name
757 "."::HTML5
758 H.td ! HA.class_ "value" $$
759 html5ify paras
760 ParaUL items ->
761 H.dl $$ do
762 forM_ items $ \item -> do
763 H.dt $$ "—"
764 H.dd $$ html5ify item
765 ParaJudgment j -> html5ify j
766 instance Html5ify Judgment where
767 html5ify Judgment{..} = do
768 st <- liftStateMarkup S.get
769 H.div $$ do
770 let judgmentGrades =
771 maybe (Prelude.error $ show grades) MJ.grades $ -- unknown grades
772 HM.lookup grades (Collect.all_grades $ state_collect st)
773 let judgmentJudges =
774 fromMaybe (Prelude.error $ show judges) $ -- unknown judges
775 HM.lookup judges (Collect.all_judges $ state_collect st)
776 let defaultGradeByJudge =
777 let defaultGrade =
778 List.head
779 [ g | g <- Set.toList judgmentGrades
780 , isDefault $ MJ.unRank g
781 ] in
782 HM.fromList
783 [ (name, defaultGrade`fromMaybe`judgeDefaultGrade)
784 | DTC.Judge{name,defaultGrades} <- judgmentJudges
785 , let judgeDefaultGrade = do
786 jdg <- listToMaybe [g | (n,g) <- defaultGrades, n == grades]
787 listToMaybe
788 [ g | g <- Set.toList judgmentGrades
789 , let DTC.Grade{name=n} = MJ.unRank g
790 , n == jdg
791 ]
792 ]
793 judgmentChoices <- forM choices $ \c@DTC.Choice{opinions} -> do
794 gradeByJudge <- forM opinions $ \DTC.Opinion{judge,grade} -> do
795 let grd =
796 fromMaybe (Prelude.error $ show grade) $ -- unknown grade
797 listToMaybe
798 [ MJ.singleGrade g | g <- Set.toList judgmentGrades
799 , let Grade{name} = MJ.unRank g
800 , name == grade
801 ]
802 return (judge, grd)
803 case MJ.opinions defaultGradeByJudge $ HM.fromList gradeByJudge of
804 (ok,ko) | null ko -> return (c, ok)
805 | otherwise -> Prelude.error $ show ko -- unknown judge
806 -- TODO: handle ko
807 html5Judgment question choices $ HM.fromList judgmentChoices
808 instance Html5ify [Para] where
809 html5ify = mapM_ html5ify
810 instance Html5ify Plain where
811 html5ify ps =
812 case Seq.viewl ps of
813 Seq.EmptyL -> mempty
814 curr Seq.:< next ->
815 case curr of
816 -- NOTE: gather adjacent PlainNotes
817 Tree PlainNote{} _
818 | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
819 H.sup ! HA.class_ "note-numbers" $$ do
820 html5ify curr
821 forM_ notes $ \note -> do
822 ", "::HTML5
823 html5ify note
824 " "::HTML5
825 html5ify rest
826 --
827 _ -> do
828 html5ify curr
829 html5ify next
830 instance Html5ify (Tree PlainNode)
831 where html5ify (Tree n ls) =
832 case n of
833 PlainBreak -> html5ify H.br
834 PlainText t -> html5ify t
835 PlainGroup -> html5ify ls
836 PlainB -> H.strong $$ html5ify ls
837 PlainCode -> H.code $$ html5ify ls
838 PlainDel -> H.del $$ html5ify ls
839 PlainI -> do
840 i <- liftStateMarkup $ do
841 i <- S.gets $ Plain.state_italic . state_plainify
842 S.modify $ \s ->
843 s{state_plainify=
844 (state_plainify s){Plain.state_italic=
845 not i}}
846 return i
847 H.em ! HA.class_ (if i then "even" else "odd") $$
848 html5ify ls
849 liftStateMarkup $
850 S.modify $ \s ->
851 s{state_plainify=
852 (state_plainify s){Plain.state_italic=i}}
853 PlainSpan{..} ->
854 html5CommonAttrs attrs $
855 H.span $$ html5ify ls
856 PlainSub -> H.sub $$ html5ify ls
857 PlainSup -> H.sup $$ html5ify ls
858 PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
859 PlainU -> H.span ! HA.class_ "underline" $$ html5ify ls
860 PlainNote{..} ->
861 case number of
862 Nothing -> Prelude.error "[BUG] PlainNote has no number."
863 Just num ->
864 H.a ! HA.class_ "note-ref"
865 ! HA.id ("note-ref."<>attrify num)
866 ! HA.href ("#note."<>attrify num) $$
867 html5ify num
868 PlainQ -> do
869 H.span ! HA.class_ "q" $$ do
870 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
871 Plain.l10n_Quote (html5ify $ Tree PlainI ls) l10n
872 PlainEref{..} ->
873 H.a ! HA.class_ "eref"
874 ! HA.href (attrify href) $$
875 if null ls
876 then html5ify $ unURL href
877 else html5ify ls
878 PlainIref{..} ->
879 case anchor of
880 Nothing -> html5ify ls
881 Just Anchor{count} ->
882 H.span ! HA.class_ "iref"
883 ! HA.id (attrify $ identifyIrefCount term count) $$
884 html5ify ls
885 PlainTag{error} -> do
886 st <- liftStateMarkup S.get
887 let l10n = Plain.state_l10n $ state_plainify st
888 case error of
889 Nothing ->
890 H.a ! HA.class_ "tag"
891 ! HA.href (refIdent $ identifyTitle l10n $ Title ls) $$
892 html5ify ls
893 Just (ErrorTarget_Unknown num) ->
894 H.span ! HA.class_ "tag tag-unknown"
895 ! HA.id (attrify $ identifyTag "-unknown" l10n ls (Just num)) $$
896 html5ify ls
897 Just (ErrorTarget_Ambiguous num) ->
898 H.span ! HA.class_ "tag tag-ambiguous"
899 ! HA.id (attrify $ identifyTag "-ambiguous" l10n ls num) $$
900 html5ify ls
901 PlainRref{..} -> do
902 case error of
903 Nothing ->
904 let ref = do
905 "["::HTML5
906 H.a ! HA.class_ "reference"
907 ! HA.href (refIdent $ identifyReference "" to Nothing)
908 ! HA.id (attrify $ identifyReference "" to number) $$
909 html5ify to
910 "]" in
911 case toList ls of
912 [] -> ref
913 [Tree (PlainText "") _] -> do
914 refs <- liftStateMarkup $ S.gets $ Collect.all_reference . state_collect
915 case toList <$> HM.lookup to refs of
916 Just [Reference{about=About{..}}] -> do
917 forM_ (List.take 1 titles) $ \(Title title) -> do
918 html5ify $ Tree PlainQ $
919 case url of
920 Nothing -> title
921 Just u -> pure $ Tree (PlainEref u) title
922 " "::HTML5
923 ref
924 _ -> mempty
925 _ -> do
926 H.a ! HA.class_ "reference"
927 ! HA.href (refIdent $ identifyReference "" to Nothing)
928 ! HA.id (attrify $ identifyReference "" to number) $$
929 html5ify ls
930 H.span ! HA.class_ "print-only" $$ do
931 " "::HTML5
932 ref
933 Just (ErrorTarget_Unknown num) -> do
934 "["::HTML5
935 H.span ! HA.class_ "reference reference-unknown"
936 ! HA.id (attrify $ identifyReference "-unknown" to $ Just num) $$
937 html5ify to
938 "]"
939 Just (ErrorTarget_Ambiguous num) -> do
940 case toList ls of
941 [] -> mempty
942 [Tree (PlainText "") _] -> mempty
943 _ -> do
944 html5ify ls
945 " "::HTML5
946 "["::HTML5
947 H.span ! HA.class_ "reference reference-ambiguous"
948 !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" to . Just <$> num) $$
949 html5ify to
950 "]"
951 instance Html5ify [Title] where
952 html5ify =
953 html5ify . fold . List.intersperse sep . toList
954 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
955 instance Html5ify About where
956 html5ify About{..} = do
957 html5Lines
958 [ html5CommasDot $ concat $
959 [ html5Titles titles
960 , html5ify <$> authors
961 , html5ify <$> maybeToList date
962 , html5ify <$> maybeToList editor
963 , html5ify <$> series
964 ]
965 , forM_ url $ \u ->
966 H.span ! HA.class_ "print-only" $$ do
967 "<"::HTML5
968 html5ify u
969 ">"
970 ]
971 where
972 html5Titles :: [Title] -> [HTML5]
973 html5Titles ts | null ts = []
974 html5Titles ts = [html5Title $ joinTitles ts]
975 where
976 joinTitles = fold . List.intersperse sep . toList
977 sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
978 html5Title (Title title) =
979 html5ify $ Tree PlainQ $
980 case url of
981 Nothing -> title
982 Just u -> pure $ Tree (PlainEref u) title
983 instance Html5ify Serie where
984 html5ify s@Serie{id=id_, name} = do
985 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
986 case urlSerie s of
987 Nothing -> do
988 html5ify name
989 Plain.l10n_Colon l10n :: HTML5
990 html5ify id_
991 Just href -> do
992 html5ify $
993 Tree PlainEref{href} $
994 Seq.fromList
995 [ tree0 $ PlainText $ unName name
996 , tree0 $ PlainText $ Plain.l10n_Colon l10n
997 , tree0 $ PlainText id_
998 ]
999 instance Html5ify Entity where
1000 html5ify Entity{..} = do
1001 case () of
1002 _ | not (TL.null email) -> do
1003 H.span ! HA.class_ "no-print" $$
1004 html5ify $
1005 Tree (PlainEref $ URL $ "mailto:"<>email) $
1006 pure $ tree0 $ PlainText name
1007 H.span ! HA.class_ "print-only" $$
1008 html5ify $
1009 Tree PlainGroup $ Seq.fromList
1010 [ tree0 $ PlainText name
1011 , tree0 $ PlainText " <"
1012 , Tree (PlainEref $ URL $ "mailto:"<>email) $
1013 pure $ tree0 $ PlainText email
1014 , tree0 $ PlainText ">"
1015 ]
1016 _ | Just u <- url ->
1017 html5ify $
1018 Tree (PlainEref u) $
1019 pure $ tree0 $ PlainText name
1020 _ ->
1021 html5ify $
1022 tree0 $ PlainText name
1023 forM_ org $ \o -> do
1024 " ("::HTML5
1025 html5ify o
1026 ")"::HTML5
1027 instance Html5ify Words where
1028 html5ify = html5ify . Index.plainifyWords
1029 instance Html5ify Alias where
1030 html5ify Alias{..} = do
1031 st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
1032 let l10n = Plain.state_l10n $ state_plainify st
1033 case toList <$> HM.lookup title all_section of
1034 Just [_] ->
1035 H.a ! HA.class_ "alias"
1036 ! HA.id (attrify $ identifyTitle l10n title) $$
1037 mempty
1038 _ -> mempty
1039 instance Html5ify URL where
1040 html5ify (URL url) =
1041 H.a ! HA.class_ "eref"
1042 ! HA.href (attrify url) $$
1043 html5ify url
1044 instance Html5ify Date where
1045 html5ify date = do
1046 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
1047 Plain.l10n_Date date l10n
1048 instance Html5ify Reference where
1049 html5ify Reference{..} =
1050 H.tr $$ do
1051 H.td ! HA.class_ "reference-key" $$
1052 html5ify $ tree0 PlainRref
1053 { number = Nothing
1054 , tctPos = def
1055 , to = id
1056 , error = (<$> error) $ \case
1057 ErrorAnchor_Ambiguous num -> ErrorTarget_Ambiguous (Just num)
1058 }
1059 H.td ! HA.class_ "reference-content" $$ do
1060 html5ify about
1061 rrefs <- liftStateMarkup $ S.gets state_rrefs
1062 case HM.lookup id rrefs of
1063 Nothing -> pure ()
1064 Just anchs ->
1065 H.span ! HA.class_ "reference-rrefs" $$
1066 html5CommasDot $
1067 (<$> List.reverse anchs) $ \(maySection,num) ->
1068 H.a ! HA.class_ "reference-rref"
1069 ! HA.href (refIdent $ identifyReference "" id $ Just num) $$
1070 case maySection of
1071 Nothing -> "0"::HTML5
1072 Just Section{xmlPos=posSection} -> html5ify $ xmlPos_Ancestors posSection
1073 instance Html5ify XmlPosPath where
1074 html5ify ancs =
1075 case toList ancs of
1076 [(_n,c)] -> do
1077 html5ify $ show c
1078 html5ify '.'
1079 as ->
1080 html5ify $
1081 Text.intercalate "." $
1082 Text.pack . show . snd <$> as
1083 instance Html5ify Plain.Plain where
1084 html5ify p = do
1085 sp <- liftStateMarkup $ S.gets state_plainify
1086 let (t,sp') = Plain.runPlain p sp
1087 html5ify t
1088 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
1089 {-
1090 instance Html5ify SVG.Element where
1091 html5ify svg =
1092 html5ify $
1093 B.preEscapedLazyText $
1094 SVG.renderText svg
1095 instance Semigroup SVG.Element where
1096 (<>) = mappend
1097 -}
1098
1099 html5CommasDot :: [HTML5] -> HTML5
1100 html5CommasDot [] = pure ()
1101 html5CommasDot hs = do
1102 sequence_ $ List.intersperse ", " hs
1103 "."
1104
1105 html5Lines :: [HTML5] -> HTML5
1106 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs
1107
1108 html5Words :: [HTML5] -> HTML5
1109 html5Words hs = sequence_ $ List.intersperse " " hs
1110
1111 html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
1112 html5AttrClass = \case
1113 [] -> Cat.id
1114 cls ->
1115 Compose .
1116 (H.AddCustomAttribute "class"
1117 (H.String $ TL.unpack $ TL.unwords cls) <$>) .
1118 getCompose
1119
1120 html5AttrId :: Ident -> HTML5 -> HTML5
1121 html5AttrId (Ident id_) =
1122 Compose .
1123 (H.AddCustomAttribute "id"
1124 (H.String $ TL.unpack id_) <$>) .
1125 getCompose
1126
1127 html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
1128 html5CommonAttrs CommonAttrs{id=id_, ..} =
1129 html5AttrClass classes .
1130 maybe Cat.id html5AttrId id_
1131
1132 html5SectionNumber :: XmlPosPath -> HTML5
1133 html5SectionNumber = go mempty
1134 where
1135 go :: XmlPosPath -> XmlPosPath -> HTML5
1136 go prev next =
1137 case Seq.viewl next of
1138 Seq.EmptyL -> pure ()
1139 a@(_n,rank) Seq.:< as -> do
1140 H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$
1141 html5ify $ show rank
1142 when (not (null as) || null prev) $ do
1143 html5ify '.'
1144 go (prev Seq.|>a) as
1145
1146 html5SectionRef :: XmlPosPath -> HTML5
1147 html5SectionRef as =
1148 H.a ! HA.href (refIdent $ identify as) $$
1149 html5ify as
1150
1151 html5Notes :: IntMap [Para] -> HTML5
1152 html5Notes notes =
1153 H.aside ! HA.class_ "notes" $$ do
1154 Compose $ pure H.hr
1155 H.table $$
1156 H.tbody $$
1157 forM_ (IntMap.toList notes) $ \(number,content) ->
1158 H.tr $$ do
1159 H.td ! HA.class_ "note-ref" $$ do
1160 H.a ! HA.class_ "note-number"
1161 ! HA.id ("note."<>attrify number)
1162 ! HA.href ("#note."<>attrify number) $$ do
1163 html5ify number
1164 ". "::HTML5
1165 H.a ! HA.href ("#note-ref."<>attrify number) $$ do
1166 "↑"
1167 H.td $$
1168 html5ify content
1169
1170 html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5
1171 html5ifyToC depth (Tree b bs) =
1172 case b of
1173 BodySection Section{..} -> do
1174 H.li $$ do
1175 H.table ! HA.class_ "toc-entry" $$
1176 H.tbody $$
1177 H.tr $$ do
1178 H.td ! HA.class_ "section-number" $$
1179 html5SectionRef $ xmlPos_Ancestors xmlPos
1180 H.td ! HA.class_ "section-title" $$
1181 html5ify $ cleanPlain $ unTitle title
1182 when (maybe True (> Nat 1) depth && not (null sections)) $
1183 H.ul $$
1184 forM_ sections $
1185 html5ifyToC (depth >>= predNat)
1186 _ -> mempty
1187 where
1188 sections =
1189 (`Seq.filter` bs) $ \case
1190 Tree BodySection{} _ -> True
1191 _ -> False
1192
1193 html5ifyToF :: [TL.Text] -> HTML5
1194 html5ifyToF types = do
1195 figuresByType <- liftStateMarkup $ S.gets $ Collect.all_figure . state_collect
1196 let figures =
1197 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
1198 if null types
1199 then figuresByType
1200 else
1201 Map.intersection figuresByType $
1202 Map.fromList [(ty,()) | ty <- types]
1203 forM_ (Map.toList figures) $ \(xmlPos, (type_, title)) ->
1204 H.tr $$ do
1205 H.td ! HA.class_ "figure-number" $$
1206 H.a ! HA.href (refIdent $ identify xmlPos) $$ do
1207 html5ify type_
1208 html5ify $ xmlPos_Ancestors xmlPos
1209 forM_ title $ \ti ->
1210 H.td ! HA.class_ "figure-title" $$
1211 html5ify $ cleanPlain $ unTitle ti
1212
1213 html5Judgment ::
1214 Maybe Title ->
1215 [Choice] ->
1216 MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade) ->
1217 HTML5
1218 html5Judgment question choices distByJudgeByChoice = do
1219 let commentJGC = HM.fromList
1220 [ (choice_, HM.fromListWith (<>)
1221 [ (grade, HM.singleton judge comment)
1222 | Opinion{..} <- opinions ])
1223 | choice_@Choice{opinions} <- choices ]
1224 case question of
1225 Nothing -> mempty
1226 Just title -> H.div ! HA.class_ "question" $$ html5ify title
1227 H.dl ! HA.class_ "choices" $$ do
1228 let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
1229 let ranking = MJ.majorityRanking meritByChoice
1230 forM_ ranking $ \(choice_@DTC.Choice{title}, majorityValue) -> do
1231 H.dt ! HA.class_ "choice-title" $$ do
1232 html5ify title
1233 H.dd ! HA.class_ "choice-merit" $$ do
1234 let distByJudge = distByJudgeByChoice HM.!choice_
1235 let numJudges = HM.size distByJudge
1236 html5MeritHistogram majorityValue numJudges
1237 let grades = Map.keys $ MJ.unMerit $ meritC HM.!choice_
1238 let commentJG = HM.lookup choice_ commentJGC
1239 html5MeritComments distByJudge grades commentJG
1240
1241 html5MeritComments ::
1242 MJ.Opinions Name (MJ.Ranked Grade) ->
1243 [MJ.Ranked Grade] ->
1244 Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
1245 HTML5
1246 html5MeritComments distJ grades commentJG = do
1247 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
1248 H.ul ! HA.class_ "merit-comments" $$ do
1249 forM_ grades $ \grade@(MJ.unRank -> DTC.Grade{name=grade_name, color}) -> do
1250 let commentJ = commentJG >>= HM.lookup grade_name
1251 let judgesWithComment =
1252 -- FIXME: sort accents better: « e é f » not « e f é »
1253 List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
1254 [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
1255 | (judge, dist) <- HM.toList distJ
1256 , importance <- maybeToList $ Map.lookup grade dist ]
1257 forM_ judgesWithComment $ \(judge, importance, comment) ->
1258 H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
1259 H.span
1260 ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
1261 ! HA.style ("color:"<>attrify color<>";") $$ do
1262 unless (importance == 1) $ do
1263 H.span ! HA.class_ "section-importance" $$ do
1264 let percent =
1265 (round::Double -> Int) $
1266 fromRational $ importance * 100
1267 html5ify $ show percent
1268 "%"::HTML5
1269 html5ify judge
1270 case comment of
1271 Nothing -> mempty
1272 Just p -> do
1273 Plain.l10n_Colon l10n :: HTML5
1274 html5ify p
1275
1276 html5MeritHistogram :: MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
1277 html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
1278 H.div ! HA.class_ "merit-histogram" $$ do
1279 forM_ majVal $ \(MJ.unRank -> DTC.Grade{name=grade_name, title=grade_title, color},count) -> do
1280 let percent :: Double =
1281 fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
1282 (count / toRational numJudges) * 100 * 1000) / 1000
1283 let bcolor = "background-color:"<>attrify color<>";"
1284 let width = "width:"<>attrify percent<>"%;"
1285 let display = if percent == 0 then "display:none;" else ""
1286 H.div
1287 ! HA.class_ "merit-grade"
1288 ! HA.alt (attrify grade_name) -- FIXME: do not work
1289 ! HA.style (bcolor<>display<>width) $$ do
1290 H.div
1291 ! HA.class_ "grade-name" $$ do
1292 case grade_title of
1293 Nothing -> html5ify grade_name
1294 Just t -> html5ify t
1295
1296 html5Judgments :: HTML5
1297 html5Judgments = do
1298 Collect.All{..} <- liftStateMarkup $ S.gets state_collect
1299 opinionsByChoiceByNodeBySectionByJudgment <-
1300 forM (HM.toList all_judgments) $ \(judgment@Judgment{judges,grades}, choicesBySection) -> do
1301 -- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
1302 -- can safely be used here: 'judges' and 'grades' are ok
1303 let judgmentGrades =
1304 maybe (Prelude.error $ show grades) MJ.grades $ -- unknown grades
1305 HM.lookup grades all_grades
1306 let judgmentJudges =
1307 fromMaybe (Prelude.error $ show judges) $ -- unknown judges
1308 HM.lookup judges all_judges
1309 let defaultGradeByJudge =
1310 let defaultGrade =
1311 List.head
1312 [ g | g <- Set.toList judgmentGrades
1313 , isDefault $ MJ.unRank g
1314 ] in
1315 HM.fromList
1316 [ (name, defaultGrade`fromMaybe`judgeDefaultGrade)
1317 | DTC.Judge{name,defaultGrades} <- judgmentJudges
1318 , let judgeDefaultGrade = do
1319 jdg <- listToMaybe [g | (n,g) <- defaultGrades, n == grades]
1320 listToMaybe
1321 [ g | g <- Set.toList judgmentGrades
1322 , let DTC.Grade{name=n} = MJ.unRank g
1323 , n == jdg
1324 ]
1325 ]
1326 opinionsByChoiceByNodeBySection <-
1327 forM choicesBySection $ \choicesTree -> do
1328 judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
1329 judgmentOpinions <- forM choices $ \choice_@DTC.Choice{opinions} -> do
1330 gradeByJudge <- forM opinions $ \DTC.Opinion{judge,grade,importance} -> do
1331 case listToMaybe
1332 [ g | g <- Set.toList judgmentGrades
1333 , let Grade{name} = MJ.unRank g
1334 , name == grade
1335 ] of
1336 Just grd -> return (judge, MJ.Section importance (Just grd))
1337 Nothing -> Prelude.error $ show grade -- unknown grade
1338 return (choice_, HM.fromList gradeByJudge)
1339 return $ MJ.SectionNode section_importance $ HM.fromList judgmentOpinions
1340 let judgmentChoices = HS.fromList $ snd $ Tree.rootLabel choicesTree
1341 -- NOTE: choices are determined by those at the root Tree.Node.
1342 -- NOTE: core Majority Judgment calculus handled here by MJ
1343 case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
1344 Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
1345 Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
1346 -- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
1347 -- this will match perfectly withw the 'html5ify' traversal:
1348 -- 'BodySection' by 'BodySection'.
1349 return (judgment, join $ toList <$> opinionsByChoiceByNodeBySection)
1350 liftStateMarkup $ S.modify' $ \st ->
1351 st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}
1352
1353 -- 'Attrify'
1354 instance Attrify Plain.Plain where
1355 attrify p = attrify t
1356 where (t,_) = Plain.runPlain p def
1357
1358 -- * Class 'L10n'
1359 class
1360 ( Plain.L10n msg lang
1361 , Plain.L10n TL.Text lang
1362 ) => L10n msg lang where
1363 l10n_Header_Address :: FullLocale lang -> msg
1364 l10n_Header_Date :: FullLocale lang -> msg
1365 l10n_Header_Version :: FullLocale lang -> msg
1366 l10n_Header_Origin :: FullLocale lang -> msg
1367 l10n_Header_Source :: FullLocale lang -> msg
1368 l10n_Errors_All :: FullLocale lang -> Nat -> msg
1369 l10n_Error_Tag_unknown :: FullLocale lang -> msg
1370 l10n_Error_Tag_ambiguous :: FullLocale lang -> msg
1371 l10n_Error_Rref_unknown :: FullLocale lang -> msg
1372 l10n_Error_Reference_ambiguous :: FullLocale lang -> msg
1373 instance L10n HTML5 EN where
1374 l10n_Header_Address _l10n = "Address"
1375 l10n_Header_Date _l10n = "Date"
1376 l10n_Header_Origin _l10n = "Origin"
1377 l10n_Header_Source _l10n = "Source"
1378 l10n_Header_Version _l10n = "Version"
1379 l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
1380 l10n_Error_Tag_unknown _l10n = "Unknown tag"
1381 l10n_Error_Tag_ambiguous _l10n = "Ambiguous tag"
1382 l10n_Error_Rref_unknown _l10n = "Unknown reference"
1383 l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
1384 instance L10n HTML5 FR where
1385 l10n_Header_Address _l10n = "Adresse"
1386 l10n_Header_Date _l10n = "Date"
1387 l10n_Header_Origin _l10n = "Origine"
1388 l10n_Header_Source _l10n = "Source"
1389 l10n_Header_Version _l10n = "Version"
1390 l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
1391 l10n_Error_Tag_unknown _l10n = "Tag inconnu"
1392 l10n_Error_Tag_ambiguous _l10n = "Tag ambigu"
1393 l10n_Error_Rref_unknown _l10n = "Référence inconnue"
1394 l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
1395
1396 instance Plain.L10n HTML5 EN where
1397 l10n_Colon l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
1398 l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
1399 l10n_Date date l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
1400 l10n_Quote msg _l10n = do
1401 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
1402 let (o,c) :: (HTML5, HTML5) =
1403 case unNat depth `mod` 3 of
1404 0 -> ("“","”")
1405 1 -> ("« "," »")
1406 _ -> ("‟","„")
1407 o
1408 setDepth $ succNat depth
1409 msg
1410 setDepth $ depth
1411 c
1412 where
1413 setDepth d =
1414 liftStateMarkup $ S.modify' $ \s ->
1415 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
1416 instance Plain.L10n HTML5 FR where
1417 l10n_Colon l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
1418 l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
1419 l10n_Date date l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
1420 l10n_Quote msg _l10n = do
1421 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
1422 let (o,c) :: (HTML5, HTML5) =
1423 case unNat depth `mod` 3 of
1424 0 -> ("« "," »")
1425 1 -> ("“","”")
1426 _ -> ("‟","„")
1427 o
1428 setDepth $ succNat depth
1429 msg
1430 setDepth $ depth
1431 c
1432 where
1433 setDepth d =
1434 liftStateMarkup $ S.modify' $ \s ->
1435 s{state_plainify=(state_plainify s){Plain.state_quote=d}}