#43, allow the tests to make use of Maybe functions
[packages/filepath.git] / tests / TestUtil.hs
1
2 module TestUtil(
3 (==>), QFilePath(..), QFilePathValidW(..), QFilePathValidP(..),
4 test, Test,
5 module Test.QuickCheck,
6 module Data.List,
7 module Data.Maybe
8 ) where
9
10 import Test.QuickCheck hiding ((==>))
11 import Data.List
12 import Data.Maybe
13 import Control.Monad
14 import qualified System.FilePath.Windows as W
15 import qualified System.FilePath.Posix as P
16
17 infixr 0 ==>
18 a ==> b = not a || b
19
20
21 newtype QFilePathValidW = QFilePathValidW FilePath deriving Show
22
23 instance Arbitrary QFilePathValidW where
24 arbitrary = fmap (QFilePathValidW . W.makeValid) arbitraryFilePath
25 shrink (QFilePathValidW x) = shrinkValid QFilePathValidW W.makeValid x
26
27 newtype QFilePathValidP = QFilePathValidP FilePath deriving Show
28
29 instance Arbitrary QFilePathValidP where
30 arbitrary = fmap (QFilePathValidP . P.makeValid) arbitraryFilePath
31 shrink (QFilePathValidP x) = shrinkValid QFilePathValidP P.makeValid x
32
33 newtype QFilePath = QFilePath FilePath deriving Show
34
35 instance Arbitrary QFilePath where
36 arbitrary = fmap QFilePath arbitraryFilePath
37 shrink (QFilePath x) = shrinkValid QFilePath id x
38
39
40 -- | Generate an arbitrary FilePath use a few special (interesting) characters.
41 arbitraryFilePath :: Gen FilePath
42 arbitraryFilePath = sized $ \n -> do
43 k <- choose (0,n)
44 replicateM k $ elements "?./:\\a ;_"
45
46 -- | Shrink, but also apply a validity function. Try and make shorter, or use more
47 -- @a@ (since @a@ is pretty dull), but make sure you terminate even after valid.
48 shrinkValid :: (FilePath -> a) -> (FilePath -> FilePath) -> FilePath -> [a]
49 shrinkValid wrap valid o =
50 [ wrap y
51 | y <- map valid $ shrinkList (\x -> ['a' | x /= 'a']) o
52 , length y < length o || (length y == length o && countA y > countA o)]
53 where countA = length . filter (== 'a')
54
55
56 data Test = Test Property Bool
57
58 test :: Testable prop => prop -> Test
59 test prop = Test (property prop) (exhaustive prop)
60
61 instance Testable Test where
62 property (Test x _) = x
63 exhaustive (Test _ x) = x