hjugement-1.0.0.20170804: test/HUnit.hs

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

import Test.Tasty
import Test.Tasty.HUnit

import Control.Arrow (second)
import qualified Data.Map.Strict as Map

import Hjugement
import Types

hunits :: TestTree
hunits =
	testGroup "HUnit"
	 [ testGroup "Value" $
		 [ testCompareValue
			 [(3,15), (2,7), (1,3), (0::Int,2)]
			 [(3,16), (2,6), (1,2), (0,3)]
		 , testGroup "OfMerits"
			 [  let m = mkMerit ['A'..'F'] in
				testValueOfMerits
				 [ (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
				testValueOfMerits
				 [ (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 "OfOpinions"
			 [ testValueOfOpinions [No,Yes]
				   [The]
				 [ [No ]
				 , [No ]
				 , [No ]
				 , [No ]
				 , [Yes]
				 , [Yes]
				 ]
				 [ (The, [(No,4),(Yes,2)])
				 ]
			 , testValueOfOpinions [No,Yes]
				   [The]
				 [ [No ]
				 , [No ]
				 , [No ]
				 , [Yes]
				 , [Yes]
				 , [Yes]
				 ]
				 [ (The, [(No,3),(Yes,3)])
				 ]
			 , testValueOfOpinions [No,Yes]
				   [This, That]
				 [ [No  , No ]
				 , [No  , Yes]
				 , [No  , Yes]
				 , [No  , Yes]
				 , [Yes , Yes]
				 , [Yes , Yes]
				 ]
				 [ (This, [(No,4),(Yes,2)])
				 , (That, [(Yes,5),(No,1)])
				 ]
			 , testValueOfOpinions [No,Yes]
				   [This, That]
				 [ [No  , No ]
				 , [No  , No ]
				 , [No  , No ]
				 , [No  , Yes]
				 , [No  , Yes]
				 , [No  , Yes]
				 ]
				 [ (This, [(No,6),(Yes,0)])
				 , (That, [(No,3),(Yes,3)])
				 ]
			 , testValueOfOpinions [No,Yes]
				   [This, That]
				 [ [Yes , No ]
				 , [Yes , No ]
				 , [Yes , No ]
				 , [Yes , Yes]
				 , [Yes , Yes]
				 , [Yes , Yes]
				 ]
				 [ (This, [(Yes,6),(No,0)])
				 , (That, [(No,3),(Yes,3)])
				 ]
			 , testValueOfOpinions [No,Yes]
				   [This, That]
				 [ [No  , No ]
				 , [No  , No ]
				 , [Yes , No ]
				 , [Yes , Yes]
				 , [Yes , Yes]
				 , [Yes , Yes]
				 ]
				 [ (This, [(Yes,4),(No,2)])
				 , (That, [(No,3),(Yes,3)])
				 ]
			 , testValueOfOpinions [ToReject,Insufficient,Acceptable,Good,VeryGood,Perfect]
				   [1::Int ..6]
				 [ [Perfect,Perfect,Acceptable,VeryGood,Good,VeryGood]
				 , [Perfect,VeryGood,Perfect,Good,Acceptable,Acceptable]
				 , [VeryGood,VeryGood,Good,Acceptable,VeryGood,Insufficient]
				 , [Perfect,VeryGood,VeryGood,Good,Good,Acceptable]
				 , [Perfect,Good,VeryGood,Good,Good,Acceptable]
				 , [Perfect,VeryGood,Perfect,Good,Good,Good]
				 ]
				 [ (1, [(Perfect,5),(VeryGood,1),(ToReject,0),(Insufficient,0),(Acceptable,0),(Good,0)])
				 , (2, [(VeryGood,4),(Good,1),(Perfect,1),(ToReject,0),(Insufficient,0),(Acceptable,0)])
				 , (3, [(VeryGood,2),(Good,1),(Perfect,2),(Acceptable,1),(ToReject,0),(Insufficient,0)])
				 , (4, [(Good,4),(Acceptable,1),(VeryGood,1),(ToReject,0),(Insufficient,0),(Perfect,0)])
				 , (5, [(Good,4),(Acceptable,1),(VeryGood,1),(ToReject,0),(Insufficient,0),(Perfect,0)])
				 , (6, [(Acceptable,3),(Good,1),(Insufficient,1),(VeryGood,1),(ToReject,0),(Perfect,0)])
				 ]
			 ]
		 ]
	 ]


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

mkOpinion :: Ord prop =>
             Choices prop -> judge -> [grade] ->
             (judge, Opinion prop grade)
mkOpinion props j gs = (j, Map.fromList $ toList props `zip` gs)

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

mkMerits :: (Ord prop, Ord grade) =>
            [grade] -> Choices prop -> [[grade]] ->
            Merits prop grade
mkMerits scal props opins =
	merits (Scale (fromList scal) (head scal)) props $ fromList $
	zipWith (mkOpinion props) [1::Int ..] opins


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

testRanking :: (Ord prop, Ord grade, Show grade, Show prop) =>
               [grade] -> Choices prop -> [[grade]] ->
               Ranking prop -> TestTree
testRanking scal props opins expect =
	testCase (elide $ show (toList props,opins)) $
		majorityRanking (mkMerits scal props opins) @?= expect

testValueOfOpinions :: (Show grade, Show prop, Ord grade, Ord prop) =>
             [grade] -> Choices prop -> [[grade]] ->
             [(prop, [(grade,Count)])] -> TestTree
testValueOfOpinions scal props opins expect =
	testCase (elide $ show (toList props,opins)) $
		majorityValueByChoice (mkMerits scal props opins)
		 @?= ((Value`second`)<$>expect)

testValueOfMerits :: (Show grade, Show prop, Ord grade, Ord prop) =>
             Merits prop grade ->
             [(prop, [(grade,Count)])] -> TestTree
testValueOfMerits ms expect =
	testCase (elide $ show ms) $
		majorityValueByChoice ms
		 @?= ((Value`second`)<$>expect)