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(..), (=<<), 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.RWS.Strict as RWS
  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 Majority.Judgment 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.Analyze.Collect as Analyze
  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         composeLift $ RWS.tell def
  66          { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
  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 merit       = meritC HM.!choice_
  92                                                 let distByJudge = distByJudgeByChoice HM.!choice_
  93                                                 let numJudges   = HM.size distByJudge
  94                                                 html5MeritHistogram merit numJudges
  95                                                 let grades    = Map.keys $ MJ.unMerit $ merit
  96                                                 let commentJG = HM.lookup choice_ commentJGC
  97                                                 html5MeritComments distByJudge grades commentJG
  98 instance Html5ify Judges where
  99         html5ify Judges{..} =
 100                 html5CommonAttrs judges_attrs
 101                  { attrs_classes = "judges":attrs_classes judges_attrs
 102                  , attrs_id      = Just $ Ident $ Plain.text def $ XML.pos_ancestors judges_posXML
 103                  } $
 104                 H.div $$ do
 105                         mempty
 106
 107 html5MeritComments ::
 108  Html5ify Title =>
 109  MJ.Opinions Name (MJ.Ranked Grade) ->
 110  [MJ.Ranked Grade] ->
 111  Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
 112  HTML5
 113 html5MeritComments distJ grades commentJG = do
 114         Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 115         H.ul ! HA.class_ "merit-comments" $$ do
 116                 forM_ grades $ \case
 117                  grade | DTC.Grade{..} <- MJ.unRank grade -> do
 118                         let commentJ = commentJG >>= HM.lookup grade_name
 119                         let judgesWithComment =
 120                                 -- FIXME: sort accents better: « e é f » not « e f é »
 121                                 List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
 122                                  [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
 123                                  | (judge, dist) <- HM.toList distJ
 124                                  , importance <- maybeToList $ Map.lookup grade dist ]
 125                         forM_ judgesWithComment $ \(judge, importance, comment) ->
 126                                 H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
 127                                         H.span
 128                                          ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
 129                                          ! HA.style ("color:"<>attrify grade_color<>";") $$ do
 130                                                 unless (importance == 1) $ do
 131                                                         H.span ! HA.class_ "section-importance" $$ do
 132                                                                 let percent =
 133                                                                         (round::Double -> Int) $
 134                                                                         fromRational $ importance * 100
 135                                                                 html5ify $ show percent
 136                                                                 "%"::HTML5
 137                                                 html5ify judge
 138                                         case comment of
 139                                          Nothing -> mempty
 140                                          Just p -> do
 141                                                 Plain.l10n_Colon l10n :: HTML5
 142                                                 html5ify p
 143
 144 html5MeritHistogram ::
 145  Html5ify Title =>
 146  MJ.Merit (MJ.Ranked Grade) -> Int -> HTML5
 147 html5MeritHistogram (MJ.Merit merit) numJudges = do
 148         H.div ! HA.class_ "merit-histogram" $$ do
 149                 forM_ (Map.toList merit) $ \case
 150                  (grade, share) | DTC.Grade{..} <- MJ.unRank grade -> do
 151                         let percent :: Double =
 152                                 fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
 153                                 (share / toRational numJudges) * 100 * 1000) / 1000
 154                         let bcolor  = "background-color:"<>attrify grade_color<>";"
 155                         let width   = "width:"<>attrify percent<>"%;"
 156                         let display = if percent == 0 then "display:none;" else ""
 157                         H.div
 158                          ! HA.class_ "merit-grade"
 159                          ! HA.alt (attrify grade_name) -- FIXME: do not work
 160                          ! HA.style (bcolor<>display<>width) $$ do
 161                                 H.div
 162                                  ! HA.class_ "grade-name" $$ do
 163                                         case grade_title of
 164                                          Nothing -> html5ify grade_name
 165                                          Just t  -> html5ify t
 166
 167 html5Judgments :: HTML5
 168 html5Judgments = do
 169         Analyze.All{..} <- composeLift $ RWS.asks reader_all
 170         opinionsByChoiceByNodeBySectionByJudgment <-
 171                 forM (HM.toList all_judgment) $ \(judgment@Judgment{..}, choicesBySection) -> do
 172                         -- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
 173                         -- can safely be used here: 'judgment_judgesId' and 'judgment_gradesId' are ok
 174                         let judgmentGrades =
 175                                 maybe (Prelude.error $ show judgment_grades) MJ.grades $ -- unknown grades
 176                                 listToMaybe $ toList $
 177                                 HM.lookupDefault def judgment_gradesId all_grades
 178                         let Judges{..} =
 179                                 fromMaybe (Prelude.error $ show judgment_judges) $ -- unknown judges
 180                                 listToMaybe $ toList $
 181                                 HM.lookupDefault def judgment_judgesId all_judges
 182                         let defaultGradeByJudge =
 183                                 let defaultGrade =
 184                                         List.head
 185                                          [ g | g <- Set.toList judgmentGrades
 186                                          , grade_isDefault $ MJ.unRank g
 187                                          ] in
 188                                 (<$> judges_byName) $ \js ->
 189                                         let Judge{..} = List.head js in
 190                                         let judgeDefaultGrade = do
 191                                                 grade <- listToMaybe =<< HM.lookup judgment_gradesId judge_defaultGrades
 192                                                 listToMaybe
 193                                                  [ g | g <- Set.toList judgmentGrades
 194                                                  , grade_name (MJ.unRank g) == grade
 195                                                  ] in
 196                                         defaultGrade`fromMaybe`judgeDefaultGrade
 197                         opinionsByChoiceByNodeBySection <-
 198                                 forM choicesBySection $ \choicesTree -> do
 199                                         judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
 200                                                 judgmentOpinions <- forM choices $ \choice_@DTC.Choice{..} -> do
 201                                                         gradeByJudge <- forM choice_opinions $ \Opinion{..} -> do
 202                                                                 case listToMaybe
 203                                                                          [ g | g <- Set.toList judgmentGrades
 204                                                                          , grade_name (MJ.unRank g) == opinion_grade
 205                                                                          ] of
 206                                                                  Just grd -> return (opinion_judge, MJ.Section opinion_importance (Just grd))
 207                                                                  Nothing -> Prelude.error $ show opinion_grade -- unknown grade
 208                                                         return (choice_, HM.fromList gradeByJudge)
 209                                                 return $ MJ.SectionNode section_importance $ HM.fromList judgmentOpinions
 210                                         let judgmentChoices = HS.fromList $ snd $ Tree.rootLabel choicesTree
 211                                           -- NOTE: choices are determined by those at the root Tree.Node.
 212                                         -- NOTE: core Majority Judgment calculus handled here by MJ
 213                                         case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
 214                                          Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
 215                                          Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
 216                         -- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
 217                         -- this will match perfectly with the 'html5ify' traversal:
 218                         -- 'BodySection' by 'BodySection'.
 219                         return (judgment, toList =<< opinionsByChoiceByNodeBySection)
 220         composeLift $ RWS.modify $ \st ->
 221                 st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}