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

import Control.Arrow ((&&&))
import Control.Monad (Monad(..), (=<<), forM, forM_, join)
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), any, concat)
import Data.Function (($), (.), id, const, on)
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.Sequence (Seq)
import Data.String (String)
import Data.Tuple (fst)
import Prelude ((*), Fractional(..), Double, toRational, RealFrac(..), undefined)
import Text.Blaze ((!))
import Text.Show (Show(..))
import Data.TreeSeq.Strict (Tree(..))
import qualified Control.Monad.Trans.Writer.Strict as W
import qualified Control.Monad.Trans.RWS.Strict as RWS
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.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text.Lazy as TL
import qualified Data.Tree as Tree
import qualified Data.TreeSeq.Strict as TS
import qualified Majority.Judgment as MJ
import qualified Prelude (error)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA

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

-- import qualified Textphile.TCT.Debug as Debug

-- <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)
{-
debug0 :: Debug.Pretty a => String -> a -> a
debug0 m a = Debug.trace (m <> ": " <> Debug.runPretty 2 a) a
instance Debug.Pretty JudgmentKey
instance Debug.Pretty Choice
instance Debug.Pretty Name
instance Debug.Pretty Grade
instance (Debug.Pretty a, Show a) => Debug.Pretty (MJ.Ranked a)
-}

-- </debug>

instance Html5ify Title => Html5ify Judgment where
 html5ify Judgment{..} = do
	composeLift $ RWS.tell def
	 { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
	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 merit       = meritC HM.!choice_
						let distByJudge = distByJudgeByChoice HM.!choice_
						let numJudges   = HM.size distByJudge
						html5MeritHistogram merit numJudges
						let grades    = Map.keys $ MJ.unMerit $ merit
						let commentJG = HM.lookup choice_ commentJGC
						html5MeritComments distByJudge grades commentJG
instance Html5ify Judges where
	html5ify Judges{..} =
		html5CommonAttrs judges_attrs
		 { attrs_classes = "judges":attrs_classes judges_attrs
		 , attrs_id      = Just $ identify $ XML.pos_ancestors judges_posXML
		 } $
		H.div $$ do
			mempty

judgmentKey :: Judgment -> JudgmentKey
judgmentKey Judgment{..} =
	JudgmentKey
	 { judgmentKey_judgesId = judgment_judgesId
	 , judgmentKey_gradesId = judgment_gradesId
	 , judgmentKey_question = judgment_question
	 }

-- | Create a mapping from what makes 'Judgment's equal
-- to what their particular used content is.
judgmentByKey :: [Judgment] -> HM.HashMap JudgmentKey Judgment
judgmentByKey js =
	HM.fromList $ (<$> js) $ \j@Judgment{..} -> (judgmentKey j,j)

-- | Collect in a 'Tree' the 'Judgment's of the given 'Body'.
judgmentByKeyBySection :: Body ->
 W.Writer (Analyze.Errors (Seq Location))
          (TS.Trees (HM.HashMap JudgmentKey Judgment))
judgmentByKeyBySection body =
	(join <$>) $ forM body $ \(Tree b bs) -> do
		judgmentKS <- judgmentByKeyBySection bs
		case b of
		 BodyBlock{} -> return mempty
		 BodySection Section{section_about=About{..}, ..} ->
			-- forM_ about_judgments $ \j@Judgment{..} ->
			-- 	
			return $ Seq.singleton $ Tree sectionJudgments $
				if hasJudgeableBlocks bs
				then Tree blocksJudgments Seq.empty Seq.<| judgmentKS
					-- NOTE: Add a judgments inheriting the 'opinion_grade' of these 'judgments'.
					--       This enables judges to express something on material not in a child 'BodySection'.
				else judgmentKS
			where
			judgments = judgmentByKey about_judgments
			-- NOTE: On the parent section, any 'opinion_default' overrides 'opinion_grade',
			-- so that the children sections will inherit it in 'MJ.opinionsBySection'.
			sectionJudgments =
				(<$> judgments) $ \j@Judgment{..} ->
				j{judgment_choices = (<$> judgment_choices) $ \c@Choice{..} ->
					c{choice_opinions = (<$> choice_opinions) $ \o@Opinion{..} ->
						o{opinion_grade = opinion_grade`fromMaybe`opinion_default}
					 }
				 }
			-- NOTE: On the (children) blocks, 'opinion_default' is not used.
			blocksJudgments = (<$> judgments) $ \j@Judgment{..} ->
				j{judgment_choices = (<$> judgment_choices) $ \c@Choice{..} ->
					c{choice_opinions = (<$> choice_opinions) $ \o@Opinion{..} ->
						o{opinion_default = Nothing}
					 }
				 }

-- | Return 'True' iif. the 'BodySection' has at least
-- a 'BodySection' and a judgeable 'BodyBlock' as children.
hasJudgeableBlocks :: Body -> Bool
hasJudgeableBlocks bs =
	(\case {Tree BodySection{} _ -> True; _ -> False} `any` bs) &&
	(\case {Tree (BodyBlock blk) _ -> hasJudgeableBlock blk; _ -> False} `any` bs)
	where
	hasJudgeableBlock = \case
	 BlockAside{}      -> True
	 BlockFigure{}     -> True
	 BlockPara p       -> case p of
		 ParaItem{..}  -> hasJudgeablePara item
		 ParaItems{..} -> hasJudgeablePara`any`items
	 BlockBreak{}      -> False
	 BlockGrades{}     -> False
	 BlockIndex{}      -> False
	 BlockJudges{}     -> False
	 BlockReferences{} -> False
	 BlockToC{}        -> False
	 BlockToF{}        -> False
	hasJudgeablePara = \case
	 ParaComment{} -> False
	 _ -> True

-- | Group by 'Judgment' the result of 'judgmentByKeyBySection'.
judgmentBySectionByKey :: -- TODO: see if this can be done using Reader and collect
 HM.HashMap JudgmentKey [Tree.Tree Judgment] ->
 TS.Tree (HM.HashMap JudgmentKey Judgment) ->
 HM.HashMap JudgmentKey [Tree.Tree Judgment]
 {-
 W.Writer (Analyze.Errors (Seq Location))
          (HM.HashMap JudgmentKey [Tree.Tree Judgment])
 -}
judgmentBySectionByKey inh (TS.Tree selfJ childrenJS) =
	HM.unionWith
	 (\selfS childrenS ->
		(<$> selfS) $ \(Tree.Node choices old) ->
			Tree.Node choices (old<>childrenS))
	 (selfSJ <> inh)
	 childrenSJ
	where
	selfSJ = (\js -> [Tree.Node js []]) <$> selfJ
	childrenSJ =
		foldl'
		 (\accJ childJ ->
			HM.unionWith (<>) accJ $
			judgmentBySectionByKey
			 (([Tree.Node def []] <$ selfJ) <> inh)
			childJ)
		 HM.empty
		 childrenJS

analyseJudgments :: Document -> HTML5
analyseJudgments Document{..} = do
	let judgmentKS =
		fst $ W.runWriter $
		judgmentByKeyBySection $
		case document_head of
		 Nothing -> document_body
		 Just Head{..} ->
			Seq.singleton $
			TS.Tree (DTC.BodySection head_section) $
			head_body <> document_body
	let judgmentSK =
		judgmentBySectionByKey HM.empty $
		TS.Tree HM.empty judgmentKS
	Analyze.All{..} <- composeLift $ RWS.asks reader_all
	opinionsByChoiceByNodeBySectionByJudgment <-
		forM (HM.toList judgmentSK) $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
			let judgmentGrades =
				maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
				-- FIXME: report correctly
				listToMaybe $ toList $
				HM.lookupDefault def judgmentKey_gradesId all_grades
			let Judges{..} =
				fromMaybe (Prelude.error $ show judgmentKey_judgesId) $
				-- FIXME: report correctly
				listToMaybe $ toList $
				HM.lookupDefault def judgmentKey_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 <- listToMaybe =<< HM.lookup judgmentKey_gradesId judge_defaultGrades
						listToMaybe
						 [ g | g <- Set.toList judgmentGrades
						 , grade_name (MJ.unRank g) == grade
						 ] in
					defaultGrade`fromMaybe`judgeDefaultGrade
			opinionsByChoiceByNodeBySection <-
				forM judgmentsBySection $ \judgmentsTree -> do
					judgmentTree <- forM judgmentsTree $ \Judgment{judgment_importance, judgment_choices} -> do
						judgmentOpinions <- forM judgment_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
									 { MJ.sectionShare = opinion_importance
									 , MJ.sectionGrade = Just grd
									 }
								 Nothing -> Prelude.error $ show opinion_grade -- FIXME: report correctly
							return (choice, HM.fromList gradeByJudge)
						return $ MJ.SectionNode judgment_importance $ HM.fromList judgmentOpinions
					let judgmentChoices = HS.fromList $ judgment_choices $ Tree.rootLabel judgmentsTree
					  -- 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
						-- FIXME: report correctly
			-- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
			-- this will match perfectly with the 'html5ify' traversal:
			-- 'BodySection' by 'BodySection'.
			return (judgmentK, toList =<< opinionsByChoiceByNodeBySection)
	composeLift $ RWS.modify $ \st ->
		st{state_judgments = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}

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 <- composeLift $ RWS.asks reader_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.Merit (MJ.Ranked Grade) -> Int -> HTML5
html5MeritHistogram (MJ.Merit merit) numJudges = do
	H.div ! HA.class_ "merit-histogram" $$ do
		forM_ (Map.toList merit) $ \case
		 (grade, share) | DTC.Grade{..} <- MJ.unRank grade -> do
			let percent :: Double =
				fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
				(share / 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

html5SectionJudgments :: Html5ify Title => HTML5
html5SectionJudgments = do
	st <- composeLift RWS.get
	Reader{reader_section, reader_body} <- composeLift RWS.ask
	let sectionJudgments =
		-- NOTE: merge inherited judgments with those of this section,
		-- while preserving their appearing order.
		List.nubBy ((==) `on` judgmentKey) $
		concat $
		about_judgments . section_about <$> reader_section
	let opinsBySectionByJudgment =
		-- NOTE: gather opinions of the judgments of this section.
		state_judgments st `HM.intersection`
		HM.fromList ((judgmentKey &&& id) <$> sectionJudgments)
	let dropChildrenBlocksJudgments =
		-- NOTE: drop the 'phantomJudgment' concerning the 'BodyBlock's
		-- directly children of this 'BodySection'.
		if hasJudgeableBlocks reader_body
		then List.tail
		else id
	composeLift $ RWS.modify $ \s ->
		s{ state_judgments =
			-- NOTE: drop current opinions of the judgments of this section.
			HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
			 (state_judgments s)
			 opinsBySectionByJudgment
		 }
	unless (null opinsBySectionByJudgment) $ do
		let judgmentK = judgmentByKey sectionJudgments
		composeLift $ RWS.tell def
		 { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
		let isDocumentHead =
			case reader_section of
			 _:_:_ -> False
			 _ -> True
		(if isDocumentHead then id else ((H.aside ! HA.class_ "aside") $$)) $
			forM_ sectionJudgments $ \judgment -> do
				-- NOTE: preserve the wanted order
				let key = judgmentKey judgment
				let opinsBySection = opinsBySectionByJudgment HM.!key
				H.div ! HA.class_
				 ("judgment section-judgment"<>
				 if isDocumentHead then " document-judgment" else "") $$ do
					html5ify judgment
					 { judgment_opinionsByChoice = listToMaybe opinsBySection
					 , judgment_choices = maybe [] judgment_choices $ HM.lookup key judgmentK
					 }

stateJudgments ::
 Analyze.All -> Document ->
 ( HM.HashMap JudgmentKey [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
 , Analyze.Errors (Seq Location)
 )
stateJudgments Analyze.All{..} Document{..} =
	W.runWriter $ do
		judgmentKS <-
			judgmentByKeyBySection $
			case document_head of
			 Nothing -> document_body
			 Just Head{..} ->
				Seq.singleton $
				TS.Tree (DTC.BodySection head_section) $
				head_body <> document_body
		let judgmentSK =
			judgmentBySectionByKey HM.empty $
			TS.Tree HM.empty judgmentKS
		W.tell def
		(HM.fromList <$>)
		 $ forM (HM.toList judgmentSK)
		 $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
			{-
			judgmentGrades <-
				maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
				-- FIXME: report correctly
				listToMaybe $ toList $
				case HM.lookup judgmentKey_gradesId all_grades of
				 Nothing -> W.tell def{errors_judgment_grades_unknown = }
			-}
			undefined
	{-
	opinionsByChoiceByNodeBySectionByJudgment <-
		forM (HM.toList judgmentSK) $ \(judgmentK@JudgmentKey{..}, judgmentsBySection) -> do
			let judgmentGrades =
				maybe (Prelude.error $ show judgmentKey_gradesId) MJ.grades $
				-- FIXME: report correctly
				listToMaybe $ toList $
				HM.lookupDefault def judgmentKey_gradesId all_grades
			let Judges{..} =
				fromMaybe (Prelude.error $ show judgmentKey_judgesId) $
				-- FIXME: report correctly
				listToMaybe $ toList $
				HM.lookupDefault def judgmentKey_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 <- listToMaybe =<< HM.lookup judgmentKey_gradesId judge_defaultGrades
						listToMaybe
						 [ g | g <- Set.toList judgmentGrades
						 , grade_name (MJ.unRank g) == grade
						 ] in
					defaultGrade`fromMaybe`judgeDefaultGrade
	MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree
	-}