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