1-- File created: 2009-01-30 15:01:02
2
3{-# LANGUAGE CPP #-}
4
5module Tests.Instances (tests) where
6
7-- Monoid is re-exported from Prelude as of 4.8.0.0
8#if !MIN_VERSION_base(4,8,0)
9import Data.Monoid (mempty, mappend)
10#endif
11import Test.Framework
12import Test.Framework.Providers.QuickCheck2
13import Test.QuickCheck (Property, (==>))
14
15import System.FilePath.Glob.Base (Token(Unmatchable), tryCompileWith, unPattern)
16
17import Tests.Base
18
19tests :: Test
20tests = testGroup "Instances"
21   [ testProperty "monoid-law-1" prop_monoidLaw1
22   , testProperty "monoid-law-2" prop_monoidLaw2
23   , testProperty "monoid-law-3" prop_monoidLaw3
24   , testProperty "monoid-4"     prop_monoid4
25   ]
26
27-- The monoid laws: associativity...
28prop_monoidLaw1 :: COpts -> PString -> PString -> PString -> Property
29prop_monoidLaw1 opt x y z =
30   let o       = unCOpts opt
31       es      = map (tryCompileWith o . unPS) [x,y,z]
32       [a,b,c] = map fromRight es
33    in all isRight es ==> mappend a (mappend b c) == mappend (mappend a b) c
34
35-- ... left identity ...
36prop_monoidLaw2 :: COpts -> PString -> Property
37prop_monoidLaw2 opt x =
38   let o = unCOpts opt
39       e = tryCompileWith o (unPS x)
40       a = fromRight e
41    in isRight e ==> mappend mempty a == a
42
43-- ... and right identity.
44prop_monoidLaw3 :: COpts -> PString -> Property
45prop_monoidLaw3 opt x =
46   let o = unCOpts opt
47       e = tryCompileWith o (unPS x)
48       a = fromRight e
49    in isRight e ==> mappend a mempty == a
50
51-- mappending two Patterns should be equivalent to appending the original
52-- strings they came from and compiling that
53--
54-- (notice: relies on the fact that our Arbitrary instance doesn't generate
55-- unclosed [] or <>; we only check for **/ and Unmatchable)
56prop_monoid4 :: COpts -> PString -> PString -> Property
57prop_monoid4 opt x y =
58   let o     = unCOpts opt
59       es    = map (tryCompileWith o . unPS) [x,y]
60       [a,b] = map fromRight es
61       cat1  = mappend a b
62       cat2  = tryCompileWith o (unPS x ++ unPS y)
63       last2 = take 2 . reverse . unPS $ x
64       head2 = take 2 . unPS $ y
65    in     (last2 /= "**" && take 1 head2 /= "/")
66        && (take 1 last2 /= "*" && take 2 head2 /= "*/")
67        && all isRight es && isRight cat2
68        && take 1 (unPattern b) /= [Unmatchable]
69       ==> cat1 == fromRight cat2
70