{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Check.Judgment where

import Control.Arrow (second)
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM, forM_, join)
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip)
import Data.Functor ((<$>), (<$))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..), fromMaybe, listToMaybe)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Traversable (Traversable(..))
import Data.Tuple (snd)
import qualified Control.Monad.Trans.State as S
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Hjugement as MJ

import Hdoc.DTC.Document
import Hdoc.DTC.Collect
import Hdoc.DTC.Check.Base
import Control.Monad.Utils

instance Check Title => Check Judges where
	check Judges{..} = do
		let duplicatedJudges = HM.filter ((> 1) . length) judges_byName
		unless (null duplicatedJudges) $ do
			S.modify' $ \s@State{state_errors} -> s
			 { state_errors = state_errors
				 { errors_judgment_judge_duplicated =
					HM.unionWith (flip (<>))
					(Seq.fromList . ((\Judge{..} -> (judge_locTCT, judge_posXML)) <$>) <$> duplicatedJudges) $
					errors_judgment_judge_duplicated state_errors
				 }
			 }
		Judges
		 judges_locTCT
		 judges_posXML
		 judges_attrs
		 <$> traverse (traverse check) judges_byName
instance Check Title => Check [Grade] where
	check = traverse check
instance Check Title => Check Judgment where
	check Judgment{..} = do
		State{state_collect=All{..}} <- S.get
		mayJudges <- do
			case HM.lookup judgment_judgesId all_judges of
			 Just js -> return $ Just js
			 Nothing -> do
				S.modify' $ \s@State{state_errors} -> s
				 { state_errors = state_errors
					 { errors_judgment_judges_unknown =
						HM.insertWith (flip (<>)) judgment_judgesId (pure (judgment_locTCT, judgment_posXML)) $
						errors_judgment_judges_unknown state_errors
					 }
				 }
				return Nothing
		mayGrades <- do
			case HM.lookup judgment_gradesId all_grades of
			 Just gs -> return $ Just $ MJ.grades gs
			 Nothing -> do
				S.modify' $ \s@State{state_errors} -> s
				 { state_errors = state_errors
					 { errors_judgment_grades_unknown =
						HM.insertWith (flip (<>)) judgment_gradesId (pure (judgment_locTCT, judgment_posXML)) $
						errors_judgment_grades_unknown state_errors
					 }
				 }
				return Nothing
		mayOpinionsByChoice  <- getCompose $ do
			Judges{..} <- Compose $ return mayJudges
			grades <- Compose $ return mayGrades
			let defaultGradeByJudge =
				let defaultGrade =
					List.head
					 [ g | g <- Set.toList grades
					 , 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 grades
						 , grade_name (MJ.unRank g) == grade
						 ] in
					defaultGrade`fromMaybe`judgeDefaultGrade
			opinionsByChoice <-
				forM judgment_choices $ \choice@Choice{..} -> do
					gradeByJudge <- forM choice_opinions $ \opinion@Opinion{..} -> do
						let mayGrade = do
							listToMaybe
							 [ MJ.singleGrade g | g <- Set.toList grades
							 , grade_name (MJ.unRank g) == opinion_grade
							 ]
						case mayGrade of
						 Just grd -> Compose $ return $ Just (opinion_judge, (opinion, grd))
						 Nothing -> do
							liftComposeState $ S.modify' $ \s@State{state_errors} -> s
							 { state_errors = state_errors
								 { errors_judgment_grade_unknown =
									HM.insertWith (flip (<>)) opinion_grade (pure (judgment_locTCT, judgment_posXML)) $
									errors_judgment_grade_unknown state_errors
								 }
							 }
							Compose $ return Nothing
					let gradeByJudges = HM.fromListWith (flip (<>)) $ second pure <$> gradeByJudge
					let duplicateJudges = HM.filter ((> 1) . length) gradeByJudges
					unless (null duplicateJudges) (do
						liftComposeState $ S.modify' $ \s@State{state_errors} -> s
						 { state_errors = state_errors
							 { errors_judgment_judge_duplicated =
								HM.unionWith (flip (<>))
								(((\(Opinion{..}, _g) -> (opinion_locTCT, opinion_posXML)) <$>) <$> duplicateJudges) $
								errors_judgment_judge_duplicated state_errors
							 }
						 }
						Compose $ return (Nothing::Maybe ())
					 ) *>
					 case MJ.opinions defaultGradeByJudge $ snd . List.head . toList <$> gradeByJudges of
					 (ok,ko) | null ko   -> Compose $ return $ Just (choice, Seq.singleton (choice, ok))
					         | otherwise -> do
						liftComposeState $ S.modify' $ \s@State{state_errors} -> s
						 { state_errors = state_errors
							 { errors_judgment_judge_unknown =
								HM.unionWith (flip (<>))
								(pure (judgment_locTCT, judgment_posXML) <$ HS.toMap ko) $
								errors_judgment_judge_unknown state_errors
							 }
						 }
						Compose $ return Nothing
			let opinionsByChoices = HM.fromListWith (flip (<>)) opinionsByChoice
			let duplicateChoices = HM.filter ((> 1) . length) opinionsByChoices
			unless (null duplicateChoices) $ do
				liftComposeState $ S.modify' $ \s@State{state_errors} -> s
				 { state_errors = state_errors
					 { errors_judgment_choice_duplicated =
						HM.unionWith (flip (<>))
						(HM.fromList $ (\(choice, os) ->
							( fromMaybe def $ choice_title choice
							, (<$> os) $ \(Choice{..}, _ok) -> (choice_locTCT, choice_posXML)
							)) <$> HM.toList duplicateChoices) $
						errors_judgment_choice_duplicated state_errors
					 }
				 }
				Compose $ return (Nothing::Maybe ())
			Compose $ return $ Just $
				snd . List.head . toList
				 <$> opinionsByChoices
		Judgment mayOpinionsByChoice mayJudges mayGrades
		 judgment_posXML
		 judgment_locTCT
		 judgment_judgesId
		 judgment_gradesId
		 judgment_importance
		 <$> check judgment_question
		 <*> traverse check judgment_choices
instance Check Title => Check Choice where
	check Choice{..} =
		Choice choice_locTCT  choice_posXML
		 <$> check choice_title
		 <*> traverse check choice_opinions
instance Check Title => Check Opinion where
	check Opinion{..} =
		Opinion
		 opinion_locTCT
		 opinion_posXML
		 opinion_judge
		 opinion_grade
		 opinion_importance
		 <$> check opinion_comment
instance Check Title => Check Grade where
	check Grade{..} =
		Grade grade_posXML grade_name grade_color grade_isDefault
		 <$> check grade_title
instance Check Title => Check Judge where
	check Judge{..} = do
		State{state_collect=All{..}} <- S.get
		let duplicatedGrades = HM.filter ((> 1) . length) judge_defaultGrades
		unless (null duplicatedGrades) $ do
			S.modify' $ \s@State{state_errors} -> s
			 { state_errors = state_errors
				 { errors_judgment_grades_duplicated =
					HM.unionWith (flip (<>))
					(Seq.fromList . ((judge_locTCT, judge_posXML) <$) <$> duplicatedGrades) $
					errors_judgment_grades_duplicated state_errors
				 }
			 }
		forM_ (HM.toList judge_defaultGrades) $ \(gradesId,gradeId) ->
			case HM.lookup gradesId all_grades of
			 Just grades -> do
				return ()
			 Nothing -> do
				S.modify' $ \s@State{state_errors} -> s
				 { state_errors = state_errors
					 { errors_judgment_grades_unknown =
						HM.insertWith (flip (<>)) gradesId (pure (judge_locTCT, judge_posXML)) $
						errors_judgment_grades_unknown state_errors
					 }
				 }
		Judge
		 judge_locTCT
		 judge_posXML
		 judge_name
		 <$> check judge_title
		 <*> pure judge_defaultGrades