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