1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
module Network.HTTP.Media.Language.Tests (tests) where
import Control.Monad (join)
import qualified Data.ByteString.Char8 as BS
import Data.Monoid ((<>))
import Data.String (fromString)
import Network.HTTP.Media.Accept
import Network.HTTP.Media.Language
import Network.HTTP.Media.Language.Gen
import Network.HTTP.Media.RenderHeader
import Test.QuickCheck ((===))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Prelude hiding ((<>))
tests :: [TestTree]
tests =
[ testEq,
testShow,
testFromString,
testMatches,
testMoreSpecific,
testParseAccept
]
-- Equality is derived, but we test it here to get 100% coverage.
testEq :: TestTree
testEq =
testGroup
"Eq"
[ testProperty "==" $ do
lang <- genLanguage
return $ lang === lang,
testProperty "/=" $ do
lang <- genLanguage
lang' <- genDiffLanguage lang
return $ lang /= lang'
]
testShow :: TestTree
testShow = testProperty "show" $ do
lang <- genLanguage
return $ parseAccept (BS.pack $ show lang) === Just lang
testFromString :: TestTree
testFromString = testProperty "fromString" $ do
lang <- genLanguage
return $ lang === fromString (show lang)
testMatches :: TestTree
testMatches =
testGroup
"matches"
[ testProperty "Equal values match" $
join matches <$> genLanguage,
testProperty "Right prefix matches left" $
uncurry (flip matches) <$> genMatchingLanguages,
testProperty "Left prefix does not match right" $
not . uncurry matches <$> genDiffMatchingLanguages,
testProperty "* matches anything" $
flip matches anything <$> genLanguage,
testProperty "No concrete language matches *" $
not . matches anything <$> genConcreteLanguage
]
testMoreSpecific :: TestTree
testMoreSpecific =
testGroup
"moreSpecificThan"
[ testProperty "Against *" $
flip moreSpecificThan anything <$> genConcreteLanguage,
testProperty "With *" $
not . moreSpecificThan anything <$> genLanguage,
testProperty "Proper prefix lhs" $
not . uncurry moreSpecificThan <$> genDiffMatchingLanguages,
testProperty "Proper prefix rhs" $
uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages,
testProperty "Unrelated languages" $
not . uncurry moreSpecificThan <$> genNonMatchingLanguages
]
testParseAccept :: TestTree
testParseAccept =
testGroup
"parseAccept"
[ testProperty "Valid parse" $ do
lang <- genLanguage
return $ parseAccept (renderHeader lang) === Just lang,
testProperty "Trailing hyphen" $ do
bs <- renderHeader <$> genLanguage
return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing
]
|
