1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 module Hdoc.DTC.Write.HTML5.Judgment where
9 import Control.Arrow ((&&&))
10 import Control.Monad (Monad(..), (=<<), forM, forM_, join)
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 ((<$>), (<$))
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
47 import Hdoc.DTC.Document as DTC
48 import Hdoc.DTC.Write.HTML5.Base
49 import Hdoc.DTC.Write.HTML5.Ident
50 import Hdoc.DTC.Write.XML ()
51 import Control.Monad.Utils
52 import Text.Blaze.Utils
53 import qualified Hdoc.XML as XML
54 import qualified Hdoc.DTC.Analyze.Collect as Analyze
55 import qualified Hdoc.DTC.Analyze.Check as Analyze
56 import qualified Hdoc.DTC.Write.Plain as Plain
58 -- import qualified Hdoc.TCT.Debug as Debug
62 showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
66 -- Tree.Node (Left ("","",Nothing)) $
67 (<$> HM.toList js) $ \((j,g,q),ts) ->
69 (Left (unIdent j,unIdent g,Plain.text def <$> q))
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)
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
95 Just title -> H.div ! HA.class_ "judgment-question" $$ html5ify title
96 H.dl ! HA.class_ "judgment-choices" $$ do
97 case judgment_opinionsByChoice of
99 forM_ judgment_choices $ \Choice{..} -> do
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
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
129 judgmentKey :: Judgment -> JudgmentKey
130 judgmentKey Judgment{..} =
132 { judgmentKey_judgesId = judgment_judgesId
133 , judgmentKey_gradesId = judgment_gradesId
134 , judgmentKey_question = judgment_question
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
141 HM.fromList $ (<$> js) $ \j@Judgment{..} -> (judgmentKey j,j)
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
151 BodyBlock{} -> return mempty
152 BodySection Section{section_about=About{..}, ..} ->
153 -- forM_ about_judgments $ \j@Judgment{..} ->
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'.
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'.
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}
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}
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)
187 hasJudgeableBlock = \case
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
200 hasJudgeablePara = \case
201 ParaComment{} -> False
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]
210 W.Writer (Analyze.Errors (Seq Location))
211 (HM.HashMap JudgmentKey [Tree.Tree Judgment])
213 judgmentBySectionByKey inh (TS.Tree selfJ childrenJS) =
216 (<$> selfS) $ \(Tree.Node choices old) ->
217 Tree.Node choices (old<>childrenS))
221 selfSJ = (\js -> [Tree.Node js []]) <$> selfJ
225 HM.unionWith (<>) accJ $
226 judgmentBySectionByKey
227 (([Tree.Node def []] <$ selfJ) <> inh)
232 analyseJudgments :: Document -> HTML5
233 analyseJudgments Document{..} = do
236 judgmentByKeyBySection $
237 case document_head of
238 Nothing -> document_body
241 TS.Tree (DTC.BodySection head_section) $
242 head_body <> document_body
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
250 maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
251 -- FIXME: report correctly
252 listToMaybe $ toList $
253 HM.lookupDefault def judgmentKey_gradesId all_grades
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 =
262 [ g | g <- Set.toList judgmentGrades
263 , grade_isDefault $ MJ.unRank g
265 (<$> judges_byName) $ \js ->
266 let Judge{..} = List.head js in
267 let judgeDefaultGrade = do
268 grade <- listToMaybe =<< HM.lookup judgmentKey_gradesId judge_defaultGrades
270 [ g | g <- Set.toList judgmentGrades
271 , grade_name (MJ.unRank g) == grade
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
280 [ g | g <- Set.toList judgmentGrades
281 , grade_name (MJ.unRank g) == opinion_grade
283 Just grd -> return $ (opinion_judge,)
285 { MJ.sectionShare = opinion_importance
286 , MJ.sectionGrade = Just grd
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}
305 html5MeritComments ::
307 MJ.Opinions Name (MJ.Ranked Grade) ->
309 Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
311 html5MeritComments distJ grades commentJG = do
312 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
313 H.ul ! HA.class_ "merit-comments" $$ do
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
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
331 (round::Double -> Int) $
332 fromRational $ importance * 100
333 html5ify $ show percent
339 Plain.l10n_Colon l10n :: HTML5
342 html5MeritHistogram ::
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 ""
356 ! HA.class_ "merit-grade"
357 ! HA.alt (attrify grade_name) -- FIXME: do not work
358 ! HA.style (bcolor<>display<>width) $$ do
360 ! HA.class_ "grade-name" $$ do
362 Nothing -> html5ify grade_name
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) $
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
385 composeLift $ RWS.modify $ \s ->
387 -- NOTE: drop current opinions of the judgments of this section.
388 HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
390 opinsBySectionByJudgment
392 unless (null opinsBySectionByJudgment) $ do
393 let judgmentK = judgmentByKey sectionJudgments
394 composeLift $ RWS.tell def
395 { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
397 case reader_section of
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
406 ("judgment section-judgment"<>
407 if isDocumentHead then " document-judgment" else "") $$ do
409 { judgment_opinionsByChoice = listToMaybe opinsBySection
410 , judgment_choices = maybe [] judgment_choices $ HM.lookup key judgmentK
414 Analyze.All -> Document ->
415 ( HM.HashMap JudgmentKey [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
416 , Analyze.Errors (Seq Location)
418 stateJudgments Analyze.All{..} Document{..} =
421 judgmentByKeyBySection $
422 case document_head of
423 Nothing -> document_body
426 TS.Tree (DTC.BodySection head_section) $
427 head_body <> document_body
429 judgmentBySectionByKey HM.empty $
430 TS.Tree HM.empty judgmentKS
433 $ forM (HM.toList judgmentSK)
434 $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
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 = }
445 opinionsByChoiceByNodeBySectionByJudgment <-
446 forM (HM.toList judgmentSK) $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
448 maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
449 -- FIXME: report correctly
450 listToMaybe $ toList $
451 HM.lookupDefault def judgmentKey_gradesId all_grades
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 =
460 [ g | g <- Set.toList judgmentGrades
461 , grade_isDefault $ MJ.unRank g
463 (<$> judges_byName) $ \js ->
464 let Judge{..} = List.head js in
465 let judgeDefaultGrade = do
466 grade <- listToMaybe =<< HM.lookup judgmentKey_gradesId judge_defaultGrades
468 [ g | g <- Set.toList judgmentGrades
469 , grade_name (MJ.unRank g) == grade
471 defaultGrade`fromMaybe`judgeDefaultGrade
472 MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree