Hdoc/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 Hdoc.DTC.Write.HTML5.Judgment where
   8
   9 import Control.Monad (Monad(..), join, forM, forM_)
  10 import Data.Default.Class (Default(..))
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>))
  16 import Data.Int (Int)
  17 import Data.Locale hiding (Index)
  18 import Data.Maybe (Maybe(..), maybe, maybeToList, listToMaybe, fromMaybe, isJust)
  19 import Data.Monoid (Monoid(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.String (String)
  22 import Data.Tuple (snd)
  23 import Prelude ((*), Fractional(..), Double, toRational, RealFrac(..))
  24 import Text.Blaze ((!))
  25 import Text.Show (Show(..))
  26 import qualified Control.Monad.Trans.State as S
  27 import qualified Data.Char as Char
  28 import qualified Data.HashMap.Strict as HM
  29 import qualified Data.HashSet as HS
  30 import qualified Data.List as List
  31 import qualified Data.Map.Strict as Map
  32 import qualified Data.Set as Set
  33 import qualified Data.Text.Lazy as TL
  34 import qualified Data.Tree as Tree
  35 import qualified Hjugement as MJ
  36 import qualified Prelude (error)
  37 import qualified Text.Blaze.Html5 as H
  38 import qualified Text.Blaze.Html5.Attributes  as HA
  39
  40 import Hdoc.DTC.Document as DTC
  41 import Hdoc.DTC.Write.HTML5.Base
  42 import Hdoc.DTC.Write.HTML5.Ident
  43 import Hdoc.DTC.Write.XML ()
  44 import Control.Monad.Utils
  45 import Text.Blaze.Utils
  46 import qualified Hdoc.XML as XML
  47 import qualified Hdoc.DTC.Collect as Collect
  48 import qualified Hdoc.DTC.Write.Plain as Plain
  49
  50 -- <debug>
  51 -- import Debug.Trace
  52 showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
  53 showJudgments js =
  54         Tree.drawForest $
  55         ((show <$>) <$>) $
  56         -- Tree.Node (Left ("","",Nothing)) $
  57         (<$> HM.toList js) $ \((j,g,q),ts) ->
  58                 Tree.Node
  59                  (Left (unIdent j,unIdent g,Plain.text def <$> q))
  60                  ((Right <$>) <$> ts)
  61 -- </debug>
  62
  63 instance Html5ify Title => Html5ify Judgment where
  64  html5ify Judgment{..} = do
  65         liftComposeState $ S.modify' $ \s -> s
  66          { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
  67         H.div ! HA.id (attrify $ identify $ XML.pos_ancestors judgment_posXML) $$ do
  68                 let commentJGC = HM.fromList
  69                         [ (choice_, HM.fromListWith (<>)
  70                                 [ (opinion_grade, HM.singleton opinion_judge opinion_comment)
  71                                 | Opinion{..} <- choice_opinions ])
  72                         | choice_@Choice{..} <- judgment_choices ]
  73                 case judgment_question of
  74                  Nothing -> mempty
  75                  Just title -> H.div ! HA.class_ "judgment-question" $$ html5ify title
  76                 H.dl ! HA.class_ "judgment-choices" $$ do
  77                         case judgment_opinionsByChoice of
  78                          Nothing -> do
  79                                 forM_ judgment_choices $ \Choice{..} -> do
  80                                         H.dt ! HA.class_ "choice-title"
  81                                              ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
  82                                                 html5ify choice_title
  83                          Just distByJudgeByChoice -> do
  84                                 let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
  85                                 let ranking = MJ.majorityRanking meritByChoice
  86                                 forM_ ranking $ \(choice_@DTC.Choice{..}, majorityValue) -> do
  87                                         H.dt ! HA.class_ "choice-title"
  88                                              ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
  89                                                 html5ify choice_title
  90                                         H.dd ! HA.class_ "choice-merit" $$ do
  91                                                 let distByJudge = distByJudgeByChoice HM.!choice_
  92                                                 let numJudges   = HM.size distByJudge
  93                                                 html5MeritHistogram majorityValue numJudges
  94                                                 let grades    = Map.keys $ MJ.unMerit $ meritC HM.!choice_
  95                                                 let commentJG = HM.lookup choice_ commentJGC
  96                                                 html5MeritComments distByJudge grades commentJG
  97 instance Html5ify Judges where
  98         html5ify Judges{..} =
  99                 html5CommonAttrs judges_attrs
 100                  { classes = "judges":classes judges_attrs
 101                  , DTC.id  = Just $ Ident $ Plain.text def $ XML.pos_ancestors judges_posXML
 102                  } $
 103                 H.div $$ do
 104                         mempty
 105
 106 html5MeritComments ::
 107  Html5ify Title =>
 108  MJ.Opinions Name (MJ.Ranked Grade) ->
 109  [MJ.Ranked Grade] ->
 110  Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
 111  HTML5
 112 html5MeritComments distJ grades commentJG = do
 113         Loqualization l10n <- liftComposeState $ S.gets state_l10n
 114         H.ul ! HA.class_ "merit-comments" $$ do
 115                 forM_ grades $ \case
 116                  grade | DTC.Grade{..} <- MJ.unRank grade -> do
 117                         let commentJ = commentJG >>= HM.lookup grade_name
 118                         let judgesWithComment =
 119                                 -- FIXME: sort accents better: « e é f » not « e f é »
 120                                 List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
 121                                  [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
 122                                  | (judge, dist) <- HM.toList distJ
 123                                  , importance <- maybeToList $ Map.lookup grade dist ]
 124                         forM_ judgesWithComment $ \(judge, importance, comment) ->
 125                                 H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
 126                                         H.span
 127                                          ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
 128                                          ! HA.style ("color:"<>attrify grade_color<>";") $$ do
 129                                                 unless (importance == 1) $ do
 130                                                         H.span ! HA.class_ "section-importance" $$ do
 131                                                                 let percent =
 132                                                                         (round::Double -> Int) $
 133                                                                         fromRational $ importance * 100
 134                                                                 html5ify $ show percent
 135                                                                 "%"::HTML5
 136                                                 html5ify judge
 137                                         case comment of
 138                                          Nothing -> mempty
 139                                          Just p -> do
 140                                                 Plain.l10n_Colon l10n :: HTML5
 141                                                 html5ify p
 142
 143 html5MeritHistogram ::
 144  Html5ify Title =>
 145  MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
 146 html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
 147         H.div ! HA.class_ "merit-histogram" $$ do
 148                 forM_ majVal $ \case
 149                  (grade, count) | DTC.Grade{..} <- MJ.unRank grade -> do
 150                         let percent :: Double =
 151                                 fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
 152                                 (count / toRational numJudges) * 100 * 1000) / 1000
 153                         let bcolor  = "background-color:"<>attrify grade_color<>";"
 154                         let width   = "width:"<>attrify percent<>"%;"
 155                         let display = if percent == 0 then "display:none;" else ""
 156                         H.div
 157                          ! HA.class_ "merit-grade"
 158                          ! HA.alt (attrify grade_name) -- FIXME: do not work
 159                          ! HA.style (bcolor<>display<>width) $$ do
 160                                 H.div
 161                                  ! HA.class_ "grade-name" $$ do
 162                                         case grade_title of
 163                                          Nothing -> html5ify grade_name
 164                                          Just t  -> html5ify t
 165
 166 html5Judgments :: HTML5
 167 html5Judgments = do
 168         Collect.All{..} <- liftComposeState $ S.gets state_collect
 169         opinionsByChoiceByNodeBySectionByJudgment <-
 170                 forM (HM.toList all_judgments) $ \(judgment@Judgment{..}, choicesBySection) -> do
 171                         -- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
 172                         -- can safely be used here: 'judgment_judgesId' and 'judgment_gradesId' are ok
 173                         let judgmentGrades =
 174                                 maybe (Prelude.error $ show judgment_grades) MJ.grades $ -- unknown grades
 175                                 HM.lookup judgment_gradesId all_grades
 176                         let Judges{..} =
 177                                 fromMaybe (Prelude.error $ show judgment_judges) $ -- unknown judges
 178                                 HM.lookup judgment_judgesId all_judges
 179                         let defaultGradeByJudge =
 180                                 let defaultGrade =
 181                                         List.head
 182                                          [ g | g <- Set.toList judgmentGrades
 183                                          , grade_isDefault $ MJ.unRank g
 184                                          ] in
 185                                 (<$> judges_byName) $ \js ->
 186                                         let Judge{..} = List.head js in
 187                                         let judgeDefaultGrade = do
 188                                                 grade <- join $ listToMaybe <$> HM.lookup judgment_gradesId judge_defaultGrades
 189                                                 listToMaybe
 190                                                  [ g | g <- Set.toList judgmentGrades
 191                                                  , grade_name (MJ.unRank g) == grade
 192                                                  ] in
 193                                         defaultGrade`fromMaybe`judgeDefaultGrade
 194                         opinionsByChoiceByNodeBySection <-
 195                                 forM choicesBySection $ \choicesTree -> do
 196                                         judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
 197                                                 judgmentOpinions <- forM choices $ \choice_@DTC.Choice{..} -> do
 198                                                         gradeByJudge <- forM choice_opinions $ \Opinion{..} -> do
 199                                                                 case listToMaybe
 200                                                                          [ g | g <- Set.toList judgmentGrades
 201                                                                          , grade_name (MJ.unRank g) == opinion_grade
 202                                                                          ] of
 203                                                                  Just grd -> return (opinion_judge, MJ.Section opinion_importance (Just grd))
 204                                                                  Nothing -> Prelude.error $ show opinion_grade -- unknown grade
 205                                                         return (choice_, HM.fromList gradeByJudge)
 206                                                 return $ MJ.SectionNode section_importance $ HM.fromList judgmentOpinions
 207                                         let judgmentChoices = HS.fromList $ snd $ Tree.rootLabel choicesTree
 208                                           -- NOTE: choices are determined by those at the root Tree.Node.
 209                                         -- NOTE: core Majority Judgment calculus handled here by MJ
 210                                         case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
 211                                          Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
 212                                          Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
 213                         -- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
 214                         -- this will match perfectly withw the 'html5ify' traversal:
 215                         -- 'BodySection' by 'BodySection'.
 216                         return (judgment, join $ toList <$> opinionsByChoiceByNodeBySection)
 217         liftComposeState $ S.modify' $ \st ->
 218                 st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}