safe-0.3.21: Test.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- In the test suite, so OK

module Main(main) where

import Safe
import Safe.Exact
import qualified Safe.Foldable as F

import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import System.IO.Unsafe
import Test.QuickCheck.Test
import Test.QuickCheck hiding ((===))


---------------------------------------------------------------------
-- TESTS

main :: IO ()
main = do
    -- All from the docs, so check they match
    tailMay dNil === Nothing
    tailMay [1,3,4] === Just [3,4]
    tailDef [12] [] === [12]
    tailDef [12] [1,3,4] === [3,4]
    tailNote "help me" dNil `err` "Safe.tailNote [], help me"
    tailNote "help me" [1,3,4] === [3,4]
    tailSafe [] === dNil
    tailSafe [1,3,4] === [3,4]

    findJust (== 2) [d1,2,3] === 2
    findJust (== 4) [d1,2,3] `err` "Safe.findJust"
    F.findJust (== 2) [d1,2,3] === 2
    F.findJust (== 4) [d1,2,3] `err` "Safe.Foldable.findJust"
    F.findJustDef 20 (== 4) [d1,2,3] === 20
    F.findJustNote "my note" (== 4) [d1,2,3] `errs` ["Safe.Foldable.findJustNote","my note"]

    takeExact 3 [d1,2] `errs` ["Safe.Exact.takeExact","index=3","length=2"]
    takeExact (-1) [d1,2] `errs` ["Safe.Exact.takeExact","negative","index=-1"]
    takeExact 1 (takeExact 3 [d1,2]) === [1] -- test is lazy

    quickCheck_ $ \(Int10 i) (List10 (xs :: [Int])) -> do
        let (t,d) = splitAt i xs
        let good = length t == i
        let f name exact may note res =
                if good then do
                    exact i xs === res
                    note "foo" i xs === res
                    may i xs === Just res
                else do
                    exact i xs `err` ("Safe.Exact." ++ name ++ "Exact")
                    note "foo" i xs `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
                    may i xs === Nothing
        f "take" takeExact takeExactMay takeExactNote t
        f "drop" dropExact dropExactMay dropExactNote d
        f "splitAt" splitAtExact splitAtExactMay splitAtExactNote (t, d)
        return True

    take 2 (zipExact [1,2,3] [1,2]) === [(1,1),(2,2)]
    zipExact [d1,2,3] [d1,2] `errs` ["Safe.Exact.zipExact","first list is longer than the second"]
    zipExact [d1,2] [d1,2,3] `errs` ["Safe.Exact.zipExact","second list is longer than the first"]
    zipExact dNil dNil === []

    predMay (minBound :: Int) === Nothing
    succMay (maxBound :: Int) === Nothing
    predMay ((minBound + 1) :: Int) === Just minBound
    succMay ((maxBound - 1) :: Int) === Just maxBound

    quickCheck_ $ \(List10 (xs :: [Int])) x -> do
        let ys = maybeToList x ++ xs
        let res = zip xs ys
        let f name exact may note =
                if isNothing x then do
                    exact xs ys === res
                    note "foo" xs ys === res
                    may xs ys === Just res
                else do
                    exact xs ys `err` ("Safe.Exact." ++ name ++ "Exact")
                    note "foo" xs ys `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
                    may xs ys === Nothing
        f "zip" zipExact zipExactMay zipExactNote
        f "zipWith" (zipWithExact (,)) (zipWithExactMay (,)) (`zipWithExactNote` (,))
        return True

    take 2 (zip3Exact [1,2,3] [1,2,3] [1,2]) === [(1,1,1),(2,2,2)]
    zip3Exact [d1,2] [d1,2,3] [d1,2,3] `errs` ["Safe.Exact.zip3Exact","first list is shorter than the others"]
    zip3Exact [d1,2,3] [d1,2] [d1,2,3] `errs` ["Safe.Exact.zip3Exact","second list is shorter than the others"]
    zip3Exact [d1,2,3] [d1,2,3] [d1,2] `errs` ["Safe.Exact.zip3Exact","third list is shorter than the others"]
    zip3Exact dNil dNil dNil === []

    quickCheck_ $ \(List10 (xs :: [Int])) x1 x2 -> do
        let ys = maybeToList x1 ++ xs
        let zs = maybeToList x2 ++ xs
        let res = zip3 xs ys zs
        let f name exact may note =
                if isNothing x1 && isNothing x2 then do
                    exact xs ys zs === res
                    note "foo" xs ys zs === res
                    may xs ys zs === Just res
                else do
                    exact xs ys zs `err` ("Safe.Exact." ++ name ++ "Exact")
                    note "foo" xs ys zs `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
                    may xs ys zs === Nothing
        f "zip3" zip3Exact zip3ExactMay zip3ExactNote
        f "zipWith3" (zipWith3Exact (,,)) (zipWith3ExactMay (,,)) (flip zipWith3ExactNote (,,))
        return True


---------------------------------------------------------------------
-- UTILITIES

quickCheck_ prop = do
    r <- quickCheckResult prop
    unless (isSuccess r) $ error "Test failed"


d1 = 1 :: Double
dNil = [] :: [Double]

(===) :: (Show a, Eq a) => a -> a -> IO ()
(===) a b = when (a /= b) $ error $ "Mismatch: " ++ show a ++ " /= " ++ show b

err :: NFData a => a -> String -> IO ()
err a b = errs a [b]

errs :: NFData a => a -> [String] -> IO ()
errs a bs = do
    res <- try $ evaluate $ rnf a
    case res of
        Right v -> error $ "Expected error, but succeeded: " ++ show bs
        Left (msg :: SomeException) -> forM_ bs $ \b -> do
            let s = show msg
            unless (b `isInfixOf` s) $ error $ "Invalid error string, got " ++ show s ++ ", want " ++ show b
            let f xs = " " ++ map (\x -> if sepChar x then ' ' else x) xs ++ " "
            unless (f b `isInfixOf` f s) $ error $ "Not standalone error string, got " ++ show s ++ ", want " ++ show b

sepChar x = isSpace x || x `elem` ",;."

newtype Int10 = Int10 Int deriving Show

instance Arbitrary Int10 where
    arbitrary = fmap Int10 $ choose (-3, 10)

newtype List10 a = List10 [a] deriving Show

instance Arbitrary a => Arbitrary (List10 a) where
    arbitrary = do i <- choose (0, 10); fmap List10 $ vector i

instance Testable a => Testable (IO a) where
    property = property . unsafePerformIO