{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Write.HTML5.Judgment where

import Control.Monad (Monad(..), join, forM, forM_)
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Locale hiding (Index)
import Data.Maybe (Maybe(..), maybe, maybeToList, listToMaybe, fromMaybe, isJust)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (snd)
import Prelude ((*), Fractional(..), Double, toRational, RealFrac(..))
import Text.Blaze ((!))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text.Lazy as TL
import qualified Data.Tree as Tree
import qualified Hjugement as MJ
import qualified Prelude (error)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA

import Hdoc.DTC.Document as DTC
import Hdoc.DTC.Write.HTML5.Base
import Hdoc.DTC.Write.HTML5.Ident
import Hdoc.DTC.Write.XML ()
import Control.Monad.Utils
import Text.Blaze.Utils
import qualified Hdoc.XML as XML
import qualified Hdoc.DTC.Collect as Collect
import qualified Hdoc.DTC.Write.Plain as Plain

-- <debug>
-- import Debug.Trace
showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
showJudgments js =
	Tree.drawForest $
	((show <$>) <$>) $
	-- Tree.Node (Left ("","",Nothing)) $
	(<$> HM.toList js) $ \((j,g,q),ts) ->
		Tree.Node
		 (Left (unIdent j,unIdent g,Plain.text def <$> q))
		 ((Right <$>) <$> ts)
-- </debug>

instance Html5ify Title => Html5ify Judgment where
 html5ify Judgment{..} = do
	liftComposeState $ S.modify' $ \s -> s
	 { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
	H.div ! HA.id (attrify $ identify $ XML.pos_ancestors judgment_posXML) $$ do
		let commentJGC = HM.fromList
			[ (choice_, HM.fromListWith (<>)
				[ (opinion_grade, HM.singleton opinion_judge opinion_comment)
				| Opinion{..} <- choice_opinions ])
			| choice_@Choice{..} <- judgment_choices ]
		case judgment_question of
		 Nothing -> mempty
		 Just title -> H.div ! HA.class_ "judgment-question" $$ html5ify title
		H.dl ! HA.class_ "judgment-choices" $$ do
			case judgment_opinionsByChoice of
			 Nothing -> do
				forM_ judgment_choices $ \Choice{..} -> do
					H.dt ! HA.class_ "choice-title"
					     ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
						html5ify choice_title
			 Just distByJudgeByChoice -> do
				let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
				let ranking = MJ.majorityRanking meritByChoice
				forM_ ranking $ \(choice_@DTC.Choice{..}, majorityValue) -> do
					H.dt ! HA.class_ "choice-title"
					     ! HA.id (attrify $ identify $ XML.pos_ancestors choice_posXML) $$ do
						html5ify choice_title
					H.dd ! HA.class_ "choice-merit" $$ do
						let distByJudge = distByJudgeByChoice HM.!choice_
						let numJudges   = HM.size distByJudge
						html5MeritHistogram majorityValue numJudges
						let grades    = Map.keys $ MJ.unMerit $ meritC HM.!choice_
						let commentJG = HM.lookup choice_ commentJGC
						html5MeritComments distByJudge grades commentJG
instance Html5ify Judges where
	html5ify Judges{..} =
		html5CommonAttrs judges_attrs
		 { classes = "judges":classes judges_attrs
		 , DTC.id  = Just $ Ident $ Plain.text def $ XML.pos_ancestors judges_posXML
		 } $
		H.div $$ do
			mempty

html5MeritComments ::
 Html5ify Title =>
 MJ.Opinions Name (MJ.Ranked Grade) ->
 [MJ.Ranked Grade] ->
 Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
 HTML5
html5MeritComments distJ grades commentJG = do
	Loqualization l10n <- liftComposeState $ S.gets state_l10n
	H.ul ! HA.class_ "merit-comments" $$ do
		forM_ grades $ \case
		 grade | DTC.Grade{..} <- MJ.unRank grade -> do
			let commentJ = commentJG >>= HM.lookup grade_name
			let judgesWithComment =
				-- FIXME: sort accents better: « e é f » not « e f é »
				List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
				 [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
				 | (judge, dist) <- HM.toList distJ
				 , importance <- maybeToList $ Map.lookup grade dist ]
			forM_ judgesWithComment $ \(judge, importance, comment) ->
				H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
					H.span
					 ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
					 ! HA.style ("color:"<>attrify grade_color<>";") $$ do
						unless (importance == 1) $ do
							H.span ! HA.class_ "section-importance" $$ do
								let percent =
									(round::Double -> Int) $
									fromRational $ importance * 100
								html5ify $ show percent
								"%"::HTML5
						html5ify judge
					case comment of
					 Nothing -> mempty
					 Just p -> do
						Plain.l10n_Colon l10n :: HTML5
						html5ify p

html5MeritHistogram ::
 Html5ify Title =>
 MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
	H.div ! HA.class_ "merit-histogram" $$ do
		forM_ majVal $ \case
		 (grade, count) | DTC.Grade{..} <- MJ.unRank grade -> do
			let percent :: Double =
				fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
				(count / toRational numJudges) * 100 * 1000) / 1000
			let bcolor  = "background-color:"<>attrify grade_color<>";"
			let width   = "width:"<>attrify percent<>"%;"
			let display = if percent == 0 then "display:none;" else ""
			H.div
			 ! HA.class_ "merit-grade"
			 ! HA.alt (attrify grade_name) -- FIXME: do not work
			 ! HA.style (bcolor<>display<>width) $$ do
				H.div
				 ! HA.class_ "grade-name" $$ do
					case grade_title of
					 Nothing -> html5ify grade_name
					 Just t  -> html5ify t

html5Judgments :: HTML5
html5Judgments = do
	Collect.All{..} <- liftComposeState $ S.gets state_collect
	opinionsByChoiceByNodeBySectionByJudgment <-
		forM (HM.toList all_judgments) $ \(judgment@Judgment{..}, choicesBySection) -> do
			-- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
			-- can safely be used here: 'judgment_judgesId' and 'judgment_gradesId' are ok
			let judgmentGrades =
				maybe (Prelude.error $ show judgment_grades) MJ.grades $ -- unknown grades
				HM.lookup judgment_gradesId all_grades
			let Judges{..} =
				fromMaybe (Prelude.error $ show judgment_judges) $ -- unknown judges
				HM.lookup judgment_judgesId all_judges
			let defaultGradeByJudge =
				let defaultGrade =
					List.head
					 [ g | g <- Set.toList judgmentGrades
					 , grade_isDefault $ MJ.unRank g
					 ] in
				(<$> judges_byName) $ \js ->
					let Judge{..} = List.head js in
					let judgeDefaultGrade = do
						grade <- join $ listToMaybe <$> HM.lookup judgment_gradesId judge_defaultGrades
						listToMaybe
						 [ g | g <- Set.toList judgmentGrades
						 , grade_name (MJ.unRank g) == grade
						 ] in
					defaultGrade`fromMaybe`judgeDefaultGrade
			opinionsByChoiceByNodeBySection <-
				forM choicesBySection $ \choicesTree -> do
					judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
						judgmentOpinions <- forM choices $ \choice_@DTC.Choice{..} -> do
							gradeByJudge <- forM choice_opinions $ \Opinion{..} -> do
								case listToMaybe
									 [ g | g <- Set.toList judgmentGrades
									 , grade_name (MJ.unRank g) == opinion_grade
									 ] of
								 Just grd -> return (opinion_judge, MJ.Section opinion_importance (Just grd))
								 Nothing -> Prelude.error $ show opinion_grade -- unknown grade
							return (choice_, HM.fromList gradeByJudge)
						return $ MJ.SectionNode section_importance $ HM.fromList judgmentOpinions
					let judgmentChoices = HS.fromList $ snd $ Tree.rootLabel choicesTree
					  -- NOTE: choices are determined by those at the root Tree.Node.
					-- NOTE: core Majority Judgment calculus handled here by MJ
					case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
					 Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
					 Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
			-- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
			-- this will match perfectly withw the 'html5ify' traversal:
			-- 'BodySection' by 'BodySection'.
			return (judgment, join $ toList <$> opinionsByChoiceByNodeBySection)
	liftComposeState $ S.modify' $ \st ->
		st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}