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