{-
-}
module Main ( main ) where
import Data.Char
import Data.Word
import Data.Maybe ( catMaybes )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Control.Monad.State
import System.Exit
import Data.CaseInsensitive
main = do
success <- flip execStateT True $ do
doTest "all Char Eq" test_AllCharEqChar
doTest "all Word8 Eq" test_AllCharEqWord8
doTest "all Char Eq String" test_AllCharEqString
doTest "all Char using caseInsensitiveMatch" test_AllCharMatchChar
doTest "all Word8 Eq Strict ByteString" test_AllCharEqBS
doTest "all Word8 Eq Lazy ByteString" test_AllCharEqBSL
doTest "unequal String cases" test_NotEqualString
doTest "unequal ByteString cases" test_NotEqualBS
doTest "unequal Lazy ByteString cases" test_NotEqualBSL
doTest "unequal Text cases" test_NotEqualT
doTest "unequal Lazy Text cases" test_NotEqualTL
doTest "equal String cases" test_EqualString
doTest "equal ByteString cases" test_EqualBS
doTest "equal Lazy ByteString cases" test_EqualBSL
doTest "equal Text cases" test_EqualT
doTest "equal Lazy Text cases" test_EqualTL
doTest "equal ByteStrirg tuple" test_EqualTupleBS
doTest "compare all Char EQ" test_CompareAllCharEQChar
doTest "compare all Char8 EQ" test_CompareAllCharEQWord8
doTest "compare all String EQ" test_CompareAllCharEQString
doTest "compare all ByteString EQ" test_CompareAllByteStringEQ
doTest "compare unequal String cases" test_OrderString
doTest "compare unequal ByteString cases" test_OrderByteString
doTest "compare unequal Text cases" test_OrderText
doTest "compare equal String cases" test_CompareEQString
doTest "compare equal ByteString cases" test_CompareEQByteString
doTest "compare equal Text cases" test_CompareEQText
doTest "compare equal ByteString tuple" test_CompareEQTupleBS
doTest "compare unequal ByteString tuple" test_CompareGTTupleBS
if success then exitSuccess else exitFailure
-- | All tests are of the simple pass/fail variety. This is meant
-- at a certain level to emulate QuickCheck.
doTest :: String -> Bool -> StateT Bool IO ()
doTest name test = do
liftIO $ putStr $ take 40 $ concat [ name , ":" , repeat ' ' ]
if test
then do
liftIO $ putStrLn "+++ OK, passed"
else do
liftIO $ putStrLn "--- Failed!"
put False
------------------------------------------------------------------------------
--
-- Testing all character values for each instance.
--
--
-- Test the case-folding behavior of one-at-a-time character matching. A
-- highly technical implementation would not match Unicode Char and String
-- using the same algorithm. The instance for Char is pragmatic enough to pass,
-- but this is a test that the case-insensitive package fails.
test_AllCharEqChar :: Bool
test_AllCharEqChar =
all id
[ all (uncurry caseInsensitiveEq) $ zip all_chars all_chars
, all (uncurry caseInsensitiveEq) $ zip all_chars all_uppers
, all (uncurry caseInsensitiveEq) $ zip all_chars all_lowers
, not $ all_chars == all_uppers -- validating toUpper, actually
, not $ all_chars == all_lowers
]
where
all_chars = [minBound..maxBound] :: [Char]
all_uppers = map toUpper all_chars
all_lowers = map toLower all_chars
test_AllCharEqWord8 :: Bool
test_AllCharEqWord8 =
all id
[ all (uncurry caseInsensitiveEq) $ zip all_chars all_chars
, all (uncurry caseInsensitiveEq) $ zip all_chars all_uppers
, all (uncurry caseInsensitiveEq) $ zip all_chars all_lowers
, not $ all_chars == all_uppers -- validating fold_8 toUpper, actually
, not $ all_chars == all_lowers
]
where
all_chars = [minBound..maxBound] :: [Word8]
all_uppers = map (fold_8 toUpper) all_chars
all_lowers = map (fold_8 toLower) all_chars
test_AllCharMatchChar :: Bool
test_AllCharMatchChar =
all id
[ all_chars `caseInsensitiveMatch` all_chars
, all_chars `caseInsensitiveMatch` all_uppers
, all_chars `caseInsensitiveMatch` all_lowers
, not $ all_chars == all_uppers -- validating map toUpper, actually
, not $ all_chars == all_lowers
]
where
all_chars = [minBound..maxBound] :: [Char]
all_uppers = map toUpper all_chars
all_lowers = map toUpper all_chars
test_AllCharEqString :: Bool
test_AllCharEqString =
all id
[ all_chars `caseInsensitiveEq` all_chars
, all_chars `caseInsensitiveEq` all_uppers
, all_chars `caseInsensitiveEq` all_lowers
, not $ all_chars == all_uppers -- validating map toUpper, actually
, not $ all_chars == all_lowers
]
where
all_chars = [minBound..maxBound] :: [Char]
all_uppers = map toUpper all_chars
all_lowers = map toUpper all_chars
test_AllCharEqBS :: Bool
test_AllCharEqBS =
all id
[ all_chars `caseInsensitiveEq` all_chars
, all_chars `caseInsensitiveEq` all_uppers
, all_chars `caseInsensitiveEq` all_lowers
, not $ all_chars == all_uppers -- validating fold_8 toUpper, actually
, not $ all_chars == all_lowers
]
where
all_chars = BS.pack $ [minBound..maxBound]
all_uppers = BS.map (fold_8 toUpper) all_chars
all_lowers = BS.map (fold_8 toLower) all_chars
test_AllCharEqBSL :: Bool
test_AllCharEqBSL =
all id
[ all_chars `caseInsensitiveEq` all_chars
, all_chars `caseInsensitiveEq` all_uppers
, all_chars `caseInsensitiveEq` all_lowers
, not $ all_chars == all_uppers -- validating fold_8 toUpper, actually
, not $ all_chars == all_lowers
]
where
all_chars = BSL.pack $ [minBound..maxBound]
all_uppers = BSL.map (fold_8 toUpper) all_chars
all_lowers = BSL.map (fold_8 toLower) all_chars
------------------------------------------------------------------------------
--
-- Ord
--
test_CompareAllCharEQChar :: Bool
test_CompareAllCharEQChar =
all id
[ all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_chars
, all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_uppers
, all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_lowers
]
where
all_chars = [minBound..maxBound] :: [Char]
all_uppers = map toUpper all_chars
all_lowers = map toLower all_chars
test_CompareAllCharEQWord8 :: Bool
test_CompareAllCharEQWord8 =
all id
[ all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_chars
, all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_uppers
, all ((==EQ) . uncurry caseInsensitiveCompare) $ zip all_chars all_lowers
]
where
all_chars = [minBound..maxBound] :: [Word8]
all_uppers = map (fold_8 toUpper) all_chars
all_lowers = map (fold_8 toLower) all_chars
test_CompareAllCharEQString :: Bool
test_CompareAllCharEQString =
all id
[ caseInsensitiveCompare all_chars all_chars == EQ
, caseInsensitiveCompare all_chars all_uppers == EQ
, caseInsensitiveCompare all_chars all_lowers == EQ
]
where
all_chars = [minBound..maxBound] :: [Char]
all_uppers = map toUpper all_chars
all_lowers = map toLower all_chars
test_CompareAllByteStringEQ :: Bool
test_CompareAllByteStringEQ =
all id
[ caseInsensitiveCompare all_chars all_chars == EQ
, caseInsensitiveCompare all_chars all_uppers == EQ
, caseInsensitiveCompare all_chars all_lowers == EQ
]
where
all_chars = BS.pack $ [minBound..maxBound]
all_uppers = BS.map (fold_8 toUpper) all_chars
all_lowers = BS.map (fold_8 toLower) all_chars
------------------------------------------------------------------------------
--
-- A few test cases with strings that should not match.
--
neq_cases =
[ (( "apples" , "oranges" ) , LT)
, (( "apples" , "apple" ) , GT)
, (( "123" , "" ) , GT)
, (( "" , "abc" ) , LT)
, (( a_to_z , z_to_a ) , LT)
]
where
a_to_z = ['a'..'z']
z_to_a = reverse a_to_z
neq_pairs = map fst neq_cases
neq_cases_bs = map (\((a,b),c) -> ((BS.pack a,BS.pack b),c)) $ cases_to_word8 neq_cases
neq_pairs_bs = map (\(a,b) -> (BS.pack a ,BS.pack b )) $ pairs_to_word8 neq_pairs
neq_cases_bsl = map (\((a,b),c) -> ((BSL.pack a,BSL.pack b),c)) $ cases_to_word8 neq_cases
neq_pairs_bsl = map (\(a,b) -> (BSL.pack a,BSL.pack b)) $ pairs_to_word8 neq_pairs
neq_cases_t = map (\((a,b),c) -> ((T.pack a,T.pack b),c)) $ neq_cases
neq_pairs_t = map (\(a,b) -> (T.pack a ,T.pack b )) $ neq_pairs
neq_cases_tl = map (\((a,b),c) -> ((TL.pack a,TL.pack b),c)) $ neq_cases
neq_pairs_tl = map (\(a,b) -> (TL.pack a,TL.pack b)) $ neq_pairs
test_NotEqualString :: Bool
test_NotEqualString = all not $ map (uncurry caseInsensitiveEq) neq_pairs
test_NotEqualBS :: Bool
test_NotEqualBS = all not $ map (uncurry caseInsensitiveEq) neq_pairs_bs
test_NotEqualBSL :: Bool
test_NotEqualBSL = all not $ map (uncurry caseInsensitiveEq) neq_pairs_bsl
test_NotEqualT :: Bool
test_NotEqualT = all not $ map (uncurry caseInsensitiveEq) neq_pairs_t
test_NotEqualTL :: Bool
test_NotEqualTL = all not $ map (uncurry caseInsensitiveEq) neq_pairs_tl
test_OrderString :: Bool
test_OrderString = all id $ map (\((a,b),c) -> caseInsensitiveCompare a b == c) neq_cases
test_OrderByteString :: Bool
test_OrderByteString = all id $ map (\((a,b),c) -> caseInsensitiveCompare a b == c) neq_cases_bs
test_OrderText :: Bool
test_OrderText = all id $ map (\((a,b),c) -> caseInsensitiveCompare a b == c) neq_cases_t
------------------------------------------------------------------------------
--
-- A few test cases with strings that should match.
--
case_eq_pairs =
[ ( "apples" , "apples" )
, ( "example.com" , "EXAMPLE.com" )
, ( "HTML" , "html" )
, ( "Content-Type" , "CONTENT-TYPE" )
, ( "C:\\Windows" , "c:\\windows" )
]
case_eq_pairs_bs = map (\(a,b) -> (BS.pack a ,BS.pack b )) $ pairs_to_word8 case_eq_pairs
case_eq_pairs_bsl = map (\(a,b) -> (BSL.pack a,BSL.pack b)) $ pairs_to_word8 case_eq_pairs
case_eq_pairs_t = map (\(a,b) -> (T.pack a ,T.pack b )) $ case_eq_pairs
case_eq_pairs_tl = map (\(a,b) -> (TL.pack a,TL.pack b)) $ case_eq_pairs
test_EqualString :: Bool
test_EqualString = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs
test_EqualBS :: Bool
test_EqualBS = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_bs
test_EqualBSL :: Bool
test_EqualBSL = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_bsl
test_EqualT :: Bool
test_EqualT = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_t
test_EqualTL :: Bool
test_EqualTL = all id $ map (uncurry caseInsensitiveEq) case_eq_pairs_tl
test_CompareEQString :: Bool
test_CompareEQString = all id $ map ((==EQ) . uncurry caseInsensitiveCompare) case_eq_pairs
test_CompareEQByteString :: Bool
test_CompareEQByteString = all id $ map ((==EQ) . uncurry caseInsensitiveCompare) case_eq_pairs_bs
test_CompareEQText :: Bool
test_CompareEQText = all id $ map ((==EQ) . uncurry caseInsensitiveCompare) case_eq_pairs_t
------------------------------------------------------------------------------
--
-- tuple instances - testing all recursively
--
test_EqualTupleBS :: Bool
test_EqualTupleBS =
("apple","oranges","me@example.com","Content-Type")
^==
("APPLE","Oranges","me@EXAMPLE.COM","content-type")
test_CompareEQTupleBS :: Bool
test_CompareEQTupleBS =
( caseInsensitiveCompare
("apple","oranges","me@example.com","Content-Type")
("APPLE","Oranges","me@EXAMPLE.COM","content-type")
) == EQ
test_CompareGTTupleBS :: Bool
test_CompareGTTupleBS =
( caseInsensitiveCompare
("apple","oranges","me@example.com",("Content-Type","text/html"))
("APPLE","Oranges","me@EXAMPLE.COM",("content-language","en-us"))
) == GT
------------------------------------------------------------------------------
--
-- utility functions for creating Word8 strings
--
char_to_word8 :: Char -> Maybe Word8
char_to_word8 c
| fromEnum c > 256 = Nothing
| otherwise = Just $ fromIntegral $ fromEnum c
string_to_word8s :: String -> [Word8]
string_to_word8s = catMaybes . map char_to_word8
cases_to_word8 = map (\((a,b),c) -> ((string_to_word8s a,string_to_word8s b),c))
pairs_to_word8 = map (\(a,b) -> (string_to_word8s a , string_to_word8s b))
-- Some of the lower-256 actually have upper-case outside that range. Here,
-- we treat those as if they didn't have any case at all.
fold_8 :: (Char -> Char) -> Word8 -> Word8
fold_8 f c
| ( fromEnum $ f $ toEnum $ fromIntegral c) > 255 = c
| otherwise = fromIntegral $ fromEnum $ f $ toEnum $ fromIntegral c