relative-date-0.0.1: tests.hs

{-# LANGUAGE TypeSynonymInstances #-}
module Tests where
import Test.QuickCheck
import Test.QuickCheck.Property as QC
import Text.Parsec.Error
import Control.Monad
import Control.Monad.Reader
import Control.Concatenative
import Text.Parsec.Prim
import Text.Parsec.Pos
import Data.DateTime.Parser
import Data.DateTime

newtype PosInt = PosInt Int deriving (Eq, Show)
instance Arbitrary PosInt where
    arbitrary = liftM PosInt (choose (0,50))

testParser p i = runReader (runPT p () "" i) (US,fromSeconds 1293840000) -- the year I graduate

formatProperty :: DateTime -> [String] -> QC.Result
formatProperty d fs = toResult $ foldl f (Right d) (map (runTestParser expr) $ map (flip formatDateTime d) fs) where
    f (Left a) _ = Left a
    f _ (Left a) = Left a
    f (Right a) (Right b) = if a==b then Right a
        else Left (newErrorMessage (Message ("Formatted parsing inconsistant: " ++ show a ++ " is not " ++ show b)) (initialPos ""), Nothing)
    runTestParser p i = getUTC (testParser p i) where
            getUTC (Right (a:_)) = Right a
            getUTC (Left a) = (Left (a,Just i))
    toResult (Right a) = succeeded
    toResult (Left (a,Just b)) = failed result {QC.reason = show a ++ " parsing string " ++ b }
    toResult (Left (a,Nothing)) = failed result {QC.reason = show a }

formatDateProperty d = formatProperty (fixDate d) ["%A %B %e, %Y", "%B %e, %Y", "%D"] where
    fixDate d = let (y,m,i) = toGregorian' d in fromGregorian' (2000 + (y`mod`100)) m i

formatTimeProperty d = formatProperty (fixTime d) ["%A %B %e, %Y %I:%M %p", "%B %e, %Y %I:%M %p"] where
    fixTime = fromSeconds . bi id (`mod`60) (-) . toSeconds

repeatProperty (PosInt n) =
    case testParser expr ("every day for " ++ (show n) ++ " weeks") of
        (Left _) -> False
        (Right a) -> length a == (n*7+1)

main = do
    mapM quickCheck [formatDateProperty, formatTimeProperty]
    quickCheck repeatProperty