packages feed

time 1.2.0.4 → 1.2.0.5

raw patch · 6 files changed

+134/−60 lines, 6 files

Files

Data/Time/Format/Parse.hs view
@@ -55,20 +55,21 @@     -- If the input does not include all the information needed to     -- construct a complete value, any missing parts should be taken     -- from 1970-01-01 00:00:00 +0000 (which was a Thursday).+    -- In the absence of @%C@ or @%Y@, century is 1969 - 2068.     buildTime :: TimeLocale -- ^ The time locale.               -> [(Char,String)] -- ^ Pairs of format characters and the                                   -- corresponding part of the input.               -> t  #if LANGUAGE_Rank2Types--- | Parses a time value given a format string. Supports the same %-codes as--- 'formatTime'. Leading and trailing whitespace is accepted. Case is not--- significant. Some variations in the input are accepted:+-- | Parses a time value given a format string.+-- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers.+-- Leading and trailing whitespace is accepted. Case is not significant.+-- Some variations in the input are accepted: -- -- [@%z@] accepts any of @-HHMM@ or @-HH:MM@. ----- [@%Z@] accepts any string of letters, or any--- of the formats accepted by @%z@.+-- [@%Z@] accepts any string of letters, or any of the formats accepted by @%z@. -- parseTime :: ParseTime t =>              TimeLocale -- ^ Time locale.@@ -104,9 +105,12 @@ -- * Internals -- +data Padding = NoPadding | SpacePadding | ZeroPadding+  deriving Show+ type DateFormat = [DateFormatSpec] -data DateFormatSpec = Value Char+data DateFormatSpec = Value (Maybe Padding) Char                      | WhiteSpace                      | Literal Char   deriving Show@@ -114,31 +118,33 @@ parseFormat :: TimeLocale -> String -> DateFormat parseFormat l = p   where p "" = []-        p ('%': c :cs) = s ++ p cs-            where s = case c of-                        'c' -> p (dateTimeFmt l)-                        'R' -> p "%H:%M"-                        'T' -> p "%H:%M:%S"-                        'X' -> p (timeFmt l)-                        'r' -> p (time12Fmt l)-                        'D' -> p "%m/%d/%y"-                        'F' -> p "%Y-%m-%d"-                        'x' -> p (dateFmt l)-                        'h' -> p "%b"-                        '%' -> [Literal '%']-                        _   -> [Value c]+        p ('%': '-' : c :cs) = (pc (Just NoPadding) c) ++ p cs+        p ('%': '_' : c :cs) = (pc (Just SpacePadding) c) ++ p cs+        p ('%': '0' : c :cs) = (pc (Just ZeroPadding) c) ++ p cs+        p ('%': c :cs) = (pc Nothing c) ++ p cs         p (c:cs) | isSpace c = WhiteSpace : p cs         p (c:cs) = Literal c : p cs+        pc _ 'c' = p (dateTimeFmt l)+        pc _ 'R' = p "%H:%M"+        pc _ 'T' = p "%H:%M:%S"+        pc _ 'X' = p (timeFmt l)+        pc _ 'r' = p (time12Fmt l)+        pc _ 'D' = p "%m/%d/%y"+        pc _ 'F' = p "%Y-%m-%d"+        pc _ 'x' = p (dateFmt l)+        pc _ 'h' = p "%b"+        pc _ '%' = [Literal '%']+        pc mpad c   = [Value mpad c]  parseInput :: TimeLocale -> DateFormat -> ReadP [(Char,String)] parseInput l = liftM catMaybes . mapM p-  where p (Value c)   = parseValue l c >>= return . Just . (,) c+  where p (Value mpad c)   = parseValue l mpad c >>= return . Just . (,) c         p WhiteSpace  = skipSpaces >> return Nothing         p (Literal c) = char c >> return Nothing  -- | Get the string corresponding to the given format specifier.-parseValue :: TimeLocale -> Char -> ReadP String-parseValue l c = +parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String+parseValue l mpad c =      case c of       'z' -> numericTZ       'Z' -> munch1 isAlpha <++@@ -146,40 +152,42 @@              return "" -- produced by %Z for LocalTime       'P' -> oneOf (let (am,pm) = amPm l in [am, pm])       'p' -> oneOf (let (am,pm) = amPm l in [am, pm])-      'H' -> digits 2-      'I' -> digits 2-      'k' -> spdigits 2-      'l' -> spdigits 2-      'M' -> digits 2 -      'S' -> digits 2-      'q' -> digits 12+      'H' -> digits ZeroPadding 2+      'I' -> digits ZeroPadding 2+      'k' -> digits SpacePadding 2+      'l' -> digits SpacePadding 2+      'M' -> digits ZeroPadding 2 +      'S' -> digits ZeroPadding 2+      'q' -> digits ZeroPadding 12       'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return ""       's' -> (char '-' >> liftM ('-':) (munch1 isDigit))               <++ munch1 isDigit-      'Y' -> digits 4-      'y' -> digits 2-      'C' -> digits 2+      'Y' -> digits ZeroPadding 4+      'y' -> digits ZeroPadding 2+      'C' -> digits ZeroPadding 2       'B' -> oneOf (map fst (months l))       'b' -> oneOf (map snd (months l))-      'm' -> digits 2-      'd' -> digits 2-      'e' -> spdigits 2-      'j' -> digits 3-      'G' -> digits 4-      'g' -> digits 2-      'f' -> digits 2-      'V' -> digits 2+      'm' -> digits ZeroPadding 2+      'd' -> digits ZeroPadding 2+      'e' -> digits SpacePadding 2+      'j' -> digits ZeroPadding 3+      'G' -> digits ZeroPadding 4+      'g' -> digits ZeroPadding 2+      'f' -> digits ZeroPadding 2+      'V' -> digits ZeroPadding 2       'u' -> oneOf $ map (:[]) ['1'..'7']       'a' -> oneOf (map snd (wDays l))       'A' -> oneOf (map fst (wDays l))-      'U' -> digits 2+      'U' -> digits ZeroPadding 2       'w' -> oneOf $ map (:[]) ['0'..'6']-      'W' -> digits 2+      'W' -> digits ZeroPadding 2       _   -> fail $ "Unknown format character: " ++ show c   where     oneOf = choice . map string-    digits n = count n (satisfy isDigit)-    spdigits n = skipSpaces >> oneUpTo n (satisfy isDigit)+    digitsforce ZeroPadding n = count n (satisfy isDigit)+    digitsforce SpacePadding n = skipSpaces >> oneUpTo n (satisfy isDigit)+    digitsforce NoPadding n = oneUpTo n (satisfy isDigit)+    digits pad = digitsforce (fromMaybe pad mpad)     oneUpTo :: Int -> ReadP a -> ReadP [a]     oneUpTo 0 _ = pfail     oneUpTo n x = liftM2 (:) x (upTo (n-1) x)@@ -187,9 +195,9 @@     upTo 0 _ = return []     upTo n x = (oneUpTo n x) <++ return []     numericTZ = do s <- choice [char '+', char '-']-                   h <- digits 2+                   h <- digitsforce ZeroPadding 2                    optional (char ':')-                   m <- digits 2+                   m <- digitsforce ZeroPadding 2                    return (s:h++m) #endif @@ -254,8 +262,9 @@        buildDay cs = rest cs         where-        y = let c = safeLast 19 [x | Century x <- cs]+        y = let                  d = safeLast 70 [x | Year x <- cs]+                c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs]              in 100 * c + d          rest (Month m:_)  = let d = safeLast 1 [x | Day x <- cs]
test/Makefile view
@@ -1,5 +1,5 @@ GHC = ghc-GHCFLAGS = -package time+GHCFLAGS = -package time -package QuickCheck-1.2.0.1  default: 	make CurrentTime.run ShowDST.run test@@ -50,7 +50,7 @@ 	date +%z > $@  TestParseTime: TestParseTime.o-	$(GHC) $(GHCFLAGS) -package QuickCheck $^ -o $@+	$(GHC) $(GHCFLAGS) $^ -o $@  test:	\ 	TestMonthDay.diff	\
test/TestFormat.hs view
@@ -131,6 +131,9 @@ class (ParseTime t) => TestParse t where     expectedParse :: String -> String -> Maybe t     expectedParse "%Z" str | all isSpace str = Just (buildTime defaultTimeLocale [])+    expectedParse "%_Z" str | all isSpace str = Just (buildTime defaultTimeLocale [])+    expectedParse "%-Z" str | all isSpace str = Just (buildTime defaultTimeLocale [])+    expectedParse "%0Z" str | all isSpace str = Just (buildTime defaultTimeLocale [])     expectedParse _ _ = Nothing  instance TestParse Day
test/TestParseTime.hs view
@@ -1,8 +1,10 @@ {-# OPTIONS -Wall -Werror -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, ExistentialQuantification #-}  import Control.Monad import Data.Char import Data.Ratio+import Data.Maybe import Data.Time import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate@@ -13,18 +15,79 @@ import Test.QuickCheck.Batch  +class RunTest p where+    runTest :: p -> IO TestResult++instance RunTest (IO TestResult) where+    runTest iob = iob++instance RunTest Property where+    runTest p = run p (TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False})++data ExhaustiveTest = forall t. (Show t) => MkExhaustiveTest [t] (t -> IO Bool)++instance RunTest ExhaustiveTest where+    runTest (MkExhaustiveTest cases f) = do+        results <- mapM (\t -> do {b <- f t;return (b,show t)}) cases+        let failures = mapMaybe (\(b,n) -> if b then Nothing else Just n) results+        let fcount = length failures+        return (if fcount == 0 then TestOk "OK" 0 [] else TestFailed failures fcount)+ ntest :: Int ntest = 1000  main :: IO ()-main = do putStrLn "Should work:"-          good <- checkAll properties-          putStrLn "Known failures:"-          _ <- checkAll knownFailures-          exitWith (if good then ExitSuccess else ExitFailure 1)+main = do+    putStrLn "Should work:"+    good1 <- checkAll extests+    putStrLn "Should work:"+    good2 <- checkAll properties+    putStrLn "Known failures:"+    _ <- checkAll knownFailures+    exitWith (if good1 && good2 then ExitSuccess else ExitFailure 1) +days2011 :: [Day]+days2011 = [(fromGregorian 2011 1 1) .. (fromGregorian 2011 12 31)] -checkAll :: [NamedProperty] -> IO Bool+extests :: [(String,ExhaustiveTest)]+extests = [+    ("parse %y",MkExhaustiveTest [0..99] parseYY),+    ("parse %C %y 1900s",MkExhaustiveTest [0..99] (parseCYY 19)),+    ("parse %C %y 2000s",MkExhaustiveTest [0..99] (parseCYY 20)),+    ("parse %C %y 1400s",MkExhaustiveTest [0..99] (parseCYY 14)),+    ("parse %C %y 700s",MkExhaustiveTest [0..99] (parseCYY 7)),+    ("parse %Y%m%d",MkExhaustiveTest days2011 parseYMD),+    ("parse %Y %m %d",MkExhaustiveTest days2011 parseYearDayD),+    ("parse %Y %-m %e",MkExhaustiveTest days2011 parseYearDayE)+    ]++parseYMD :: Day -> IO Bool+parseYMD day = case toGregorian day of+    (y,m,d) -> return $ (parse "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d))) == Just day++parseYearDayD :: Day -> IO Bool+parseYearDayD day = case toGregorian day of+    (y,m,d) -> return $ (parse "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d))) == Just day++parseYearDayE :: Day -> IO Bool+parseYearDayE day = case toGregorian day of+    (y,m,d) -> return $ (parse "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d))) == Just day++-- | 1969 - 2068+expectedYear :: Integer -> Integer+expectedYear i | i >= 69 = 1900 + i+expectedYear i = 2000 + i++show2 :: (Integral n) => n -> String+show2 i = (show (div i 10)) ++ (show (mod i 10))++parseYY :: Integer -> IO Bool+parseYY i = return (parse "%y" (show2 i) == Just (fromGregorian (expectedYear i) 1 1))++parseCYY :: Integer -> Integer -> IO Bool+parseCYY c i = return (parse "%C %y" ((show2 c) ++ " " ++ (show2 i)) == Just (fromGregorian ((c * 100) + i) 1 1))++checkAll :: RunTest p => [(String,p)] -> IO Bool checkAll ps = fmap and (mapM checkOne ps)  trMessage :: TestResult -> String@@ -37,16 +100,15 @@ trGood (TestOk _ _ _) = True trGood _ = False -checkOne :: NamedProperty -> IO Bool+checkOne :: RunTest p => (String,p) -> IO Bool checkOne (n,p) =     do        putStr (rpad 65 ' ' n)-       tr <- run p options+       tr <- runTest p        putStrLn (trMessage tr)        return (trGood tr)   where     rpad n' c xs = xs ++ replicate (n' - length xs) c-    options = TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False}   parse :: ParseTime t => String -> String -> Maybe t
test/TimeZone.ref view
@@ -1,1 +1,1 @@--0800+-0700
time.cabal view
@@ -1,5 +1,5 @@ name:           time-version:        1.2.0.4+version:        1.2.0.5 stability:      stable license:        BSD3 license-file:   LICENSE