1{-# LANGUAGE ScopedTypeVariables #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-} -- In the test suite, so OK
3
4module Main(main) where
5
6import Safe
7import Safe.Exact
8import qualified Safe.Foldable as F
9
10import Control.DeepSeq
11import Control.Exception
12import Control.Monad
13import Data.Char
14import Data.List
15import Data.Maybe
16import System.IO.Unsafe
17import Test.QuickCheck.Test
18import Test.QuickCheck hiding ((===))
19
20
21---------------------------------------------------------------------
22-- TESTS
23
24main :: IO ()
25main = do
26    -- All from the docs, so check they match
27    tailMay dNil === Nothing
28    tailMay [1,3,4] === Just [3,4]
29    tailDef [12] [] === [12]
30    tailDef [12] [1,3,4] === [3,4]
31    tailNote "help me" dNil `err` "Safe.tailNote [], help me"
32    tailNote "help me" [1,3,4] === [3,4]
33    tailSafe [] === dNil
34    tailSafe [1,3,4] === [3,4]
35
36    findJust (== 2) [d1,2,3] === 2
37    findJust (== 4) [d1,2,3] `err` "Safe.findJust"
38    F.findJust (== 2) [d1,2,3] === 2
39    F.findJust (== 4) [d1,2,3] `err` "Safe.Foldable.findJust"
40    F.findJustDef 20 (== 4) [d1,2,3] === 20
41    F.findJustNote "my note" (== 4) [d1,2,3] `errs` ["Safe.Foldable.findJustNote","my note"]
42
43    takeExact 3 [d1,2] `errs` ["Safe.Exact.takeExact","index=3","length=2"]
44    takeExact (-1) [d1,2] `errs` ["Safe.Exact.takeExact","negative","index=-1"]
45    takeExact 1 (takeExact 3 [d1,2]) === [1] -- test is lazy
46
47    quickCheck_ $ \(Int10 i) (List10 (xs :: [Int])) -> do
48        let (t,d) = splitAt i xs
49        let good = length t == i
50        let f name exact may note res =
51                if good then do
52                    exact i xs === res
53                    note "foo" i xs === res
54                    may i xs === Just res
55                else do
56                    exact i xs `err` ("Safe.Exact." ++ name ++ "Exact")
57                    note "foo" i xs `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
58                    may i xs === Nothing
59        f "take" takeExact takeExactMay takeExactNote t
60        f "drop" dropExact dropExactMay dropExactNote d
61        f "splitAt" splitAtExact splitAtExactMay splitAtExactNote (t, d)
62        return True
63
64    take 2 (zipExact [1,2,3] [1,2]) === [(1,1),(2,2)]
65    zipExact [d1,2,3] [d1,2] `errs` ["Safe.Exact.zipExact","first list is longer than the second"]
66    zipExact [d1,2] [d1,2,3] `errs` ["Safe.Exact.zipExact","second list is longer than the first"]
67    zipExact dNil dNil === []
68
69    predMay (minBound :: Int) === Nothing
70    succMay (maxBound :: Int) === Nothing
71    predMay ((minBound + 1) :: Int) === Just minBound
72    succMay ((maxBound - 1) :: Int) === Just maxBound
73
74    quickCheck_ $ \(List10 (xs :: [Int])) x -> do
75        let ys = maybeToList x ++ xs
76        let res = zip xs ys
77        let f name exact may note =
78                if isNothing x then do
79                    exact xs ys === res
80                    note "foo" xs ys === res
81                    may xs ys === Just res
82                else do
83                    exact xs ys `err` ("Safe.Exact." ++ name ++ "Exact")
84                    note "foo" xs ys `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
85                    may xs ys === Nothing
86        f "zip" zipExact zipExactMay zipExactNote
87        f "zipWith" (zipWithExact (,)) (zipWithExactMay (,)) (`zipWithExactNote` (,))
88        return True
89
90    take 2 (zip3Exact [1,2,3] [1,2,3] [1,2]) === [(1,1,1),(2,2,2)]
91    zip3Exact [d1,2] [d1,2,3] [d1,2,3] `errs` ["Safe.Exact.zip3Exact","first list is shorter than the others"]
92    zip3Exact [d1,2,3] [d1,2] [d1,2,3] `errs` ["Safe.Exact.zip3Exact","second list is shorter than the others"]
93    zip3Exact [d1,2,3] [d1,2,3] [d1,2] `errs` ["Safe.Exact.zip3Exact","third list is shorter than the others"]
94    zip3Exact dNil dNil dNil === []
95
96    quickCheck_ $ \(List10 (xs :: [Int])) x1 x2 -> do
97        let ys = maybeToList x1 ++ xs
98        let zs = maybeToList x2 ++ xs
99        let res = zip3 xs ys zs
100        let f name exact may note =
101                if isNothing x1 && isNothing x2 then do
102                    exact xs ys zs === res
103                    note "foo" xs ys zs === res
104                    may xs ys zs === Just res
105                else do
106                    exact xs ys zs `err` ("Safe.Exact." ++ name ++ "Exact")
107                    note "foo" xs ys zs `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
108                    may xs ys zs === Nothing
109        f "zip3" zip3Exact zip3ExactMay zip3ExactNote
110        f "zipWith3" (zipWith3Exact (,,)) (zipWith3ExactMay (,,)) (flip zipWith3ExactNote (,,))
111        return True
112
113
114---------------------------------------------------------------------
115-- UTILITIES
116
117quickCheck_ prop = do
118    r <- quickCheckResult prop
119    unless (isSuccess r) $ error "Test failed"
120
121
122d1 = 1 :: Double
123dNil = [] :: [Double]
124
125(===) :: (Show a, Eq a) => a -> a -> IO ()
126(===) a b = when (a /= b) $ error $ "Mismatch: " ++ show a ++ " /= " ++ show b
127
128err :: NFData a => a -> String -> IO ()
129err a b = errs a [b]
130
131errs :: NFData a => a -> [String] -> IO ()
132errs a bs = do
133    res <- try $ evaluate $ rnf a
134    case res of
135        Right v -> error $ "Expected error, but succeeded: " ++ show bs
136        Left (msg :: SomeException) -> forM_ bs $ \b -> do
137            let s = show msg
138            unless (b `isInfixOf` s) $ error $ "Invalid error string, got " ++ show s ++ ", want " ++ show b
139            let f xs = " " ++ map (\x -> if sepChar x then ' ' else x) xs ++ " "
140            unless (f b `isInfixOf` f s) $ error $ "Not standalone error string, got " ++ show s ++ ", want " ++ show b
141
142sepChar x = isSpace x || x `elem` ",;."
143
144newtype Int10 = Int10 Int deriving Show
145
146instance Arbitrary Int10 where
147    arbitrary = fmap Int10 $ choose (-3, 10)
148
149newtype List10 a = List10 [a] deriving Show
150
151instance Arbitrary a => Arbitrary (List10 a) where
152    arbitrary = do i <- choose (0, 10); fmap List10 $ vector i
153
154instance Testable a => Testable (IO a) where
155    property = property . unsafePerformIO
156