{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HUnit where

import Test.Tasty
import Test.Tasty.HUnit

import Control.Arrow (second)
import Data.Hashable (Hashable)
import Data.Ratio ((%))
import Data.Tree (Tree(..))
import GHC.Exts (IsList(..))
import Prelude
import qualified Data.HashMap.Strict as HM

import Hjugement
import Types

hunits :: TestTree
hunits =
	testGroup "HUnit"
	 [ testGroup "MajorityValue" $
		 [ testCompareValue
			 [(3,15), (2,7), (1,3), (0::Int,2)]
			 [(3,16), (2,6), (1,2), (0,3)]
		 , testGroup "Merit"
			 [  let m = mkMerit ['A'..'F'] in
				testMajorityValueOfMerits
				 [ (The, m [136,307,251,148,84,74])
				 ]
				 [ (The, [('C',251),('B',307),('D',148),('E',84),('A',136),('F',74)])
				 ]
			 , let m = mkMerit [ToReject .. TooGood] in
				testMajorityValueOfMerits
				 [ (This, m [12,10,21,5,5,5,2])
				 , (That, m [12,16,22,3,3,3,1])
				 ]
				 [ (This, [(Acceptable,21),(Insufficient,10),(Good,5),(ToReject,12),(Perfect,5),(VeryGood,5),(TooGood,2)])
				 , (That, [(Acceptable,22),(Insufficient,16),(ToReject,12),(VeryGood,3),(Perfect,3),(Good,3),(TooGood,1)])
				 ]
			 ]
		 , testGroup "MajorityRanking"
			 [ testMajorityValueOfOpinions
				 [ (The, [No,No,No,No,Yes,Yes]) ]
				 [ (The, [(No,4),(Yes,2)]) ]
			 , testMajorityValueOfOpinions
				 [ (The, [No,No,No,Yes,Yes,Yes]) ]
				 [ (The, [(No,3),(Yes,3)]) ]
			 , testMajorityValueOfOpinions
				 [ (This, [No,No,No,No,Yes,Yes])
				 , (That, [No,Yes,Yes,Yes,Yes,Yes])
				 ]
				 [ (This, [(No,4),(Yes,2)])
				 , (That, [(Yes,5),(No,1)])
				 ]
			 , testMajorityValueOfOpinions
				 [ (This, [No,No,No,No,No,No])
				 , (That, [No,No,No,Yes,Yes,Yes])
				 ]
				 [ (This, [(No,6)])
				 , (That, [(No,3),(Yes,3)])
				 ]
			 , testMajorityValueOfOpinions
				 [ (This, [Yes,Yes,Yes,Yes,Yes,Yes])
				 , (That, [No,No,No,Yes,Yes,Yes])
				 ]
				 [ (This, [(Yes,6)])
				 , (That, [(No,3),(Yes,3)])
				 ]
			 , testMajorityValueOfOpinions
				 [ (This, [No,No,Yes,Yes,Yes,Yes])
				 , (That, [No,No,No,Yes,Yes,Yes])
				 ]
				 [ (This, [(Yes,4),(No,2)])
				 , (That, [(No,3),(Yes,3)])
				 ]
			 , testMajorityValueOfOpinions
				 [ (1::Int, [Perfect,Perfect,VeryGood,Perfect,Perfect,Perfect])
				 , (2, [Perfect,VeryGood,VeryGood,VeryGood,Good,VeryGood])
				 , (3, [Acceptable,Perfect,Good,VeryGood,VeryGood,Perfect])
				 , (4, [VeryGood,Good,Acceptable,Good,Good,Good])
				 , (5, [Good,Acceptable,VeryGood,Good,Good,Good])
				 , (6, [VeryGood,Acceptable,Insufficient,Acceptable,Acceptable,Good])
				 ]
				 [ (1, [(Perfect,5),(VeryGood,1)])
				 , (2, [(VeryGood,4),(Good,1),(Perfect,1)])
				 , (3, [(VeryGood,2),(Good,1),(Perfect,2),(Acceptable,1)])
				 , (4, [(Good,4),(Acceptable,1),(VeryGood,1)])
				 , (5, [(Good,4),(Acceptable,1),(VeryGood,1)])
				 , (6, [(Acceptable,3),(Good,1),(Insufficient,1),(VeryGood,1)])
				 ]
			 ]
		 , testGroup "Section"
			 [ testSection "1 judge, default grade"
				 [(1::Int,ToReject)]
				 (node0 [(1,SectionOpinion Nothing Nothing)])
				 (Right $ node0 [(1,[(ToReject,1%1)])])
			 {-
			 , testSection "2 judges, default grade"
				 [(1::Int,ToReject), (2::Int,ToReject)]
				 (node0
					 [ (1,SectionOpinion Nothing Nothing)
					 ])
				 (Right $ node0
					 [ (1,[(ToReject,1%1)])
					 , (2,[(ToReject,1%1)])
					 ])
			 , testSection "ErrorSection_unknown_judges"
				 [(1::Int,ToReject)]
				 (node0 [(2,SectionOpinion Nothing Nothing)])
				 (Left $ ErrorSection_unknown_judges [2])
			 , testSection "1 judge, 1 grade"
				 [(1::Int,ToReject)]
				 (node0 [(1,SectionOpinion Nothing (Just Acceptable))])
				 (Right $ Node [(1,[(Acceptable,1%1)])] [])
			 , testSection "1 judge, 1 grade, 2 sections"
				 [(1::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable)) ]
					 [ node0 [(1,SectionOpinion (Just $ 1%2) Nothing)]
					 , node0 [(1,SectionOpinion (Just $ 1%2) Nothing)]
					 ])
				 (Right $ Node
					 [ (1,[(Acceptable,1%1)]) ]
					 [ node0 [(1,[(Acceptable,1%1)])]
					 , node0 [(1,[(Acceptable,1%1)])]
					 ])
			 , testSection "1 judge, 2 grades, 2 sections"
				 [(1::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable)) ]
					 [ node0 [(1,SectionOpinion (Just $ 1%2) Nothing)]
					 , node0 [(1,SectionOpinion (Just $ 1%2) (Just Good))]
					 ])
				 (Right $ Node
					 [(1,[(Acceptable,1%2), (Good,1%2)])]
					 [ node0 [(1,[(Acceptable,1%1)])]
					 , node0 [(1,[(Good,1%1)])]
					 ])
			 , testSection "1 judge, 2 grades, 2 sections (1 default)"
				 [(1::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable)) ]
					 [ node0 [(1,SectionOpinion Nothing Nothing)]
					 , node0 [(1,SectionOpinion (Just $ 1%2) (Just Good))]
					 ])
				 (Right $ Node
					 [(1,[(Acceptable,1%2), (Good,1%2)])]
					 [ node0 [(1,[(Acceptable,1%1)])]
					 , node0 [(1,[(Good,1%1)])]
					 ])
			 , testSection "1 judge, 3 grades, 3 sections (2 default)"
				 [(1::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable)) ]
					 [ node0 [(1,SectionOpinion Nothing Nothing)]
					 , node0 [(1,SectionOpinion (Just $ 1%2) (Just Good))]
					 , node0 [(1,SectionOpinion Nothing (Just VeryGood))]
					 ])
				 (Right $ Node
					 [(1,[(Acceptable,1%4), (Good,1%2), (VeryGood,1%4)])]
					 [ node0 [(1,[(Acceptable,1%1)])]
					 , node0 [(1,[(Good,1%1)])]
					 , node0 [(1,[(VeryGood,1%1)])]
					 ])
			 , testSection "ErrorSection_invalid_shares sum not 1"
				 [(1::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable)) ]
					 [ node0 [(1,SectionOpinion (Just $ 1%2) Nothing)]
					 , node0 [(1,SectionOpinion (Just $ 1%3) (Just Good))]
					 ])
				 (Left $ ErrorSection_invalid_shares [(1,[1%2,1%3])])
			 , testSection "ErrorSection_invalid_shares negative share"
				 [(1::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable)) ]
					 [ node0 [(1,SectionOpinion (Just $ 1%2) Nothing)]
					 , node0 [(1,SectionOpinion (Just $ -1%2) (Just Good))]
					 ])
				 (Left $ ErrorSection_invalid_shares [(1,[1%2,-1%2])])
			 -}
			 , testSection "2 judges, 3 grade, 3 sections (1 default)"
				 [(1::Int,ToReject), (2::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable))
					 ]
					 [ node0
						 [ (1,SectionOpinion Nothing Nothing)
						 ]
					 , node0
						 [ (1,SectionOpinion (Just $ 1%2) (Just Good))
						 ]
					 ])
				 (Right $ Node
					 [ (1,[(Acceptable,1%2), (Good,1%2)])
					 , (2,[(ToReject,1%1)])
					 ]
					 [ node0
						 [ (1,[(Acceptable,1%1)])
						 , (2,[(ToReject,1%1)])
						 ]
					 , node0
						 [ (1,[(Good,1%1)])
						 , (2,[(ToReject,1%1)])
						 ]
					 ])
			 , testSection "2 judges, 3 grades, 5 sections (2 defaults)"
				 [(1::Int,ToReject), (2::Int,ToReject)]
				 (Node
					 [ (1,SectionOpinion Nothing (Just Acceptable))
					 ]
					 [ node0
						 [ (1,SectionOpinion Nothing Nothing)
						 ]
					 , node0
						 [ (1,SectionOpinion (Just $ 1%2) (Just Good))
						 ]
					 , Node
						 [ (1,SectionOpinion Nothing (Just Good))
						 ]
						 [ node0
							 [ (1,SectionOpinion Nothing (Just VeryGood))
							 , (2,SectionOpinion Nothing (Just Insufficient))
							 ]
						 ]
					 ])
				 (Right $ Node
					 [ (1,[(Acceptable,1%4), (Good,1%2), (VeryGood,1%4)])
					 , (2,[(ToReject,2%3), (Insufficient,1%3)])
					 ]
					 [ node0
						 [ (1,[(Acceptable,1%1)])
						 , (2,[(ToReject,1%1)])
						 ]
					 , node0
						 [ (1,[(Good,1%1)])
						 , (2,[(ToReject,1%1)])
						 ]
					 , Node
						 [ (1,[(VeryGood,1%1)])
						 , (2,[(Insufficient,1%1)])
						 ]
						 [ node0
							 [ (1,[(VeryGood,1%1)])
							 , (2,[(Insufficient,1%1)])
							 ]
						 ]
					 ])
			 ]
		 ]
	 ]

elide :: String -> String
elide s | length s > 42 = take 42 s ++ ['…']
        | otherwise = s

mkMerit :: (Ord grade, Show grade) => [grade] -> [Share] -> Merit grade
mkMerit gs = fromList . (gs`zip`)

mkMeritByChoice ::
 (Eq choice, Hashable choice, Ord grade) =>
 [(choice,[grade])] ->
 MeritByChoice choice grade
mkMeritByChoice os =
	meritByChoice $ fromList $
	second (fromList . zip [1::Int ..] . (singleGrade <$>)) <$> os

testCompareValue :: (Ord grade, Show grade) =>
                    [(grade, Share)] -> [(grade, Share)] -> TestTree
testCompareValue x y =
	testGroup (elide $ show (x,y))
	 [ testCase "x == x" $ MajorityValue x`compare`MajorityValue x @?= EQ
	 , testCase "y == y" $ MajorityValue y`compare`MajorityValue y @?= EQ
	 , testCase "x <  y" $ MajorityValue x`compare`MajorityValue y @?= LT
	 , testCase "y >  x" $ MajorityValue y`compare`MajorityValue x @?= GT
	 ]

testMajorityRanking ::
 (Eq choice, Hashable choice, Ord grade, Show grade, Show choice) =>
 [(choice, [grade])] ->
 MajorityRanking choice grade -> TestTree
testMajorityRanking os expect =
	testCase (elide $ show os) $
		majorityRanking (mkMeritByChoice os) @?= expect

testMajorityValueOfOpinions ::
 (Show grade, Show choice, Ord grade, Eq choice, Hashable choice) =>
 [(choice, [grade])] ->
 [(choice, [(grade,Share)])] -> TestTree
testMajorityValueOfOpinions os expect =
	testCase (elide $ show os) $
		majorityValueByChoice (mkMeritByChoice os)
		 @?= (MajorityValue<$>HM.fromList expect)

testMajorityValueOfMerits ::
 (Show grade, Show choice, Ord grade, Eq choice, Hashable choice) =>
 MeritByChoice choice grade ->
 [(choice, [(grade,Share)])] -> TestTree
testMajorityValueOfMerits ms expect =
	testCase (elide $ show ms) $
		majorityValueByChoice ms
		 @?= (MajorityValue<$>HM.fromList expect)


testSection ::
 Eq judge =>
 Hashable judge =>
 Ord grade =>
 Show grade =>
 Show judge =>
 String ->
 Judges judge grade ->
 Tree (Section judge grade) ->
 Either (ErrorSection judge)
        (Tree (Opinions judge grade)) ->
 TestTree
testSection msg js ss expect =
	testCase (elide msg) $
		opinionsBySection js ss @?= expect

node0 :: a -> Tree a
node0 = (`Node`[])