1-- File created: 2008-10-10 22:03:00 2 3module Tests.Base ( PString(unPS), Path(unP), COpts(unCOpts) 4 , (-->), fromRight, isRight 5 ) where 6 7import System.FilePath (extSeparator, pathSeparators) 8import Test.QuickCheck 9 10import System.FilePath.Glob.Base (CompOptions(..)) 11 12newtype PString = PatString { unPS :: String } deriving Show 13newtype Path = Path { unP :: String } deriving Show 14newtype COpts = COpts { unCOpts :: CompOptions } deriving Show 15 16alpha0, alpha :: String 17alpha0 = extSeparator : "-^!" ++ ['a'..'z'] ++ ['0'..'9'] 18alpha = pathSeparators ++ alpha0 19 20instance Arbitrary PString where 21 arbitrary = sized $ \size -> do 22 let xs = 23 (1, return "**/") : 24 map (\(a,b) -> (a*100,b)) 25 [ (40, plain alpha) 26 , (20, return "?") 27 , (20, charRange) 28 , (10, return "*") 29 , (10, openRange) 30 ] 31 32 s <- mapM (const $ frequency xs) [1..size] 33 return.PatString $ concat s 34 35 shrink (PatString s) = map PatString (shrink s) 36 37instance Arbitrary Path where 38 arbitrary = sized $ \size -> do 39 s <- mapM (const $ plain alpha) [1..size `mod` 16] 40 return.Path $ concat s 41 42 shrink (Path s) = map Path (shrink s) 43 44instance Arbitrary COpts where 45 arbitrary = do 46 (a,b,c,d,e,f) <- arbitrary 47 return.COpts $ CompOptions a b c d e f False 48 49 50plain :: String -> Gen String 51plain from = sized $ \size -> mapM (const $ elements from) [0..size `mod` 3] 52 53charRange :: Gen String 54charRange = do 55 s <- plain alpha0 56 if s `elem` ["^","!"] 57 then do 58 s' <- plain alpha0 59 return$ "[" ++ s ++ s' ++ "]" 60 else 61 return$ "[" ++ s ++ "]" 62 63openRange :: Gen String 64openRange = do 65 probA <- choose (0,1) :: Gen Float 66 probB <- choose (0,1) :: Gen Float 67 a <- if probA > 0.4 68 then fmap (Just .abs) arbitrary 69 else return Nothing 70 b <- if probB > 0.4 71 then fmap (Just .abs) arbitrary 72 else return Nothing 73 return.concat $ 74 [ "<" 75 , maybe "" show (a :: Maybe Int) 76 , "-" 77 , maybe "" show (b :: Maybe Int) 78 , ">" 79 ] 80 81-- Not in Data.Either until base-4.7 (GHC 7.8) 82isRight :: Either a b -> Bool 83isRight (Right _) = True 84isRight _ = False 85 86fromRight :: Either a b -> b 87fromRight (Right x) = x 88fromRight _ = error "fromRight :: Left" 89 90(-->) :: Bool -> Bool -> Bool 91a --> b = not a || b 92