tests/Properties.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-}
   2 module Properties (main) where
   3 import Network.MPD.Utils
   4
   5 import Control.Monad
   6 import Data.Char
   7 import Data.List
   8 import Data.Maybe
   9 import System.Environment
  10 import Text.Printf
  11 import Test.QuickCheck
  12
  13 main :: IO ()
  14 main = do
  15     n <- (maybe 100 read . listToMaybe) `liftM` getArgs
  16     mapM_ (\(s, f) -> printf "%-25s : " s >> f n) tests
  17     where tests = [("splitGroups / reversible",
  18                         mytest prop_splitGroups_rev)
  19                   ,("splitGroups / integrity",
  20                         mytest prop_splitGroups_integrity)
  21                   ,("parseBool", mytest prop_parseBool)
  22                   ,("parseBool / reversible",
  23                         mytest prop_parseBool_rev)
  24                   ,("showBool", mytest prop_showBool)
  25                   ,("toAssoc / reversible",
  26                         mytest prop_toAssoc_rev)
  27                   ,("toAssoc / integrity",
  28                         mytest prop_toAssoc_integrity)
  29                   ,("parseNum", mytest prop_parseNum)
  30                   ,("parseDate / simple",
  31                         mytest prop_parseDate_simple)
  32                   ,("parseDate / complex",
  33                         mytest prop_parseDate_complex)]
  34
  35 mytest :: Testable a => a -> Int -> IO ()
  36 mytest a n = check defaultConfig { configMaxTest = n } a
  37
  38 instance Arbitrary Char where
  39     arbitrary     = choose ('\0', '\128')
  40
  41 -- an assoc. string is a string of the form "key: value".
  42 newtype AssocString = AS String
  43     deriving Show
  44
  45 instance Arbitrary AssocString where
  46     arbitrary = do
  47         key <- arbitrary
  48         val <- arbitrary
  49         return . AS $ key ++ ": " ++ val
  50
  51 newtype IntegralString = IS String
  52     deriving Show
  53
  54 instance Arbitrary IntegralString where
  55     arbitrary = fmap (IS . show) (arbitrary :: Gen Integer)
  56
  57 newtype BoolString = BS String
  58     deriving Show
  59
  60 instance Arbitrary BoolString where
  61     arbitrary = fmap BS $ oneof [return "1", return "0"]
  62
  63 -- Positive integers.
  64 newtype PosInt = PI Integer
  65
  66 instance Show PosInt where
  67     show (PI x) = show x
  68
  69 instance Arbitrary PosInt where
  70     arbitrary = (PI . abs) `fmap` arbitrary
  71
  72 -- Simple date representation, like "2004" and "1998".
  73 newtype SimpleDateString = SDS String
  74     deriving Show
  75
  76 instance Arbitrary SimpleDateString where
  77     arbitrary = fmap (SDS . concatMap show) .
  78                 replicateM 4 . oneof $ map return [0..9]
  79
  80 -- Complex date representations, like "2004-20-30".
  81 newtype ComplexDateString = CDS String
  82     deriving Show
  83
  84 instance Arbitrary ComplexDateString where
  85     arbitrary = do
  86         -- eww...
  87         y <- replicateM 4 . oneof $ map return [0..9]
  88         let (m, d) = splitAt 2 y
  89         return . CDS . intercalate "-" $ map (concatMap show) [y, m, d]
  90
  91 prop_parseDate_simple :: SimpleDateString -> Bool
  92 prop_parseDate_simple (SDS x) = isJust $ parseDate x
  93
  94 prop_parseDate_complex :: ComplexDateString -> Bool
  95 prop_parseDate_complex (CDS x) = isJust $ parseDate x
  96
  97 prop_toAssoc_rev :: [AssocString] -> Bool
  98 prop_toAssoc_rev x = toAssoc (fromAssoc r) == r
  99     where r = toAssoc (fromAS x)
 100           fromAssoc = map (\(a, b) -> a ++ ": " ++ b)
 101
 102 prop_toAssoc_integrity :: [AssocString] -> Bool
 103 prop_toAssoc_integrity x = length (toAssoc $ fromAS x) == length x
 104
 105 fromAS :: [AssocString] -> [String]
 106 fromAS s = [x | AS x <- s]
 107
 108 prop_parseBool_rev :: BoolString -> Bool
 109 prop_parseBool_rev (BS x) = showBool (fromJust $ parseBool x) == x
 110
 111 prop_parseBool :: BoolString -> Bool
 112 prop_parseBool (BS "1") = fromJust $ parseBool "1"
 113 prop_parseBool (BS x)   = not (fromJust $ parseBool x)
 114
 115 prop_showBool :: Bool -> Bool
 116 prop_showBool True = showBool True == "1"
 117 prop_showBool x    = showBool x == "0"
 118
 119 prop_splitGroups_rev :: [(String, String)] -> Bool
 120 prop_splitGroups_rev xs =
 121     let r = splitGroups xs in r == splitGroups (concat r)
 122
 123 prop_splitGroups_integrity :: [(String, String)] -> Bool
 124 prop_splitGroups_integrity xs = sort (concat $ splitGroups xs) == sort xs
 125
 126 prop_parseNum :: IntegralString -> Bool
 127 prop_parseNum (IS xs@"")      = parseNum xs == Nothing
 128 prop_parseNum (IS xs@('-':_)) = fromMaybe 0 (parseNum xs) <= 0
 129 prop_parseNum (IS xs)         = fromMaybe 0 (parseNum xs) >= 0