{-# LANGUAGE FlexibleInstances #-}
module Hdoc.DTC.Analyze.Check where

import Control.Arrow ((&&&))
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($))
import Data.Functor (Functor(..), (<$>))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.Tuple (fst)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM

import Hdoc.DTC.Document
import Hdoc.DTC.Analyze.Collect

-- ** Type 'Errors'
data Errors a = Errors
 { errors_at_unknown                 :: HM.HashMap Ident  a
 , errors_at_ambiguous               :: HM.HashMap Ident  a
 , errors_ref_unknown                :: HM.HashMap Ident  a
 , errors_reference_ambiguous        :: HM.HashMap Ident  a
 , errors_judgment_judges_unknown    :: HM.HashMap Ident  a
 , errors_judgment_grades_unknown    :: HM.HashMap Ident  a
 , errors_judgment_grades_duplicated :: HM.HashMap Ident  a
 , errors_judgment_grade_duplicated  :: HM.HashMap Ident  a
 , errors_judgment_judge_unknown     :: HM.HashMap Name   a
 , errors_judgment_judge_duplicated  :: HM.HashMap Name   a
 , errors_judgment_grade_unknown     :: HM.HashMap Name   a
 , errors_judgment_choice_duplicated :: HM.HashMap Title  a
 } deriving (Eq,Show)
instance Default (Errors a) where
	def = Errors
	 { errors_at_unknown                 = def
	 , errors_at_ambiguous               = def
	 , errors_ref_unknown                = def
	 , errors_reference_ambiguous        = def
	 , errors_judgment_judges_unknown    = def
	 , errors_judgment_judge_unknown     = def
	 , errors_judgment_judge_duplicated  = def
	 , errors_judgment_grades_unknown    = def
	 , errors_judgment_grades_duplicated = def
	 , errors_judgment_grade_duplicated  = def
	 , errors_judgment_grade_unknown     = def
	 , errors_judgment_choice_duplicated = def
	 }
instance Semigroup a => Semigroup (Errors a) where
	x<>y = Errors
	 { errors_at_unknown                 = hm_union errors_at_unknown
	 , errors_at_ambiguous               = hm_union errors_at_ambiguous
	 , errors_ref_unknown                = hm_union errors_ref_unknown
	 , errors_reference_ambiguous        = hm_union errors_reference_ambiguous
	 , errors_judgment_judges_unknown    = hm_union errors_judgment_judges_unknown
	 , errors_judgment_judge_unknown     = hm_union errors_judgment_judge_unknown
	 , errors_judgment_judge_duplicated  = hm_union errors_judgment_judge_duplicated
	 , errors_judgment_grades_unknown    = hm_union errors_judgment_grades_unknown
	 , errors_judgment_grades_duplicated = hm_union errors_judgment_grades_duplicated
	 , errors_judgment_grade_duplicated  = hm_union errors_judgment_grade_duplicated
	 , errors_judgment_grade_unknown     = hm_union errors_judgment_grade_unknown
	 , errors_judgment_choice_duplicated = hm_union errors_judgment_choice_duplicated
	 } where hm_union get = HM.unionWith (<>) (get x) (get y)
instance Semigroup a => Monoid (Errors a) where
	mempty  = def
	mappend = (<>)
instance Functor Errors where
	fmap f Errors{..} = Errors
	 { errors_at_unknown                 = fmap f errors_at_unknown
	 , errors_at_ambiguous               = fmap f errors_at_ambiguous
	 , errors_ref_unknown                = fmap f errors_ref_unknown
	 , errors_reference_ambiguous        = fmap f errors_reference_ambiguous
	 , errors_judgment_judges_unknown    = fmap f errors_judgment_judges_unknown
	 , errors_judgment_judge_unknown     = fmap f errors_judgment_judge_unknown
	 , errors_judgment_judge_duplicated  = fmap f errors_judgment_judge_duplicated
	 , errors_judgment_grades_unknown    = fmap f errors_judgment_grades_unknown
	 , errors_judgment_grades_duplicated = fmap f errors_judgment_grades_duplicated
	 , errors_judgment_grade_duplicated  = fmap f errors_judgment_grade_duplicated
	 , errors_judgment_grade_unknown     = fmap f errors_judgment_grade_unknown
	 , errors_judgment_choice_duplicated = fmap f errors_judgment_choice_duplicated
	 }

errors :: All -> Errors (Seq Location)
errors All{..} =
	def -- FIXME: Errors
	 { errors_at_unknown =
		(fst <$>) <$>
		HM.difference all_at all_section
	 , errors_at_ambiguous =
		HM.intersection ((fst <$>) <$> all_at) $
		HM.filter (\x -> length x > 1) all_section
	 , errors_ref_unknown =
		(fst <$>) <$>
		HM.difference all_ref all_reference
	 , errors_reference_ambiguous =
		((&&&) reference_locTCT reference_posXML <$>)
		 <$> HM.filter (\x -> length x > 1) all_reference
	 {-
	 , errors_judgment_judges_unknown =
	 , errors_judgment_judge_unknown =
	 , errors_judgment_judge_duplicated =
	 , errors_judgment_grades_unknown =
	 , errors_judgment_grades_duplicated =
	 , errors_judgment_grade_duplicated =
	 , errors_judgment_grade_unknown =
	 , errors_judgment_choice_duplicated =
	 -}
	 }