]> Git — Sourcephile - doclang.git/blob - src/Textphile/DTC/Write/HTML5/Judgment.hs
Fix megaparsec-8 update
[doclang.git] / src / Textphile / DTC / Write / HTML5 / Judgment.hs
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 module Textphile.DTC.Write.HTML5.Judgment where
8
9 import Control.Arrow ((&&&))
10 import Control.Monad (Monad(..), (=<<), forM, forM_, join)
11 import Data.Bool
12 import Data.Default.Class (Default(..))
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Foldable (Foldable(..), any, concat)
16 import Data.Function (($), (.), id, const, on)
17 import Data.Functor ((<$>), (<$))
18 import Data.Int (Int)
19 import Data.Locale hiding (Index)
20 import Data.Maybe (Maybe(..), maybe, maybeToList, listToMaybe, fromMaybe, isJust)
21 import Data.Monoid (Monoid(..))
22 import Data.Semigroup (Semigroup(..))
23 import Data.Sequence (Seq)
24 import Data.String (String)
25 import Data.Tuple (fst)
26 import Prelude ((*), Fractional(..), Double, toRational, RealFrac(..), undefined)
27 import Text.Blaze ((!))
28 import Text.Show (Show(..))
29 import Data.TreeSeq.Strict (Tree(..))
30 import qualified Control.Monad.Trans.Writer.Strict as W
31 import qualified Control.Monad.Trans.RWS.Strict as RWS
32 import qualified Data.Char as Char
33 import qualified Data.HashMap.Strict as HM
34 import qualified Data.HashSet as HS
35 import qualified Data.List as List
36 import qualified Data.Map.Strict as Map
37 import qualified Data.Sequence as Seq
38 import qualified Data.Set as Set
39 import qualified Data.Text.Lazy as TL
40 import qualified Data.Tree as Tree
41 import qualified Data.TreeSeq.Strict as TS
42 import qualified Majority.Judgment as MJ
43 import qualified Prelude (error)
44 import qualified Text.Blaze.Html5 as H
45 import qualified Text.Blaze.Html5.Attributes as HA
46
47 import Textphile.DTC.Document as DTC
48 import Textphile.DTC.Write.HTML5.Base
49 import Textphile.DTC.Write.HTML5.Ident
50 import Textphile.DTC.Write.XML ()
51 import Control.Monad.Utils
52 import Text.Blaze.Utils
53 import qualified Textphile.XML as XML
54 import qualified Textphile.DTC.Analyze.Collect as Analyze
55 import qualified Textphile.DTC.Analyze.Check as Analyze
56 import qualified Textphile.DTC.Write.Plain as Plain
57
58 -- import qualified Textphile.TCT.Debug as Debug
59
60 -- <debug>
61 -- import Debug.Trace
62 showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
63 showJudgments js =
64 Tree.drawForest $
65 ((show <$>) <$>) $
66 -- Tree.Node (Left ("","",Nothing)) $
67 (<$> HM.toList js) $ \((j,g,q),ts) ->
68 Tree.Node
69 (Left (unIdent j,unIdent g,Plain.text def <$> q))
70 ((Right <$>) <$> ts)
71 {-
72 debug0 :: Debug.Pretty a => String -> a -> a
73 debug0 m a = Debug.trace (m <> ": " <> Debug.runPretty 2 a) a
74 instance Debug.Pretty JudgmentKey
75 instance Debug.Pretty Choice
76 instance Debug.Pretty Name
77 instance Debug.Pretty Grade
78 instance (Debug.Pretty a, Show a) => Debug.Pretty (MJ.Ranked a)
79 -}
80
81 -- </debug>
82
83 instance Html5ify Title => Html5ify Judgment where
84 html5ify Judgment{..} = do
85 composeLift $ RWS.tell def
86 { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
87 H.div ! HA.id (attrify $ identify $ XML.pos_ancestors judgment_posXML) $$ do
88 let commentJGC = HM.fromList
89 [ (choice_, HM.fromListWith (<>)
90 [ (opinion_grade, HM.singleton opinion_judge opinion_comment)
91 | Opinion{..} <- choice_opinions ])
92 | choice_@Choice{..} <- judgment_choices ]
93 case judgment_question of
94 Nothing -> mempty
95 Just title -> H.div ! HA.class_ "judgment-question" $$ html5ify title
96 H.dl ! HA.class_ "judgment-choices" $$ do
97 case judgment_opinionsByChoice of
98 Nothing -> do
99 forM_ judgment_choices $ \Choice{..} -> do
100 H.dt
101 ! HA.class_ "choice-title"
102 ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
103 html5ify choice_title
104 Just distByJudgeByChoice -> do
105 let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
106 let ranking = MJ.majorityRanking meritByChoice
107 forM_ ranking $ \(choice_@DTC.Choice{..}, _majorityValue) -> do
108 H.dt
109 ! HA.class_ "choice-title"
110 ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
111 html5ify choice_title
112 H.dd ! HA.class_ "choice-merit" $$ do
113 let merit = meritC HM.!choice_
114 let distByJudge = distByJudgeByChoice HM.!choice_
115 let numJudges = HM.size distByJudge
116 html5MeritHistogram merit numJudges
117 let grades = Map.keys $ MJ.unMerit $ merit
118 let commentJG = HM.lookup choice_ commentJGC
119 html5MeritComments distByJudge grades commentJG
120 instance Html5ify Judges where
121 html5ify Judges{..} =
122 html5CommonAttrs judges_attrs
123 { attrs_classes = "judges":attrs_classes judges_attrs
124 , attrs_id = Just $ identify $ XML.pos_ancestors judges_posXML
125 } $
126 H.div $$ do
127 mempty
128
129 judgmentKey :: Judgment -> JudgmentKey
130 judgmentKey Judgment{..} =
131 JudgmentKey
132 { judgmentKey_judgesId = judgment_judgesId
133 , judgmentKey_gradesId = judgment_gradesId
134 , judgmentKey_question = judgment_question
135 }
136
137 -- | Create a mapping from what makes 'Judgment's equal
138 -- to what their particular used content is.
139 judgmentByKey :: [Judgment] -> HM.HashMap JudgmentKey Judgment
140 judgmentByKey js =
141 HM.fromList $ (<$> js) $ \j@Judgment{..} -> (judgmentKey j,j)
142
143 -- | Collect in a 'Tree' the 'Judgment's of the given 'Body'.
144 judgmentByKeyBySection :: Body ->
145 W.Writer (Analyze.Errors (Seq Location))
146 (TS.Trees (HM.HashMap JudgmentKey Judgment))
147 judgmentByKeyBySection body =
148 (join <$>) $ forM body $ \(Tree b bs) -> do
149 judgmentKS <- judgmentByKeyBySection bs
150 case b of
151 BodyBlock{} -> return mempty
152 BodySection Section{section_about=About{..}, ..} ->
153 -- forM_ about_judgments $ \j@Judgment{..} ->
154 --
155 return $ Seq.singleton $ Tree sectionJudgments $
156 if hasJudgeableBlocks bs
157 then Tree blocksJudgments Seq.empty Seq.<| judgmentKS
158 -- NOTE: Add a judgments inheriting the 'opinion_grade' of these 'judgments'.
159 -- This enables judges to express something on material not in a child 'BodySection'.
160 else judgmentKS
161 where
162 judgments = judgmentByKey about_judgments
163 -- NOTE: On the parent section, any 'opinion_default' overrides 'opinion_grade',
164 -- so that the children sections will inherit it in 'MJ.opinionsBySection'.
165 sectionJudgments =
166 (<$> judgments) $ \j@Judgment{..} ->
167 j{judgment_choices = (<$> judgment_choices) $ \c@Choice{..} ->
168 c{choice_opinions = (<$> choice_opinions) $ \o@Opinion{..} ->
169 o{opinion_grade = opinion_grade`fromMaybe`opinion_default}
170 }
171 }
172 -- NOTE: On the (children) blocks, 'opinion_default' is not used.
173 blocksJudgments = (<$> judgments) $ \j@Judgment{..} ->
174 j{judgment_choices = (<$> judgment_choices) $ \c@Choice{..} ->
175 c{choice_opinions = (<$> choice_opinions) $ \o@Opinion{..} ->
176 o{opinion_default = Nothing}
177 }
178 }
179
180 -- | Return 'True' iif. the 'BodySection' has at least
181 -- a 'BodySection' and a judgeable 'BodyBlock' as children.
182 hasJudgeableBlocks :: Body -> Bool
183 hasJudgeableBlocks bs =
184 (\case {Tree BodySection{} _ -> True; _ -> False} `any` bs) &&
185 (\case {Tree (BodyBlock blk) _ -> hasJudgeableBlock blk; _ -> False} `any` bs)
186 where
187 hasJudgeableBlock = \case
188 BlockAside{} -> True
189 BlockFigure{} -> True
190 BlockPara p -> case p of
191 ParaItem{..} -> hasJudgeablePara item
192 ParaItems{..} -> hasJudgeablePara`any`items
193 BlockBreak{} -> False
194 BlockGrades{} -> False
195 BlockIndex{} -> False
196 BlockJudges{} -> False
197 BlockReferences{} -> False
198 BlockToC{} -> False
199 BlockToF{} -> False
200 hasJudgeablePara = \case
201 ParaComment{} -> False
202 _ -> True
203
204 -- | Group by 'Judgment' the result of 'judgmentByKeyBySection'.
205 judgmentBySectionByKey :: -- TODO: see if this can be done using Reader and collect
206 HM.HashMap JudgmentKey [Tree.Tree Judgment] ->
207 TS.Tree (HM.HashMap JudgmentKey Judgment) ->
208 HM.HashMap JudgmentKey [Tree.Tree Judgment]
209 {-
210 W.Writer (Analyze.Errors (Seq Location))
211 (HM.HashMap JudgmentKey [Tree.Tree Judgment])
212 -}
213 judgmentBySectionByKey inh (TS.Tree selfJ childrenJS) =
214 HM.unionWith
215 (\selfS childrenS ->
216 (<$> selfS) $ \(Tree.Node choices old) ->
217 Tree.Node choices (old<>childrenS))
218 (selfSJ <> inh)
219 childrenSJ
220 where
221 selfSJ = (\js -> [Tree.Node js []]) <$> selfJ
222 childrenSJ =
223 foldl'
224 (\accJ childJ ->
225 HM.unionWith (<>) accJ $
226 judgmentBySectionByKey
227 (([Tree.Node def []] <$ selfJ) <> inh)
228 childJ)
229 HM.empty
230 childrenJS
231
232 analyseJudgments :: Document -> HTML5
233 analyseJudgments Document{..} = do
234 let judgmentKS =
235 fst $ W.runWriter $
236 judgmentByKeyBySection $
237 case document_head of
238 Nothing -> document_body
239 Just Head{..} ->
240 Seq.singleton $
241 TS.Tree (DTC.BodySection head_section) $
242 head_body <> document_body
243 let judgmentSK =
244 judgmentBySectionByKey HM.empty $
245 TS.Tree HM.empty judgmentKS
246 Analyze.All{..} <- composeLift $ RWS.asks reader_all
247 opinionsByChoiceByNodeBySectionByJudgment <-
248 forM (HM.toList judgmentSK) $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
249 let judgmentGrades =
250 maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
251 -- FIXME: report correctly
252 listToMaybe $ toList $
253 HM.lookupDefault def judgmentKey_gradesId all_grades
254 let Judges{..} =
255 fromMaybe (Prelude.error $ show judgmentKey_judgesId) $
256 -- FIXME: report correctly
257 listToMaybe $ toList $
258 HM.lookupDefault def judgmentKey_judgesId all_judges
259 let defaultGradeByJudge =
260 let defaultGrade =
261 List.head
262 [ g | g <- Set.toList judgmentGrades
263 , grade_isDefault $ MJ.unRank g
264 ] in
265 (<$> judges_byName) $ \js ->
266 let Judge{..} = List.head js in
267 let judgeDefaultGrade = do
268 grade <- listToMaybe =<< HM.lookup judgmentKey_gradesId judge_defaultGrades
269 listToMaybe
270 [ g | g <- Set.toList judgmentGrades
271 , grade_name (MJ.unRank g) == grade
272 ] in
273 defaultGrade`fromMaybe`judgeDefaultGrade
274 opinionsByChoiceByNodeBySection <-
275 forM judgmentsBySection $ \judgmentsTree -> do
276 judgmentTree <- forM judgmentsTree $ \Judgment{judgment_importance, judgment_choices} -> do
277 judgmentOpinions <- forM judgment_choices $ \choice@DTC.Choice{..} -> do
278 gradeByJudge <- forM choice_opinions $ \Opinion{..} -> do
279 case listToMaybe
280 [ g | g <- Set.toList judgmentGrades
281 , grade_name (MJ.unRank g) == opinion_grade
282 ] of
283 Just grd -> return $ (opinion_judge,)
284 MJ.Section
285 { MJ.sectionShare = opinion_importance
286 , MJ.sectionGrade = Just grd
287 }
288 Nothing -> Prelude.error $ show opinion_grade -- FIXME: report correctly
289 return (choice, HM.fromList gradeByJudge)
290 return $ MJ.SectionNode judgment_importance $ HM.fromList judgmentOpinions
291 let judgmentChoices = HS.fromList $ judgment_choices $ Tree.rootLabel judgmentsTree
292 -- NOTE: choices are determined by those at the root Tree.Node.
293 -- NOTE: core Majority Judgment calculus handled here by MJ
294 case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
295 Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
296 Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
297 -- FIXME: report correctly
298 -- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
299 -- this will match perfectly with the 'html5ify' traversal:
300 -- 'BodySection' by 'BodySection'.
301 return (judgmentK, toList =<< opinionsByChoiceByNodeBySection)
302 composeLift $ RWS.modify $ \st ->
303 st{state_judgments = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}
304
305 html5MeritComments ::
306 Html5ify Title =>
307 MJ.Opinions Name (MJ.Ranked Grade) ->
308 [MJ.Ranked Grade] ->
309 Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
310 HTML5
311 html5MeritComments distJ grades commentJG = do
312 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
313 H.ul ! HA.class_ "merit-comments" $$ do
314 forM_ grades $ \case
315 grade | DTC.Grade{..} <- MJ.unRank grade -> do
316 let commentJ = commentJG >>= HM.lookup grade_name
317 let judgesWithComment =
318 -- FIXME: sort accents better: « e é f » not « e f é »
319 List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
320 [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
321 | (judge, dist) <- HM.toList distJ
322 , importance <- maybeToList $ Map.lookup grade dist ]
323 forM_ judgesWithComment $ \(judge, importance, comment) ->
324 H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
325 H.span
326 ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
327 ! HA.style ("color:"<>attrify grade_color<>";") $$ do
328 unless (importance == 1) $ do
329 H.span ! HA.class_ "section-importance" $$ do
330 let percent =
331 (round::Double -> Int) $
332 fromRational $ importance * 100
333 html5ify $ show percent
334 "%"::HTML5
335 html5ify judge
336 case comment of
337 Nothing -> mempty
338 Just p -> do
339 Plain.l10n_Colon l10n :: HTML5
340 html5ify p
341
342 html5MeritHistogram ::
343 Html5ify Title =>
344 MJ.Merit (MJ.Ranked Grade) -> Int -> HTML5
345 html5MeritHistogram (MJ.Merit merit) numJudges = do
346 H.div ! HA.class_ "merit-histogram" $$ do
347 forM_ (Map.toList merit) $ \case
348 (grade, share) | DTC.Grade{..} <- MJ.unRank grade -> do
349 let percent :: Double =
350 fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
351 (share / toRational numJudges) * 100 * 1000) / 1000
352 let bcolor = "background-color:"<>attrify grade_color<>";"
353 let width = "width:"<>attrify percent<>"%;"
354 let display = if percent == 0 then "display:none;" else ""
355 H.div
356 ! HA.class_ "merit-grade"
357 ! HA.alt (attrify grade_name) -- FIXME: do not work
358 ! HA.style (bcolor<>display<>width) $$ do
359 H.div
360 ! HA.class_ "grade-name" $$ do
361 case grade_title of
362 Nothing -> html5ify grade_name
363 Just t -> html5ify t
364
365 html5SectionJudgments :: Html5ify Title => HTML5
366 html5SectionJudgments = do
367 st <- composeLift RWS.get
368 Reader{reader_section, reader_body} <- composeLift RWS.ask
369 let sectionJudgments =
370 -- NOTE: merge inherited judgments with those of this section,
371 -- while preserving their appearing order.
372 List.nubBy ((==) `on` judgmentKey) $
373 concat $
374 about_judgments . section_about <$> reader_section
375 let opinsBySectionByJudgment =
376 -- NOTE: gather opinions of the judgments of this section.
377 state_judgments st `HM.intersection`
378 HM.fromList ((judgmentKey &&& id) <$> sectionJudgments)
379 let dropChildrenBlocksJudgments =
380 -- NOTE: drop the 'phantomJudgment' concerning the 'BodyBlock's
381 -- directly children of this 'BodySection'.
382 if hasJudgeableBlocks reader_body
383 then List.tail
384 else id
385 composeLift $ RWS.modify $ \s ->
386 s{ state_judgments =
387 -- NOTE: drop current opinions of the judgments of this section.
388 HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
389 (state_judgments s)
390 opinsBySectionByJudgment
391 }
392 unless (null opinsBySectionByJudgment) $ do
393 let judgmentK = judgmentByKey sectionJudgments
394 composeLift $ RWS.tell def
395 { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
396 let isDocumentHead =
397 case reader_section of
398 _:_:_ -> False
399 _ -> True
400 (if isDocumentHead then id else ((H.aside ! HA.class_ "aside") $$)) $
401 forM_ sectionJudgments $ \judgment -> do
402 -- NOTE: preserve the wanted order
403 let key = judgmentKey judgment
404 let opinsBySection = opinsBySectionByJudgment HM.!key
405 H.div ! HA.class_
406 ("judgment section-judgment"<>
407 if isDocumentHead then " document-judgment" else "") $$ do
408 html5ify judgment
409 { judgment_opinionsByChoice = listToMaybe opinsBySection
410 , judgment_choices = maybe [] judgment_choices $ HM.lookup key judgmentK
411 }
412
413 stateJudgments ::
414 Analyze.All -> Document ->
415 ( HM.HashMap JudgmentKey [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
416 , Analyze.Errors (Seq Location)
417 )
418 stateJudgments Analyze.All{..} Document{..} =
419 W.runWriter $ do
420 judgmentKS <-
421 judgmentByKeyBySection $
422 case document_head of
423 Nothing -> document_body
424 Just Head{..} ->
425 Seq.singleton $
426 TS.Tree (DTC.BodySection head_section) $
427 head_body <> document_body
428 let judgmentSK =
429 judgmentBySectionByKey HM.empty $
430 TS.Tree HM.empty judgmentKS
431 W.tell def
432 (HM.fromList <$>)
433 $ forM (HM.toList judgmentSK)
434 $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
435 {-
436 judgmentGrades <-
437 maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
438 -- FIXME: report correctly
439 listToMaybe $ toList $
440 case HM.lookup judgmentKey_gradesId all_grades of
441 Nothing -> W.tell def{errors_judgment_grades_unknown = }
442 -}
443 undefined
444 {-
445 opinionsByChoiceByNodeBySectionByJudgment <-
446 forM (HM.toList judgmentSK) $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
447 let judgmentGrades =
448 maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
449 -- FIXME: report correctly
450 listToMaybe $ toList $
451 HM.lookupDefault def judgmentKey_gradesId all_grades
452 let Judges{..} =
453 fromMaybe (Prelude.error $ show judgmentKey_judgesId) $
454 -- FIXME: report correctly
455 listToMaybe $ toList $
456 HM.lookupDefault def judgmentKey_judgesId all_judges
457 let defaultGradeByJudge =
458 let defaultGrade =
459 List.head
460 [ g | g <- Set.toList judgmentGrades
461 , grade_isDefault $ MJ.unRank g
462 ] in
463 (<$> judges_byName) $ \js ->
464 let Judge{..} = List.head js in
465 let judgeDefaultGrade = do
466 grade <- listToMaybe =<< HM.lookup judgmentKey_gradesId judge_defaultGrades
467 listToMaybe
468 [ g | g <- Set.toList judgmentGrades
469 , grade_name (MJ.unRank g) == grade
470 ] in
471 defaultGrade`fromMaybe`judgeDefaultGrade
472 MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree
473 -}