hide members of FormatTime and ParseTime classes;
authorAshley Yakeley <ashley@semantic.org>
Thu, 18 Jan 2018 22:54:18 +0000 (14:54 -0800)
committerAshley Yakeley <ashley@semantic.org>
Thu, 18 Jan 2018 22:54:18 +0000 (14:54 -0800)
parsing for diff types (#22)

changelog.md
lib/Data/Time/Format.hs
lib/Data/Time/Format/Format/Class.hs [new file with mode: 0644]
lib/Data/Time/Format/Format/Instances.hs [new file with mode: 0644]
lib/Data/Time/Format/Parse.hs
lib/Data/Time/Format/Parse/Class.hs [new file with mode: 0644]
lib/Data/Time/Format/Parse/Instances.hs [new file with mode: 0644]
test/main/Test/Format/Format.hs
test/main/Test/Format/ParseTime.hs
time.cabal

index f835027..eb813ab 100644 (file)
@@ -5,7 +5,8 @@
 - new DayOfWeek type
 - new CalendarDiffDays and CalendarDiffTime types
 - new addLocalTime, diffLocalTime
-- formatting: diff types (NominalDiffTime, DiffTime, CalendarDiffDays, CalendarDiffTime)
+- hide members of FormatTime and ParseTime classes
+- formatting & parsing for diff types (NominalDiffTime, DiffTime, CalendarDiffDays, CalendarDiffTime)
 - formatting: %Ez and %EZ for ±HH:MM format
 - parseTimeM: use MonadFail constraint when supported
 - parsing: reject invalid (and empty) time-zones with %z and %Z
index af9e582..88f9f9e 100644 (file)
+{-# OPTIONS -fno-warn-orphans #-}
 module Data.Time.Format
     (
     -- * UNIX-style formatting
-    NumericPadOption,FormatTime(..),formatTime,
+    FormatTime(),formatTime,
     module Data.Time.Format.Parse
     ) where
-
-import Data.Maybe
-import Data.Char
-import Data.Fixed
-
-import Data.Time.Clock.Internal.DiffTime
-import Data.Time.Clock.Internal.NominalDiffTime
-import Data.Time.Clock.Internal.UniversalTime
-import Data.Time.Clock.Internal.UTCTime
-import Data.Time.Clock.POSIX
-import Data.Time.Calendar.Days
-import Data.Time.Calendar.CalendarDiffDays
-import Data.Time.Calendar.Gregorian
-import Data.Time.Calendar.Week
-import Data.Time.Calendar.WeekDate
-import Data.Time.Calendar.OrdinalDate
-import Data.Time.Calendar.Private
-import Data.Time.LocalTime.Internal.CalendarDiffTime
-import Data.Time.LocalTime.Internal.TimeZone
-import Data.Time.LocalTime.Internal.TimeOfDay
-import Data.Time.LocalTime.Internal.LocalTime
-import Data.Time.LocalTime.Internal.ZonedTime
+import Data.Time.Format.Format.Class
+import Data.Time.Format.Format.Instances()
 import Data.Time.Format.Parse
-
-
-type NumericPadOption = Maybe Char
-
--- the weird UNIX logic is here
-getPadOption :: Bool -> Bool -> Int -> Char -> Maybe NumericPadOption -> Maybe Int -> PadOption
-getPadOption trunc fdef idef cdef mnpad mi = let
-    c = case mnpad of
-        Just (Just c') -> c'
-        Just Nothing -> ' '
-        _ -> cdef
-    i = case mi of
-        Just i' -> case mnpad of
-            Just Nothing -> i'
-            _ -> if trunc then i' else max i' idef
-        Nothing -> idef
-    f = case mi of
-        Just _ -> True
-        Nothing -> case mnpad of
-            Nothing -> fdef
-            Just Nothing -> False
-            Just (Just _) -> True
-    in if f then Pad i c else NoPad
-
-data FormatOptions = MkFormatOptions {
-    foLocale :: TimeLocale,
-    foPadding :: Maybe NumericPadOption,
-    foWidth :: Maybe Int,
-    foAlternate :: Bool
-}
-
-padGeneral :: Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String)
-padGeneral trunc fdef idef cdef ff fo = ff (foLocale fo) $ getPadOption trunc fdef idef cdef (foPadding fo) (foWidth fo)
-
-padString :: (TimeLocale -> t -> String) -> (FormatOptions -> t -> String)
-padString ff = padGeneral False False 1 ' ' $ \locale pado -> showPadded pado . ff locale
-
-padNum :: (ShowPadded i) => Bool -> Int -> Char -> (t -> i) -> (FormatOptions -> t -> String)
-padNum fdef idef cdef ff = padGeneral False fdef idef cdef $ \_ pado -> showPaddedNum pado . ff
-
--- <http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html>
-class FormatTime t where
-    formatCharacter :: Char -> Maybe (FormatOptions -> t -> String)
-
-formatChar :: (FormatTime t) => Char -> FormatOptions -> t -> String
-formatChar '%' = padString $ \_ _ -> "%"
-formatChar 't' = padString $ \_ _ -> "\t"
-formatChar 'n' = padString $ \_ _ -> "\n"
-formatChar c = case formatCharacter c of
-    Just f -> f
-    _ -> \_ _ -> ""
-
--- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'.
---
--- The general form is @%\<modifier\>\<width\>\<alternate\>\<specifier\>@, where @\<modifier\>@, @\<width\>@, and @\<alternate\>@ are optional.
---
--- == @\<modifier\>@
--- glibc-style modifiers can be used before the specifier (here marked as @z@):
---
--- [@%-z@] no padding
---
--- [@%_z@] pad with spaces
---
--- [@%0z@] pad with zeros
---
--- [@%^z@] convert to upper case
---
--- [@%#z@] convert to lower case (consistently, unlike glibc)
---
--- == @\<width\>@
--- Width digits can also be used after any modifiers and before the specifier (here marked as @z@), for example:
---
--- [@%4z@] pad to 4 characters (with default padding character)
---
--- [@%_12z@] pad with spaces to 12 characters
---
--- == @\<alternate\>@
--- An optional @E@ character indicates an alternate formatting. Currently this only affects @%Z@ and @%z@.
---
--- [@%Ez@] alternate formatting
---
--- == @\<specifier\>@
---
--- For all types (note these three are done by 'formatTime', not by 'formatCharacter'):
---
--- [@%%@] @%@
---
--- [@%t@] tab
---
--- [@%n@] newline
---
--- === 'TimeZone'
--- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):
---
--- [@%z@] timezone offset in the format @±HHMM@
---
--- [@%Ez@] timezone offset in the format @±HH:MM@
---
--- [@%Z@] timezone name (or else offset in the format @±HHMM@)
---
--- [@%EZ@] timezone name (or else offset in the format @±HH:MM@)
---
--- === 'LocalTime'
--- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
---
--- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@)
---
--- === 'TimeOfDay'
--- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
---
--- [@%R@] same as @%H:%M@
---
--- [@%T@] same as @%H:%M:%S@
---
--- [@%X@] as 'timeFmt' @locale@ (e.g. @%H:%M:%S@)
---
--- [@%r@] as 'time12Fmt' @locale@ (e.g. @%I:%M:%S %p@)
---
--- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @am@, @pm@
---
--- [@%p@] day-half of day from ('amPm' @locale@), @AM@, @PM@
---
--- [@%H@] hour of day (24-hour), 0-padded to two chars, @00@ - @23@
---
--- [@%k@] hour of day (24-hour), space-padded to two chars, @ 0@ - @23@
---
--- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @01@ - @12@
---
--- [@%l@] hour of day-half (12-hour), space-padded to two chars, @ 1@ - @12@
---
--- [@%M@] minute of hour, 0-padded to two chars, @00@ - @59@
---
--- [@%S@] second of minute (without decimal part), 0-padded to two chars, @00@ - @60@
---
--- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@.
---
--- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros.
--- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified.
---
--- === 'UTCTime' and 'ZonedTime'
--- For 'UTCTime' and 'ZonedTime':
---
--- [@%s@] number of whole seconds since the Unix epoch. For times before
--- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@
--- the decimals are positive, not negative. For example, 0.9 seconds
--- before the Unix epoch is formatted as @-1.1@ with @%s%Q@.
---
--- === 'DayOfWeek'
--- For 'DayOfWeek' (and 'Day' and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
---
--- [@%u@] day of week number for Week Date format, @1@ (= Monday) - @7@ (= Sunday)
---
--- [@%w@] day of week number, @0@ (= Sunday) - @6@ (= Saturday)
---
--- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @Sun@ - @Sat@
---
--- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @Sunday@ - @Saturday@
---
--- === 'Day'
--- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
---
--- [@%D@] same as @%m\/%d\/%y@
---
--- [@%F@] same as @%Y-%m-%d@
---
--- [@%x@] as 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@)
---
--- [@%Y@] year, no padding. Note @%0Y@ and @%_Y@ pad to four chars
---
--- [@%y@] year of century, 0-padded to two chars, @00@ - @99@
---
--- [@%C@] century, no padding. Note @%0C@ and @%_C@ pad to two chars
---
--- [@%B@] month name, long form ('fst' from 'months' @locale@), @January@ - @December@
---
--- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @Jan@ - @Dec@
---
--- [@%m@] month of year, 0-padded to two chars, @01@ - @12@
---
--- [@%d@] day of month, 0-padded to two chars, @01@ - @31@
---
--- [@%e@] day of month, space-padded to two chars,  @ 1@ - @31@
---
--- [@%j@] day of year, 0-padded to three chars, @001@ - @366@
---
--- [@%f@] century for Week Date format, no padding. Note @%0f@ and @%_f@ pad to two chars
---
--- [@%V@] week of year for Week Date format, 0-padded to two chars, @01@ - @53@
---
--- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @00@ - @53@
---
--- [@%W@] week of year where weeks start on Monday (as 'mondayStartWeek'), 0-padded to two chars, @00@ - @53@
---
--- == Duration types
--- The specifiers for 'DiffTime', 'NominalDiffTime', 'CalendarDiffDays', and 'CalendarDiffTime' are semantically
--- separate from the other types.
--- Specifiers on negative time differences will generally be negative (think 'rem' rather than 'mod').
---
--- === 'NominalDiffTime' and 'DiffTime'
--- Note that a "minute" of 'DiffTime' is simply 60 SI seconds, rather than a minute of civil time.
--- Use 'NominalDiffTime' to work with civil time, ignoring any leap seconds.
---
--- For 'NominalDiffTime' and 'DiffTime':
---
--- [@%W@] total weeks
---
--- [@%D@] total days
---
--- [@%d@] days of week
---
--- [@%H@] total hours
---
--- [@%h@] hours of day
---
--- [@%M@] total minutes
---
--- [@%m@] minutes of hour
---
--- [@%S@] total seconds
---
--- [@%s@] seconds of minute
---
--- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@.
---
--- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros.
--- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified.
---
--- === 'CalendarDiffDays'
--- For 'CalendarDiffDays' (and 'CalendarDiffTime'):
---
--- [@%Y@] total years
---
--- [@%B@] total months
---
--- [@%b@] months of year
---
--- [@%W@] total weeks, not including months
---
--- [@%D@] total days, not including months
---
--- [@%d@] days of week
---
--- === 'CalendarDiffTime'
--- For 'CalendarDiffTime':
---
--- [@%H@] total hours, not including months
---
--- [@%h@] hours of day
---
--- [@%M@] total minutes, not including months
---
--- [@%m@] minutes of hour
---
--- [@%S@] total seconds, not including months
---
--- [@%s@] seconds of minute
---
--- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@.
---
--- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros.
--- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified.
-formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String
-formatTime _ [] _ = ""
-formatTime locale ('%':cs) t = case formatTime1 locale cs t of
-    Just result -> result
-    Nothing -> '%':(formatTime locale cs t)
-formatTime locale (c:cs) t = c:(formatTime locale cs t)
-
-formatTime1 :: (FormatTime t) => TimeLocale -> String -> t -> Maybe String
-formatTime1 locale ('_':cs) t = formatTime2 locale id (Just (Just ' ')) cs t
-formatTime1 locale ('-':cs) t = formatTime2 locale id (Just Nothing) cs t
-formatTime1 locale ('0':cs) t = formatTime2 locale id (Just (Just '0')) cs t
-formatTime1 locale ('^':cs) t = formatTime2 locale (fmap toUpper) Nothing cs t
-formatTime1 locale ('#':cs) t = formatTime2 locale (fmap toLower) Nothing cs t
-formatTime1 locale cs t = formatTime2 locale id Nothing cs t
-
-getDigit :: Char -> Maybe Int
-getDigit c | c < '0' = Nothing
-getDigit c | c > '9' = Nothing
-getDigit c = Just $ (ord c) - (ord '0')
-
-pullNumber :: Maybe Int -> String -> (Maybe Int,String)
-pullNumber mx [] = (mx,[])
-pullNumber mx s@(c:cs) = case getDigit c of
-    Just i -> pullNumber (Just $ (fromMaybe 0 mx)*10+i) cs
-    Nothing -> (mx,s)
-
-formatTime2 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe NumericPadOption -> String -> t -> Maybe String
-formatTime2 locale recase mpad cs t = let
-    (mwidth,rest) = pullNumber Nothing cs
-    in formatTime3 locale recase mpad mwidth rest t
-
-formatTime3 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe NumericPadOption -> Maybe Int -> String -> t -> Maybe String
-formatTime3 locale recase mpad mwidth ('E':cs) = formatTime4 recase (MkFormatOptions locale mpad mwidth True) cs
-formatTime3 locale recase mpad mwidth cs = formatTime4 recase (MkFormatOptions locale mpad mwidth False) cs
-
-formatTime4 :: (FormatTime t) => (String -> String) -> FormatOptions -> String -> t -> Maybe String
-formatTime4 recase fo (c:cs) t = Just $ (recase (formatChar c fo t)) ++ (formatTime (foLocale fo) cs t)
-formatTime4 _recase _fo [] _t = Nothing
-
-instance FormatTime LocalTime where
-    formatCharacter 'c' = Just $ \fo -> formatTime (foLocale fo) $ dateTimeFmt $ foLocale fo
-    formatCharacter c = case formatCharacter c of
-        Just f -> Just $ \fo dt -> f fo (localDay dt)
-        Nothing -> case formatCharacter c of
-            Just f -> Just $ \fo dt -> f fo (localTimeOfDay dt)
-            Nothing -> Nothing
-
-todAMPM :: TimeLocale -> TimeOfDay -> String
-todAMPM locale day = let
-    (am,pm) = amPm locale
-    in if (todHour day) < 12 then am else pm
-
-tod12Hour :: TimeOfDay -> Int
-tod12Hour day = (mod (todHour day - 1) 12) + 1
-
-showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String
-showPaddedFixedFraction pado x = let
-    digits = dropWhile (=='.') $ dropWhile (/='.') $ showFixed True x
-    n = length digits
-    in case pado of
-        NoPad -> digits
-        Pad i c -> if i < n
-            then take i digits
-            else digits ++ replicate (i - n) c
-
-instance FormatTime TimeOfDay where
-    -- Aggregate
-    formatCharacter 'R' = Just $ padString $ \locale -> formatTime locale "%H:%M"
-    formatCharacter 'T' = Just $ padString $ \locale -> formatTime locale "%H:%M:%S"
-    formatCharacter 'X' = Just $ padString $ \locale -> formatTime locale (timeFmt locale)
-    formatCharacter 'r' = Just $ padString $ \locale -> formatTime locale (time12Fmt locale)
-    -- AM/PM
-    formatCharacter 'P' = Just $ padString $ \locale -> map toLower . todAMPM locale
-    formatCharacter 'p' = Just $ padString $ \locale -> todAMPM locale
-    -- Hour
-    formatCharacter 'H' = Just $ padNum True  2 '0' todHour
-    formatCharacter 'I' = Just $ padNum True  2 '0' tod12Hour
-    formatCharacter 'k' = Just $ padNum True  2 ' ' todHour
-    formatCharacter 'l' = Just $ padNum True  2 ' ' tod12Hour
-    -- Minute
-    formatCharacter 'M' = Just $ padNum True  2 '0' todMin
-    -- Second
-    formatCharacter 'S' = Just $ padNum True  2 '0' $ (floor . todSec :: TimeOfDay -> Int)
-    formatCharacter 'q' = Just $ padGeneral True True 12 '0' $ \_ pado -> showPaddedFixedFraction pado . todSec
-    formatCharacter 'Q' = Just $ padGeneral True False 12 '0' $ \_ pado -> dotNonEmpty . showPaddedFixedFraction pado . todSec where
-        dotNonEmpty "" = ""
-        dotNonEmpty s = '.':s
-
-    -- Default
-    formatCharacter _   = Nothing
-
-instance FormatTime ZonedTime where
-    formatCharacter 'c' = Just $ padString $ \locale -> formatTime locale (dateTimeFmt locale)
-    formatCharacter 's' = Just $ padNum True  1 '0' $ (floor . utcTimeToPOSIXSeconds . zonedTimeToUTC :: ZonedTime -> Integer)
-    formatCharacter c = case formatCharacter c of
-        Just f -> Just $ \fo dt -> f fo (zonedTimeToLocalTime dt)
-        Nothing -> case formatCharacter c of
-            Just f -> Just $ \fo dt -> f fo (zonedTimeZone dt)
-            Nothing -> Nothing
-
-instance FormatTime TimeZone where
-    formatCharacter 'z' = Just $ \fo z -> let
-        alt = foAlternate fo
-        in timeZoneOffsetString'' alt (getPadOption False True (if alt then 5 else 4) '0' (foPadding fo) (foWidth fo)) z
-    formatCharacter 'Z' = Just $ \fo z -> let
-        n = timeZoneName z
-        alt = foAlternate fo
-        in if null n then timeZoneOffsetString'' alt (getPadOption False True (if alt then 5 else 4) '0' (foPadding fo) (foWidth fo)) z else padString (\_ -> timeZoneName) fo z
-    formatCharacter _ = Nothing
-
-instance FormatTime DayOfWeek where
-    formatCharacter 'u' = Just $ padNum True  1 '0' $ fromEnum
-    formatCharacter 'w' = Just $ padNum True  1 '0' $ \wd -> (mod (fromEnum wd) 7)
-    formatCharacter 'a' = Just $ padString $ \locale wd -> snd $ (wDays locale) !! (mod (fromEnum wd) 7)
-    formatCharacter 'A' = Just $ padString $ \locale wd -> fst $ (wDays locale) !! (mod (fromEnum wd) 7)
-    formatCharacter _   = Nothing
-
-instance FormatTime Day where
-    -- Aggregate
-    formatCharacter 'D' = Just $ padString $ \locale -> formatTime locale "%m/%d/%y"
-    formatCharacter 'F' = Just $ padString $ \locale -> formatTime locale "%Y-%m-%d"
-    formatCharacter 'x' = Just $ padString $ \locale -> formatTime locale (dateFmt locale)
-
-    -- Year Count
-    formatCharacter 'Y' = Just $ padNum False 4 '0' $          fst . toOrdinalDate
-    formatCharacter 'y' = Just $ padNum True  2 '0' $ mod100 . fst . toOrdinalDate
-    formatCharacter 'C' = Just $ padNum False 2 '0' $ div100 . fst . toOrdinalDate
-    -- Month of Year
-    formatCharacter 'B' = Just $ padString $ \locale -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
-    formatCharacter 'b' = Just $ padString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
-    formatCharacter 'h' = Just $ padString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
-    formatCharacter 'm' = Just $ padNum True  2 '0' $ (\(_,m,_) -> m) . toGregorian
-    -- Day of Month
-    formatCharacter 'd' = Just $ padNum True  2 '0' $ (\(_,_,d) -> d) . toGregorian
-    formatCharacter 'e' = Just $ padNum True  2 ' ' $ (\(_,_,d) -> d) . toGregorian
-    -- Day of Year
-    formatCharacter 'j' = Just $ padNum True  3 '0' $ snd . toOrdinalDate
-
-    -- ISO 8601 Week Date
-    formatCharacter 'G' = Just $ padNum False 4 '0' $ (\(y,_,_) -> y) . toWeekDate
-    formatCharacter 'g' = Just $ padNum True  2 '0' $ mod100 . (\(y,_,_) -> y) . toWeekDate
-    formatCharacter 'f' = Just $ padNum False 2 '0' $ div100 . (\(y,_,_) -> y) . toWeekDate
-
-    formatCharacter 'V' = Just $ padNum True  2 '0' $ (\(_,w,_) -> w) . toWeekDate
-    formatCharacter 'u' = Just $ padNum True  1 '0' $ (\(_,_,d) -> d) . toWeekDate
-
-    -- Day of week
-    formatCharacter 'a' = Just $ padString $ \locale -> snd . ((wDays locale) !!) . snd . sundayStartWeek
-    formatCharacter 'A' = Just $ padString $ \locale -> fst . ((wDays locale) !!) . snd . sundayStartWeek
-    formatCharacter 'U' = Just $ padNum True  2 '0' $ fst . sundayStartWeek
-    formatCharacter 'w' = Just $ padNum True  1 '0' $ snd . sundayStartWeek
-    formatCharacter 'W' = Just $ padNum True  2 '0' $ fst . mondayStartWeek
-
-    -- Default
-    formatCharacter _   = Nothing
-
-instance FormatTime UTCTime where
-    formatCharacter c = fmap (\f fo t -> f fo (utcToZonedTime utc t)) (formatCharacter c)
-
-instance FormatTime UniversalTime where
-    formatCharacter c = fmap (\f fo t -> f fo (ut1ToLocalTime 0 t)) (formatCharacter c)
-
-padNumStd :: Int -> (t -> Integer) -> (FormatOptions -> t -> String)
-padNumStd n = padNum False n '0'
-
-quotBy :: Real t => t -> t -> Integer
-quotBy d n = truncate ((toRational n) / (toRational d))
-
-remBy :: Real t => t -> t -> t
-remBy d n = n - (fromInteger f) * d where
-    f = quotBy d n
-
-instance FormatTime NominalDiffTime where
-    formatCharacter 'W' = Just $ padNumStd 1 $ quotBy $ 7 * 86400
-    formatCharacter 'D' = Just $ padNumStd 1 $ quotBy 86400
-    formatCharacter 'd' = Just $ padNumStd 1 $ remBy 7 . quotBy 86400
-    formatCharacter 'H' = Just $ padNumStd 1 $ quotBy 3600
-    formatCharacter 'h' = Just $ padNumStd 2 $ remBy 24 . quotBy 3600
-    formatCharacter 'M' = Just $ padNumStd 1 $ quotBy 60
-    formatCharacter 'm' = Just $ padNumStd 2 $ remBy 60 . quotBy 60
-    formatCharacter 'S' = Just $ padNumStd 1 $ quotBy 1
-    formatCharacter 's' = Just $ padNumStd 2 $ remBy 60 . quotBy 1
-    formatCharacter 'q' = Just $ padGeneral True True 12 '0' $ \_ pado t -> showPaddedFixedFraction pado (realToFrac t :: Pico)
-    formatCharacter 'Q' = Just $ padGeneral True False 12 '0' $ \_ pado t -> dotNonEmpty $ showPaddedFixedFraction pado (realToFrac t :: Pico) where
-        dotNonEmpty "" = ""
-        dotNonEmpty s = '.':s
-    formatCharacter _   = Nothing
-
-instance FormatTime DiffTime where
-    formatCharacter 'W' = Just $ padNumStd 1 $ quotBy $ 7 * 86400
-    formatCharacter 'D' = Just $ padNumStd 1 $ quotBy 86400
-    formatCharacter 'd' = Just $ padNumStd 1 $ remBy 7 . quotBy 86400
-    formatCharacter 'H' = Just $ padNumStd 1 $ quotBy 3600
-    formatCharacter 'h' = Just $ padNumStd 2 $ remBy 24 . quotBy 3600
-    formatCharacter 'M' = Just $ padNumStd 1 $ quotBy 60
-    formatCharacter 'm' = Just $ padNumStd 2 $ remBy 60 . quotBy 60
-    formatCharacter 'S' = Just $ padNumStd 1 $ quotBy 1
-    formatCharacter 's' = Just $ padNumStd 2 $ remBy 60 . quotBy 1
-    formatCharacter 'q' = Just $ padGeneral True True 12 '0' $ \_ pado t -> showPaddedFixedFraction pado (realToFrac t :: Pico)
-    formatCharacter 'Q' = Just $ padGeneral True False 12 '0' $ \_ pado t -> dotNonEmpty $ showPaddedFixedFraction pado (realToFrac t :: Pico) where
-        dotNonEmpty "" = ""
-        dotNonEmpty s = '.':s
-    formatCharacter _   = Nothing
-
-instance FormatTime CalendarDiffDays where
-    formatCharacter 'Y' = Just $ padNumStd 1 $ quotBy 12 . cdMonths
-    formatCharacter 'B' = Just $ padNumStd 1 $ cdMonths
-    formatCharacter 'b' = Just $ padNumStd 1 $ remBy 12 . cdMonths
-    formatCharacter 'W' = Just $ padNumStd 1 $ quotBy 7 . cdDays
-    formatCharacter 'D' = Just $ padNumStd 1 $ cdDays
-    formatCharacter 'd' = Just $ padNumStd 1 $ remBy 7 . cdDays
-    formatCharacter _   = Nothing
-
-instance FormatTime CalendarDiffTime where
-    formatCharacter 'Y' = Just $ padNumStd 1 $ quotBy 12 . ctMonths
-    formatCharacter 'B' = Just $ padNumStd 1 $ ctMonths
-    formatCharacter 'b' = Just $ padNumStd 1 $ remBy 12 . ctMonths
-    formatCharacter c = fmap (\f fo t -> f fo (ctTime t)) (formatCharacter c)
diff --git a/lib/Data/Time/Format/Format/Class.hs b/lib/Data/Time/Format/Format/Class.hs
new file mode 100644 (file)
index 0000000..0805a78
--- /dev/null
@@ -0,0 +1,352 @@
+module Data.Time.Format.Format.Class
+    (
+        -- * Formatting
+        formatTime,
+        FormatNumericPadding,
+        FormatOptions(..),
+        FormatTime(..),
+        ShowPadded,PadOption,
+        formatGeneral,formatString,formatNumber,formatNumberStd,
+        showPaddedFixed,showPaddedFixedFraction,
+        quotBy,remBy,
+    )
+    where
+
+import Data.Char
+import Data.Maybe
+import Data.Fixed
+import Data.Time.Calendar.Private
+import Data.Time.Format.Locale
+
+type FormatNumericPadding = Maybe Char
+
+data FormatOptions = MkFormatOptions {
+    foLocale :: TimeLocale,
+    foPadding :: Maybe FormatNumericPadding,
+    foWidth :: Maybe Int
+}
+
+-- <http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html>
+class FormatTime t where
+    formatCharacter :: Bool -> Char -> Maybe (FormatOptions -> t -> String)
+
+
+-- the weird UNIX logic is here
+getPadOption :: Bool -> Bool -> Int -> Char -> Maybe FormatNumericPadding -> Maybe Int -> PadOption
+getPadOption trunc fdef idef cdef mnpad mi = let
+    c = case mnpad of
+        Just (Just c') -> c'
+        Just Nothing -> ' '
+        _ -> cdef
+    i = case mi of
+        Just i' -> case mnpad of
+            Just Nothing -> i'
+            _ -> if trunc then i' else max i' idef
+        Nothing -> idef
+    f = case mi of
+        Just _ -> True
+        Nothing -> case mnpad of
+            Nothing -> fdef
+            Just Nothing -> False
+            Just (Just _) -> True
+    in if f then Pad i c else NoPad
+
+formatGeneral :: Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String)
+formatGeneral trunc fdef idef cdef ff fo = ff (foLocale fo) $ getPadOption trunc fdef idef cdef (foPadding fo) (foWidth fo)
+
+formatString :: (TimeLocale -> t -> String) -> (FormatOptions -> t -> String)
+formatString ff = formatGeneral False False 1 ' ' $ \locale pado -> showPadded pado . ff locale
+
+formatNumber :: (ShowPadded i) => Bool -> Int -> Char -> (t -> i) -> (FormatOptions -> t -> String)
+formatNumber fdef idef cdef ff = formatGeneral False fdef idef cdef $ \_ pado -> showPaddedNum pado . ff
+
+formatNumberStd :: Int -> (t -> Integer) -> (FormatOptions -> t -> String)
+formatNumberStd n = formatNumber False n '0'
+
+quotBy :: Real t => t -> t -> Integer
+quotBy d n = truncate ((toRational n) / (toRational d))
+
+remBy :: Real t => t -> t -> t
+remBy d n = n - (fromInteger f) * d where
+    f = quotBy d n
+
+
+showPaddedFixed :: HasResolution a => PadOption -> PadOption -> Fixed a -> String
+showPaddedFixed padn padf x | x < 0 = '-' : showPaddedFixed padn padf (negate x)
+showPaddedFixed padn padf x = let
+    ns = showPaddedNum padn $ (floor x :: Integer)
+    fs = showPaddedFixedFraction padf x
+    ds = if null fs then "" else "."
+    in ns ++ ds ++ fs
+
+showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String
+showPaddedFixedFraction pado x = let
+    digits = dropWhile (=='.') $ dropWhile (/='.') $ showFixed True x
+    n = length digits
+    in case pado of
+        NoPad -> digits
+        Pad i c -> if i < n
+            then take i digits
+            else digits ++ replicate (i - n) c
+
+
+-- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'.
+--
+-- The general form is @%\<modifier\>\<width\>\<alternate\>\<specifier\>@, where @\<modifier\>@, @\<width\>@, and @\<alternate\>@ are optional.
+--
+-- == @\<modifier\>@
+-- glibc-style modifiers can be used before the specifier (here marked as @z@):
+--
+-- [@%-z@] no padding
+--
+-- [@%_z@] pad with spaces
+--
+-- [@%0z@] pad with zeros
+--
+-- [@%^z@] convert to upper case
+--
+-- [@%#z@] convert to lower case (consistently, unlike glibc)
+--
+-- == @\<width\>@
+-- Width digits can also be used after any modifiers and before the specifier (here marked as @z@), for example:
+--
+-- [@%4z@] pad to 4 characters (with default padding character)
+--
+-- [@%_12z@] pad with spaces to 12 characters
+--
+-- == @\<alternate\>@
+-- An optional @E@ character indicates an alternate formatting. Currently this only affects @%Z@ and @%z@.
+--
+-- [@%Ez@] alternate formatting
+--
+-- == @\<specifier\>@
+--
+-- For all types (note these three are done by 'formatTime', not by 'formatCharacter'):
+--
+-- [@%%@] @%@
+--
+-- [@%t@] tab
+--
+-- [@%n@] newline
+--
+-- === 'TimeZone'
+-- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):
+--
+-- [@%z@] timezone offset in the format @±HHMM@
+--
+-- [@%Ez@] timezone offset in the format @±HH:MM@
+--
+-- [@%Z@] timezone name (or else offset in the format @±HHMM@)
+--
+-- [@%EZ@] timezone name (or else offset in the format @±HH:MM@)
+--
+-- === 'LocalTime'
+-- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
+--
+-- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@)
+--
+-- === 'TimeOfDay'
+-- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
+--
+-- [@%R@] same as @%H:%M@
+--
+-- [@%T@] same as @%H:%M:%S@
+--
+-- [@%X@] as 'timeFmt' @locale@ (e.g. @%H:%M:%S@)
+--
+-- [@%r@] as 'time12Fmt' @locale@ (e.g. @%I:%M:%S %p@)
+--
+-- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @am@, @pm@
+--
+-- [@%p@] day-half of day from ('amPm' @locale@), @AM@, @PM@
+--
+-- [@%H@] hour of day (24-hour), 0-padded to two chars, @00@ - @23@
+--
+-- [@%k@] hour of day (24-hour), space-padded to two chars, @ 0@ - @23@
+--
+-- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @01@ - @12@
+--
+-- [@%l@] hour of day-half (12-hour), space-padded to two chars, @ 1@ - @12@
+--
+-- [@%M@] minute of hour, 0-padded to two chars, @00@ - @59@
+--
+-- [@%S@] second of minute (without decimal part), 0-padded to two chars, @00@ - @60@
+--
+-- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@.
+--
+-- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros.
+-- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified.
+--
+-- === 'UTCTime' and 'ZonedTime'
+-- For 'UTCTime' and 'ZonedTime':
+--
+-- [@%s@] number of whole seconds since the Unix epoch. For times before
+-- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@
+-- the decimals are positive, not negative. For example, 0.9 seconds
+-- before the Unix epoch is formatted as @-1.1@ with @%s%Q@.
+--
+-- === 'DayOfWeek'
+-- For 'DayOfWeek' (and 'Day' and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
+--
+-- [@%u@] day of week number for Week Date format, @1@ (= Monday) - @7@ (= Sunday)
+--
+-- [@%w@] day of week number, @0@ (= Sunday) - @6@ (= Saturday)
+--
+-- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @Sun@ - @Sat@
+--
+-- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @Sunday@ - @Saturday@
+--
+-- === 'Day'
+-- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
+--
+-- [@%D@] same as @%m\/%d\/%y@
+--
+-- [@%F@] same as @%Y-%m-%d@
+--
+-- [@%x@] as 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@)
+--
+-- [@%Y@] year, no padding. Note @%0Y@ and @%_Y@ pad to four chars
+--
+-- [@%y@] year of century, 0-padded to two chars, @00@ - @99@
+--
+-- [@%C@] century, no padding. Note @%0C@ and @%_C@ pad to two chars
+--
+-- [@%B@] month name, long form ('fst' from 'months' @locale@), @January@ - @December@
+--
+-- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @Jan@ - @Dec@
+--
+-- [@%m@] month of year, 0-padded to two chars, @01@ - @12@
+--
+-- [@%d@] day of month, 0-padded to two chars, @01@ - @31@
+--
+-- [@%e@] day of month, space-padded to two chars,  @ 1@ - @31@
+--
+-- [@%j@] day of year, 0-padded to three chars, @001@ - @366@
+--
+-- [@%f@] century for Week Date format, no padding. Note @%0f@ and @%_f@ pad to two chars
+--
+-- [@%V@] week of year for Week Date format, 0-padded to two chars, @01@ - @53@
+--
+-- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @00@ - @53@
+--
+-- [@%W@] week of year where weeks start on Monday (as 'mondayStartWeek'), 0-padded to two chars, @00@ - @53@
+--
+-- == Duration types
+-- The specifiers for 'DiffTime', 'NominalDiffTime', 'CalendarDiffDays', and 'CalendarDiffTime' are semantically
+-- separate from the other types.
+-- Specifiers on negative time differences will generally be negative (think 'rem' rather than 'mod').
+--
+-- === 'NominalDiffTime' and 'DiffTime'
+-- Note that a "minute" of 'DiffTime' is simply 60 SI seconds, rather than a minute of civil time.
+-- Use 'NominalDiffTime' to work with civil time, ignoring any leap seconds.
+--
+-- For 'NominalDiffTime' and 'DiffTime':
+--
+-- [@%W@] total whole weeks
+--
+-- [@%D@] total whole days
+--
+-- [@%d@] whole days of week
+--
+-- [@%H@] total whole hours
+--
+-- [@%h@] whole hours of day
+--
+-- [@%M@] total whole minutes
+--
+-- [@%m@] whole minutes of hour
+--
+-- [@%S@] total whole seconds
+--
+-- [@%ES@] total seconds, with decimal point and up to <width> (default 12) decimal places, without trailing zeros.
+-- For a whole number of seconds, @%ES@ omits the decimal point unless padding is specified.
+--
+-- [@%0ES@] total seconds, with decimal point and <width> (default 12) decimal places.
+--
+-- [@%s@] whole seconds of minute
+--
+-- [@%Es@] seconds of minute, with decimal point and up to <width> (default 12) decimal places, without trailing zeros.
+-- For a whole number of seconds, @%Es@ omits the decimal point unless padding is specified.
+--
+-- [@%0Es@] seconds of minute as two digits, with decimal point and <width> (default 12) decimal places.
+--
+-- === 'CalendarDiffDays'
+-- For 'CalendarDiffDays' (and 'CalendarDiffTime'):
+--
+-- [@%Y@] total years
+--
+-- [@%B@] total months
+--
+-- [@%b@] months of year
+--
+-- [@%W@] total weeks, not including months
+--
+-- [@%D@] total days, not including months
+--
+-- [@%d@] days of week
+--
+-- === 'CalendarDiffTime'
+-- For 'CalendarDiffTime':
+--
+-- [@%H@] total hours, not including months
+--
+-- [@%h@] hours of day
+--
+-- [@%M@] total minutes, not including months
+--
+-- [@%m@] minutes of hour
+--
+-- [@%S@] total seconds, not including months
+--
+-- [@%s@] seconds of minute
+--
+-- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@.
+--
+-- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros.
+-- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified.
+formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String
+formatTime _ [] _ = ""
+formatTime locale ('%':cs) t = case formatTime1 locale cs t of
+    Just result -> result
+    Nothing -> '%':(formatTime locale cs t)
+formatTime locale (c:cs) t = c:(formatTime locale cs t)
+
+formatTime1 :: (FormatTime t) => TimeLocale -> String -> t -> Maybe String
+formatTime1 locale ('_':cs) t = formatTime2 locale id (Just (Just ' ')) cs t
+formatTime1 locale ('-':cs) t = formatTime2 locale id (Just Nothing) cs t
+formatTime1 locale ('0':cs) t = formatTime2 locale id (Just (Just '0')) cs t
+formatTime1 locale ('^':cs) t = formatTime2 locale (fmap toUpper) Nothing cs t
+formatTime1 locale ('#':cs) t = formatTime2 locale (fmap toLower) Nothing cs t
+formatTime1 locale cs t = formatTime2 locale id Nothing cs t
+
+getDigit :: Char -> Maybe Int
+getDigit c | c < '0' = Nothing
+getDigit c | c > '9' = Nothing
+getDigit c = Just $ (ord c) - (ord '0')
+
+pullNumber :: Maybe Int -> String -> (Maybe Int,String)
+pullNumber mx [] = (mx,[])
+pullNumber mx s@(c:cs) = case getDigit c of
+    Just i -> pullNumber (Just $ (fromMaybe 0 mx)*10+i) cs
+    Nothing -> (mx,s)
+
+formatTime2 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> String -> t -> Maybe String
+formatTime2 locale recase mpad cs t = let
+    (mwidth,rest) = pullNumber Nothing cs
+    in formatTime3 locale recase mpad mwidth rest t
+
+formatTime3 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> Maybe Int -> String -> t -> Maybe String
+formatTime3 locale recase mpad mwidth ('E':cs) = formatTime4 True recase (MkFormatOptions locale mpad mwidth) cs
+formatTime3 locale recase mpad mwidth cs = formatTime4 False recase (MkFormatOptions locale mpad mwidth) cs
+
+formatTime4 :: (FormatTime t) => Bool -> (String -> String) -> FormatOptions -> String -> t -> Maybe String
+formatTime4 alt recase fo (c:cs) t = Just $ (recase (formatChar alt c fo t)) ++ (formatTime (foLocale fo) cs t)
+formatTime4 _alt _recase _fo [] _t = Nothing
+
+formatChar :: (FormatTime t) => Bool -> Char -> FormatOptions -> t -> String
+formatChar _ '%' = formatString $ \_ _ -> "%"
+formatChar _ 't' = formatString $ \_ _ -> "\t"
+formatChar _ 'n' = formatString $ \_ _ -> "\n"
+formatChar alt c = case formatCharacter alt c of
+    Just f -> f
+    _ -> \_ _ -> ""
diff --git a/lib/Data/Time/Format/Format/Instances.hs b/lib/Data/Time/Format/Format/Instances.hs
new file mode 100644 (file)
index 0000000..6087f4a
--- /dev/null
@@ -0,0 +1,188 @@
+{-# OPTIONS -fno-warn-orphans #-}
+module Data.Time.Format.Format.Instances () where
+
+import Data.Char
+import Data.Fixed
+import Data.Time.Clock.Internal.DiffTime
+import Data.Time.Clock.Internal.NominalDiffTime
+import Data.Time.Clock.Internal.UniversalTime
+import Data.Time.Clock.Internal.UTCTime
+import Data.Time.Clock.POSIX
+import Data.Time.Calendar.Days
+import Data.Time.Calendar.CalendarDiffDays
+import Data.Time.Calendar.Gregorian
+import Data.Time.Calendar.Week
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.OrdinalDate
+import Data.Time.Calendar.Private
+import Data.Time.LocalTime.Internal.CalendarDiffTime
+import Data.Time.LocalTime.Internal.TimeZone
+import Data.Time.LocalTime.Internal.TimeOfDay
+import Data.Time.LocalTime.Internal.LocalTime
+import Data.Time.LocalTime.Internal.ZonedTime
+import Data.Time.Format.Locale
+import Data.Time.Format.Format.Class
+
+
+instance FormatTime LocalTime where
+    formatCharacter _ 'c' = Just $ \fo -> formatTime (foLocale fo) $ dateTimeFmt $ foLocale fo
+    formatCharacter alt c = case formatCharacter alt c of
+        Just f -> Just $ \fo dt -> f fo (localDay dt)
+        Nothing -> case formatCharacter alt c of
+            Just f -> Just $ \fo dt -> f fo (localTimeOfDay dt)
+            Nothing -> Nothing
+
+todAMPM :: TimeLocale -> TimeOfDay -> String
+todAMPM locale day = let
+    (am,pm) = amPm locale
+    in if (todHour day) < 12 then am else pm
+
+tod12Hour :: TimeOfDay -> Int
+tod12Hour day = (mod (todHour day - 1) 12) + 1
+
+instance FormatTime TimeOfDay where
+    -- Aggregate
+    formatCharacter _ 'R' = Just $ formatString $ \locale -> formatTime locale "%H:%M"
+    formatCharacter _ 'T' = Just $ formatString $ \locale -> formatTime locale "%H:%M:%S"
+    formatCharacter _ 'X' = Just $ formatString $ \locale -> formatTime locale (timeFmt locale)
+    formatCharacter _ 'r' = Just $ formatString $ \locale -> formatTime locale (time12Fmt locale)
+    -- AM/PM
+    formatCharacter _ 'P' = Just $ formatString $ \locale -> map toLower . todAMPM locale
+    formatCharacter _ 'p' = Just $ formatString $ \locale -> todAMPM locale
+    -- Hour
+    formatCharacter _ 'H' = Just $ formatNumber True  2 '0' todHour
+    formatCharacter _ 'I' = Just $ formatNumber True  2 '0' tod12Hour
+    formatCharacter _ 'k' = Just $ formatNumber True  2 ' ' todHour
+    formatCharacter _ 'l' = Just $ formatNumber True  2 ' ' tod12Hour
+    -- Minute
+    formatCharacter _ 'M' = Just $ formatNumber True  2 '0' todMin
+    -- Second
+    formatCharacter _ 'S' = Just $ formatNumber True  2 '0' $ (floor . todSec :: TimeOfDay -> Int)
+    formatCharacter _ 'q' = Just $ formatGeneral True True 12 '0' $ \_ pado -> showPaddedFixedFraction pado . todSec
+    formatCharacter _ 'Q' = Just $ formatGeneral True False 12 '0' $ \_ pado -> dotNonEmpty . showPaddedFixedFraction pado . todSec where
+        dotNonEmpty "" = ""
+        dotNonEmpty s = '.':s
+
+    -- Default
+    formatCharacter _ _   = Nothing
+
+instance FormatTime ZonedTime where
+    formatCharacter _ 'c' = Just $ formatString $ \locale -> formatTime locale (dateTimeFmt locale)
+    formatCharacter _ 's' = Just $ formatNumber True  1 '0' $ (floor . utcTimeToPOSIXSeconds . zonedTimeToUTC :: ZonedTime -> Integer)
+    formatCharacter alt c = case formatCharacter alt c of
+        Just f -> Just $ \fo dt -> f fo (zonedTimeToLocalTime dt)
+        Nothing -> case formatCharacter alt c of
+            Just f -> Just $ \fo dt -> f fo (zonedTimeZone dt)
+            Nothing -> Nothing
+
+instance FormatTime TimeZone where
+    formatCharacter False 'z' = Just $ formatGeneral False True 4 '0' $ \_ -> timeZoneOffsetString'' False
+    formatCharacter True 'z' = Just $ formatGeneral False True 5 '0' $ \_ -> timeZoneOffsetString'' True
+    formatCharacter alt 'Z' = Just $ \fo z -> let
+        n = timeZoneName z
+        idef = if alt then 5 else 4
+        in if null n then formatGeneral False True idef '0' (\_ -> timeZoneOffsetString'' alt) fo z else formatString (\_ -> timeZoneName) fo z
+    formatCharacter _ _ = Nothing
+
+instance FormatTime DayOfWeek where
+    formatCharacter _ 'u' = Just $ formatNumber True  1 '0' $ fromEnum
+    formatCharacter _ 'w' = Just $ formatNumber True  1 '0' $ \wd -> (mod (fromEnum wd) 7)
+    formatCharacter _ 'a' = Just $ formatString $ \locale wd -> snd $ (wDays locale) !! (mod (fromEnum wd) 7)
+    formatCharacter _ 'A' = Just $ formatString $ \locale wd -> fst $ (wDays locale) !! (mod (fromEnum wd) 7)
+    formatCharacter _ _   = Nothing
+
+instance FormatTime Day where
+    -- Aggregate
+    formatCharacter _ 'D' = Just $ formatString $ \locale -> formatTime locale "%m/%d/%y"
+    formatCharacter _ 'F' = Just $ formatString $ \locale -> formatTime locale "%Y-%m-%d"
+    formatCharacter _ 'x' = Just $ formatString $ \locale -> formatTime locale (dateFmt locale)
+
+    -- Year Count
+    formatCharacter _ 'Y' = Just $ formatNumber False 4 '0' $          fst . toOrdinalDate
+    formatCharacter _ 'y' = Just $ formatNumber True  2 '0' $ mod100 . fst . toOrdinalDate
+    formatCharacter _ 'C' = Just $ formatNumber False 2 '0' $ div100 . fst . toOrdinalDate
+    -- Month of Year
+    formatCharacter _ 'B' = Just $ formatString $ \locale -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
+    formatCharacter _ 'b' = Just $ formatString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
+    formatCharacter _ 'h' = Just $ formatString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
+    formatCharacter _ 'm' = Just $ formatNumber True  2 '0' $ (\(_,m,_) -> m) . toGregorian
+    -- Day of Month
+    formatCharacter _ 'd' = Just $ formatNumber True  2 '0' $ (\(_,_,d) -> d) . toGregorian
+    formatCharacter _ 'e' = Just $ formatNumber True  2 ' ' $ (\(_,_,d) -> d) . toGregorian
+    -- Day of Year
+    formatCharacter _ 'j' = Just $ formatNumber True  3 '0' $ snd . toOrdinalDate
+
+    -- ISO 8601 Week Date
+    formatCharacter _ 'G' = Just $ formatNumber False 4 '0' $ (\(y,_,_) -> y) . toWeekDate
+    formatCharacter _ 'g' = Just $ formatNumber True  2 '0' $ mod100 . (\(y,_,_) -> y) . toWeekDate
+    formatCharacter _ 'f' = Just $ formatNumber False 2 '0' $ div100 . (\(y,_,_) -> y) . toWeekDate
+
+    formatCharacter _ 'V' = Just $ formatNumber True  2 '0' $ (\(_,w,_) -> w) . toWeekDate
+    formatCharacter _ 'u' = Just $ formatNumber True  1 '0' $ (\(_,_,d) -> d) . toWeekDate
+
+    -- Day of week
+    formatCharacter _ 'a' = Just $ formatString $ \locale -> snd . ((wDays locale) !!) . snd . sundayStartWeek
+    formatCharacter _ 'A' = Just $ formatString $ \locale -> fst . ((wDays locale) !!) . snd . sundayStartWeek
+    formatCharacter _ 'U' = Just $ formatNumber True  2 '0' $ fst . sundayStartWeek
+    formatCharacter _ 'w' = Just $ formatNumber True  1 '0' $ snd . sundayStartWeek
+    formatCharacter _ 'W' = Just $ formatNumber True  2 '0' $ fst . mondayStartWeek
+
+    -- Default
+    formatCharacter _ _   = Nothing
+
+instance FormatTime UTCTime where
+    formatCharacter alt c = fmap (\f fo t -> f fo (utcToZonedTime utc t)) (formatCharacter alt c)
+
+instance FormatTime UniversalTime where
+    formatCharacter alt c = fmap (\f fo t -> f fo (ut1ToLocalTime 0 t)) (formatCharacter alt c)
+
+instance FormatTime NominalDiffTime where
+    formatCharacter _ 'W' = Just $ formatNumberStd 1 $ quotBy $ 7 * 86400
+    formatCharacter _ 'D' = Just $ formatNumberStd 1 $ quotBy 86400
+    formatCharacter _ 'd' = Just $ formatNumberStd 1 $ remBy 7 . quotBy 86400
+    formatCharacter _ 'H' = Just $ formatNumberStd 1 $ quotBy 3600
+    formatCharacter _ 'h' = Just $ formatNumberStd 2 $ remBy 24 . quotBy 3600
+    formatCharacter _ 'M' = Just $ formatNumberStd 1 $ quotBy 60
+    formatCharacter _ 'm' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 60
+    formatCharacter False 'S' = Just $ formatNumberStd 1 $ quotBy 1
+    formatCharacter True 'S' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> showPaddedFixed NoPad padf (realToFrac t :: Pico)
+    formatCharacter False 's' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1
+    formatCharacter True 's' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> let
+        padn = case padf of
+            NoPad -> NoPad
+            Pad _ c -> Pad 2 c
+        in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico)
+    formatCharacter _ _   = Nothing
+
+instance FormatTime DiffTime where
+    formatCharacter _ 'W' = Just $ formatNumberStd 1 $ quotBy $ 7 * 86400
+    formatCharacter _ 'D' = Just $ formatNumberStd 1 $ quotBy 86400
+    formatCharacter _ 'd' = Just $ formatNumberStd 1 $ remBy 7 . quotBy 86400
+    formatCharacter _ 'H' = Just $ formatNumberStd 1 $ quotBy 3600
+    formatCharacter _ 'h' = Just $ formatNumberStd 2 $ remBy 24 . quotBy 3600
+    formatCharacter _ 'M' = Just $ formatNumberStd 1 $ quotBy 60
+    formatCharacter _ 'm' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 60
+    formatCharacter False 'S' = Just $ formatNumberStd 1 $ quotBy 1
+    formatCharacter True 'S' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> showPaddedFixed NoPad padf (realToFrac t :: Pico)
+    formatCharacter False 's' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1
+    formatCharacter True 's' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> let
+        padn = case padf of
+            NoPad -> NoPad
+            Pad _ c -> Pad 2 c
+        in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico)
+    formatCharacter _ _   = Nothing
+
+instance FormatTime CalendarDiffDays where
+    formatCharacter _ 'Y' = Just $ formatNumberStd 1 $ quotBy 12 . cdMonths
+    formatCharacter _ 'B' = Just $ formatNumberStd 1 $ cdMonths
+    formatCharacter _ 'b' = Just $ formatNumberStd 2 $ remBy 12 . cdMonths
+    formatCharacter _ 'W' = Just $ formatNumberStd 1 $ quotBy 7 . cdDays
+    formatCharacter _ 'D' = Just $ formatNumberStd 1 $ cdDays
+    formatCharacter _ 'd' = Just $ formatNumberStd 1 $ remBy 7 . cdDays
+    formatCharacter _ _   = Nothing
+
+instance FormatTime CalendarDiffTime where
+    formatCharacter _ 'Y' = Just $ formatNumberStd 1 $ quotBy 12 . ctMonths
+    formatCharacter _ 'B' = Just $ formatNumberStd 1 $ ctMonths
+    formatCharacter _ 'b' = Just $ formatNumberStd 2 $ remBy 12 . ctMonths
+    formatCharacter alt c = fmap (\f fo t -> f fo (ctTime t)) (formatCharacter alt c)
index 207e8d4..f3e47d0 100644 (file)
@@ -1,84 +1,40 @@
 {-# OPTIONS -fno-warn-orphans #-}
-#include "HsConfigure.h"
+-- #include "HsConfigure.h"
 
 -- #hide
 module Data.Time.Format.Parse
     (
     -- * UNIX-style parsing
-#if LANGUAGE_Rank2Types
     parseTimeM, parseTimeOrError, readSTime, readPTime,
     parseTime, readTime, readsTime,
-#endif
-    ParseTime(..),
+    ParseTime(),
     -- * Locale
     module Data.Time.Format.Locale
     ) where
 
-import Text.Read(readMaybe)
-import Data.Time.Clock.Internal.UniversalTime
-import Data.Time.Clock.POSIX
-import Data.Time.Clock.Internal.UTCTime
-import Data.Time.Calendar.Days
-import Data.Time.Calendar.Gregorian
-import Data.Time.Calendar.OrdinalDate
-import Data.Time.Calendar.WeekDate
-import Data.Time.Calendar.Private(clipValid)
-import Data.Time.LocalTime.Internal.TimeZone
-import Data.Time.LocalTime.Internal.TimeOfDay
-import Data.Time.LocalTime.Internal.LocalTime
-import Data.Time.LocalTime.Internal.ZonedTime
-
+import Data.Proxy
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative ((<$>),(<*>))
 #endif
-#if LANGUAGE_Rank2Types
 import Control.Monad hiding (fail)
-#endif
 #if MIN_VERSION_base(4,9,0)
 import Control.Monad.Fail
 import Prelude hiding (fail)
 #endif
 import Data.Char
-import Data.Fixed
-import Data.List
-import Data.Maybe
-import Data.Ratio
 import Data.Time.Format.Locale
-#if LANGUAGE_Rank2Types
 import Text.ParserCombinators.ReadP hiding (char, string)
-#endif
-
-#if LANGUAGE_Rank2Types
--- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'.
-char :: Char -> ReadP Char
-char c = satisfy (\x -> toUpper c == toUpper x)
--- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'.
-string :: String -> ReadP String
-string this = do s <- look; scan this s
-  where
-    scan []     _                               = do return this
-    scan (x:xs) (y:ys) | toUpper x == toUpper y = do _ <- get; scan xs ys
-    scan _      _                               = do pfail
-#endif
--- | Convert string to upper case.
-up :: String -> String
-up = map toUpper
-
-
--- | The class of types which can be parsed given a UNIX-style time format
--- string.
-class ParseTime t where
-    -- | Builds a time value from a parsed input string.
-    -- 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.
-              -> Maybe t
+import Data.Time.Clock.Internal.UniversalTime
+import Data.Time.Clock.Internal.UTCTime
+import Data.Time.Calendar.Days
+--import Data.Time.LocalTime.Internal.CalendarDiffTime
+import Data.Time.LocalTime.Internal.TimeZone
+import Data.Time.LocalTime.Internal.TimeOfDay
+import Data.Time.LocalTime.Internal.LocalTime
+import Data.Time.LocalTime.Internal.ZonedTime
+import Data.Time.Format.Parse.Class
+import Data.Time.Format.Parse.Instances()
 
-#if LANGUAGE_Rank2Types
 -- | Parses a time value given a format string.
 -- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers, however padding widths are not supported.
 -- Case is not significant in the input string.
@@ -160,16 +116,19 @@ readPTime :: ParseTime t =>
 readPTime False l f = readPOnlyTime l f
 readPTime True l f = (skipSpaces >> readPOnlyTime l f) <++ readPOnlyTime l f
 
+readPOnlyTime' :: ParseTime t => proxy t -> TimeLocale -> String -> ReadP t
+readPOnlyTime' pt l f = do
+    pairs <- parseSpecifiers pt l f
+    case buildTime l pairs of
+        Just t -> return t
+        Nothing -> pfail
+
 -- | Parse a time value given a format string (without allowing leading whitespace).  See 'parseTimeM' for details.
 readPOnlyTime :: ParseTime t =>
              TimeLocale -- ^ Time locale.
           -> String     -- ^ Format string
           -> ReadP t
-readPOnlyTime l f = do
-    pairs <- parseInput l $ parseFormat l f
-    case buildTime l pairs of
-        Just t -> return t
-        Nothing -> pfail
+readPOnlyTime = readPOnlyTime' Proxy
 
 {-# DEPRECATED parseTime "use \"parseTimeM True\" instead" #-}
 parseTime :: ParseTime t =>
@@ -195,434 +154,8 @@ readsTime :: ParseTime t =>
           -> ReadS t
 readsTime = readSTime True
 
-
---
--- * Internals
---
-
-data Padding = NoPadding | SpacePadding | ZeroPadding
-  deriving Show
-
-type DateFormat = [DateFormatSpec]
-
-data DateFormatSpec = Value (Maybe Padding) Char
-                     | WhiteSpace
-                     | Literal Char
-  deriving Show
-
-parseFormat :: TimeLocale -> String -> DateFormat
-parseFormat l = p
-  where p "" = []
-        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 _ [] = return []
-parseInput l (Value mpad c:ff) = do
-  s <- parseValue l mpad c
-  r <- parseInput l ff
-  return ((c,s):r)
-parseInput l (Literal c:ff) = do
-  _ <- char c
-  parseInput l ff
-parseInput l (WhiteSpace:ff) = do
-  _ <- satisfy isSpace
-  case ff of
-     (WhiteSpace:_) -> return ()
-     _ -> skipSpaces
-  parseInput l ff
-
--- | Get the string corresponding to the given format specifier.
-parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String
-parseValue l mpad c =
-    case c of
-      -- century
-      'C' -> digits SpacePadding 2
-      'f' -> digits SpacePadding 2
-
-      -- year
-      'Y' -> digits SpacePadding 4
-      'G' -> digits SpacePadding 4
-
-      -- year of century
-      'y' -> digits ZeroPadding 2
-      'g' -> digits ZeroPadding 2
-
-      -- month of year
-      'B' -> oneOf (map fst (months l))
-      'b' -> oneOf (map snd (months l))
-      'm' -> digits ZeroPadding 2
-
-      -- day of month
-      'd' -> digits ZeroPadding 2
-      'e' -> digits SpacePadding 2
-
-      -- week of year
-      'V' -> digits ZeroPadding 2
-      'U' -> digits ZeroPadding 2
-      'W' -> digits ZeroPadding 2
-
-      -- day of week
-      'u' -> oneOf $ map (:[]) ['1'..'7']
-      'a' -> oneOf (map snd (wDays l))
-      'A' -> oneOf (map fst (wDays l))
-      'w' -> oneOf $ map (:[]) ['0'..'6']
-
-      -- day of year
-      'j' -> digits ZeroPadding 3
-
-      -- dayhalf of day (i.e. AM or PM)
-      'P' -> oneOf (let (am,pm) = amPm l in [am, pm])
-      'p' -> oneOf (let (am,pm) = amPm l in [am, pm])
-
-      -- hour of day (i.e. 24h)
-      'H' -> digits ZeroPadding 2
-      'k' -> digits SpacePadding 2
-
-      -- hour of dayhalf (i.e. 12h)
-      'I' -> digits ZeroPadding 2
-      'l' -> digits SpacePadding 2
-
-      -- minute of hour
-      'M' -> digits ZeroPadding 2
-
-      -- second of minute
-      'S' -> digits ZeroPadding 2
-
-      -- picosecond of second
-      'q' -> digits ZeroPadding 12
-      'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return ""
-
-      -- time zone
-      'z' -> numericTZ
-      'Z' -> munch1 isAlpha <++
-             numericTZ
-
-      -- seconds since epoch
-      's' -> (char '-' >> liftM ('-':) (munch1 isDigit))
-             <++ munch1 isDigit
-
-      _   -> fail $ "Unknown format character: " ++ show c
-  where
-    oneOf = choice . map string
-    digitsforce ZeroPadding n = count n (satisfy isDigit)
-    digitsforce SpacePadding _n = skipSpaces >> many1 (satisfy isDigit)
-    digitsforce NoPadding _n = many1 (satisfy isDigit)
-    digits pad = digitsforce (fromMaybe pad mpad)
-    numericTZ = do s <- choice [char '+', char '-']
-                   h <- digitsforce ZeroPadding 2
-                   optional (char ':')
-                   m <- digitsforce ZeroPadding 2
-                   return (s:h++m)
-#endif
-
---
--- * Instances for the time package types
---
-
-data DayComponent = Century Integer -- century of all years
-                  | CenturyYear Integer -- 0-99, last two digits of both real years and week years
-                  | YearMonth Int -- 1-12
-                  | MonthDay Int -- 1-31
-                  | YearDay Int -- 1-366
-                  | WeekDay Int -- 1-7 (mon-sun)
-                  | YearWeek WeekType Int -- 1-53 or 0-53
-
-data WeekType = ISOWeek | SundayWeek | MondayWeek
-
-instance ParseTime Day where
-    buildTime l = let
-
-        -- 'Nothing' indicates a parse failure,
-        -- while 'Just []' means no information
-        f :: Char -> String -> Maybe [DayComponent]
-        f c x = let
-            ra :: (Read a) => Maybe a
-            ra = readMaybe x
-
-            zeroBasedListIndex :: [String] -> Maybe Int
-            zeroBasedListIndex ss = elemIndex (up x) $ fmap up ss
-
-            oneBasedListIndex :: [String] -> Maybe Int
-            oneBasedListIndex ss = do
-                index <- zeroBasedListIndex ss
-                return $ 1 + index
-
-            in case c of
-            -- %C: century (all but the last two digits of the year), 00 - 99
-            'C' -> do
-                a <- ra
-                return [Century a]
-            -- %f century (all but the last two digits of the year), 00 - 99
-            'f' -> do
-                a <- ra
-                return [Century a]
-            -- %Y: year
-            'Y' -> do
-                a <- ra
-                return [Century (a `div` 100), CenturyYear (a `mod` 100)]
-            -- %G: year for Week Date format
-            'G' -> do
-                a <- ra
-                return [Century (a `div` 100), CenturyYear (a `mod` 100)]
-            -- %y: last two digits of year, 00 - 99
-            'y' -> do
-                a <- ra
-                return [CenturyYear a]
-            -- %g: last two digits of year for Week Date format, 00 - 99
-            'g' -> do
-                a <- ra
-                return [CenturyYear a]
-            -- %B: month name, long form (fst from months locale), January - December
-            'B' -> do
-                a <- oneBasedListIndex $ fmap fst $ months l
-                return [YearMonth a]
-            -- %b: month name, short form (snd from months locale), Jan - Dec
-            'b' -> do
-                a <- oneBasedListIndex $ fmap snd $ months l
-                return [YearMonth a]
-            -- %m: month of year, leading 0 as needed, 01 - 12
-            'm' -> do
-                raw <- ra
-                a <- clipValid 1 12 raw
-                return [YearMonth a]
-            -- %d: day of month, leading 0 as needed, 01 - 31
-            'd' -> do
-                raw <- ra
-                a <- clipValid 1 31 raw
-                return [MonthDay a]
-            -- %e: day of month, leading space as needed, 1 - 31
-            'e' -> do
-                raw <- ra
-                a <- clipValid 1 31 raw
-                return [MonthDay a]
-            -- %V: week for Week Date format, 01 - 53
-            'V' -> do
-                raw <- ra
-                a <- clipValid 1 53 raw
-                return [YearWeek ISOWeek a]
-            -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53
-            'U' -> do
-                raw <- ra
-                a <- clipValid 0 53 raw
-                return [YearWeek SundayWeek a]
-            -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53
-            'W' -> do
-                raw <- ra
-                a <- clipValid 0 53 raw
-                return [YearWeek MondayWeek a]
-            -- %u: day for Week Date format, 1 - 7
-            'u' -> do
-                raw <- ra
-                a <- clipValid 1 7 raw
-                return [WeekDay a]
-            -- %a: day of week, short form (snd from wDays locale), Sun - Sat
-            'a' -> do
-                a' <- zeroBasedListIndex $ fmap snd $ wDays l
-                let a = if a' == 0 then 7 else a'
-                return [WeekDay a]
-            -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday
-            'A' -> do
-                a' <- zeroBasedListIndex $ fmap fst $ wDays l
-                let a = if a' == 0 then 7 else a'
-                return [WeekDay a]
-            -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
-            'w' -> do
-                raw <- ra
-                a' <- clipValid 0 6 raw
-                let a = if a' == 0 then 7 else a'
-                return [WeekDay a]
-            -- %j: day of year for Ordinal Date format, 001 - 366
-            'j' -> do
-                raw <- ra
-                a <- clipValid 1 366 raw
-                return [YearDay a]
-            -- unrecognised, pass on to other parsers
-            _   -> return []
-
-        buildDay :: [DayComponent] -> Maybe Day
-        buildDay cs = let
-            safeLast x xs = last (x:xs)
-            y = let
-                d = safeLast 70 [x | CenturyYear x <- cs]
-                c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs]
-                in 100 * c + d
-            rest (YearMonth m:_) = let
-                d = safeLast 1 [x | MonthDay x <- cs]
-                in fromGregorianValid y m d
-            rest (YearDay d:_) = fromOrdinalDateValid y d
-            rest (YearWeek wt w:_) = let
-                d = safeLast 4 [x | WeekDay x <- cs]
-                in case wt of
-                    ISOWeek    -> fromWeekDateValid y w d
-                    SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
-                    MondayWeek -> fromMondayStartWeekValid y w d
-            rest (_:xs)        = rest xs
-            rest []            = rest [YearMonth 1]
-
-            in rest cs
-
-        in \pairs -> do
-            components <- mapM (uncurry f) pairs
-            buildDay $ concat components
-
-mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
-mfoldl f = let
-    mf ma b = do
-        a <- ma
-        f a b
-    in foldl mf
-
-instance ParseTime TimeOfDay where
-    buildTime l = let
-        f t@(TimeOfDay h m s) (c,x) = let
-            ra :: (Read a) => Maybe a
-            ra = readMaybe x
-
-            getAmPm = let
-                upx = up x
-                (amStr,pmStr) = amPm l
-                in if upx == amStr
-                    then Just $ TimeOfDay (h `mod` 12) m s
-                    else if upx == pmStr
-                    then Just $ TimeOfDay (if h < 12 then h + 12 else h) m s
-                    else Nothing
-
-            in case c of
-                'P' -> getAmPm
-                'p' -> getAmPm
-                'H' -> do
-                    raw <- ra
-                    a <- clipValid 0 23 raw
-                    return $ TimeOfDay a m s
-                'I' -> do
-                    raw <- ra
-                    a <- clipValid 1 12 raw
-                    return $ TimeOfDay a m s
-                'k' -> do
-                    raw <- ra
-                    a <- clipValid 0 23 raw
-                    return $ TimeOfDay a m s
-                'l' -> do
-                    raw <- ra
-                    a <- clipValid 1 12 raw
-                    return $ TimeOfDay a m s
-                'M' -> do
-                    raw <- ra
-                    a <- clipValid 0 59 raw
-                    return $ TimeOfDay h a s
-                'S' -> do
-                    raw <- ra
-                    a <- clipValid 0 60 raw
-                    return $ TimeOfDay h m (fromInteger a)
-                'q' -> do
-                    a <- ra
-                    return $ TimeOfDay h m (mkPico (floor s) a)
-                'Q' -> if null x then Just t else do
-                    ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x
-                    return $ TimeOfDay h m (mkPico (floor s) ps)
-                _   -> Just t
-
-        in mfoldl f (Just midnight)
-
-rpad :: Int -> a -> [a] -> [a]
-rpad n c xs = xs ++ replicate (n - length xs) c
-
-mkPico :: Integer -> Integer -> Pico
-mkPico i f = fromInteger i + fromRational (f % 1000000000000)
-
-instance ParseTime LocalTime where
-    buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs)
-
-enumDiff :: (Enum a) => a -> a -> Int
-enumDiff a b = (fromEnum a) - (fromEnum b)
-
-getMilZoneHours :: Char -> Maybe Int
-getMilZoneHours c | c < 'A' = Nothing
-getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A'
-getMilZoneHours 'J' = Nothing
-getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K'
-getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1
-getMilZoneHours 'Z' = Just 0
-getMilZoneHours _ = Nothing
-
-getMilZone :: Char -> Maybe TimeZone
-getMilZone c = let
-    yc = toUpper c
-    in do
-        hours <- getMilZoneHours yc
-        return $ TimeZone (hours * 60) False [yc]
-
-getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
-getKnownTimeZone locale x = find (\tz -> up x == timeZoneName tz) (knownTimeZones locale)
-
-instance ParseTime TimeZone where
-    buildTime l = let
-        f :: Char -> String -> TimeZone -> Maybe TimeZone
-        f 'z' str (TimeZone _ dst name) | Just offset <- readTzOffset str = Just $ TimeZone offset dst name
-        f 'z' _ _ = Nothing
-        f 'Z' str _ | Just offset <- readTzOffset str = Just $ TimeZone offset False ""
-        f 'Z' str _ | Just zone <- getKnownTimeZone l str = Just zone
-        f 'Z' "UTC" _ = Just utc
-        f 'Z' [c] _ | Just zone <- getMilZone c = Just zone
-        f 'Z' _ _ = Nothing
-        f _ _ tz = Just tz
-        in foldl (\mt (c,s) -> mt >>= f c s) (Just $ minutesToTimeZone 0)
-
-readTzOffset :: String -> Maybe Int
-readTzOffset str = let
-
-    getSign '+' = Just 1
-    getSign '-' = Just (-1)
-    getSign _ = Nothing
-
-    calc s h1 h2 m1 m2 = do
-        sign <- getSign s
-        h <- readMaybe [h1,h2]
-        m <- readMaybe [m1,m2]
-        return $ sign * (60 * h + m)
-
-    in case str of
-        (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2
-        (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2
-        _ -> Nothing
-
-instance ParseTime ZonedTime where
-    buildTime l xs = let
-        f (ZonedTime (LocalTime _ tod) z) ('s',x) = do
-            a <- readMaybe x
-            let
-                s = fromInteger a
-                (_,ps) = properFraction (todSec tod) :: (Integer,Pico)
-                s' = s + fromRational (toRational ps)
-            return $ utcToZonedTime z (posixSecondsToUTCTime s')
-        f t _ = Just t
-        in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs
-
-instance ParseTime UTCTime where
-    buildTime l xs = zonedTimeToUTC <$> buildTime l xs
-
-instance ParseTime UniversalTime where
-    buildTime l xs = localTimeToUT1 0 <$> buildTime l xs
-
 -- * Read instances for time package types
 
-#if LANGUAGE_Rank2Types
 instance Read Day where
     readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Y-%m-%d"
 
@@ -644,4 +177,3 @@ instance Read UTCTime where
 
 instance Read UniversalTime where
     readsPrec n s = [ (localTimeToUT1 0 t, r) | (t,r) <- readsPrec n s ]
-#endif
diff --git a/lib/Data/Time/Format/Parse/Class.hs b/lib/Data/Time/Format/Parse/Class.hs
new file mode 100644 (file)
index 0000000..3397e81
--- /dev/null
@@ -0,0 +1,220 @@
+module Data.Time.Format.Parse.Class
+    (
+        -- * Parsing
+        ParseNumericPadding(..),
+        ParseTime(..),
+        parseSpecifiers,
+        timeSubstituteTimeSpecifier,
+        timeParseTimeSpecifier,
+        durationParseTimeSpecifier,
+    )
+    where
+
+import Control.Applicative hiding (optional,many)
+import Data.Char
+import Data.Maybe
+import Data.Time.Format.Locale
+import Text.ParserCombinators.ReadP
+
+data ParseNumericPadding = NoPadding | SpacePadding | ZeroPadding
+
+-- | The class of types which can be parsed given a UNIX-style time format
+-- string.
+class ParseTime t where
+    substituteTimeSpecifier :: proxy t -> TimeLocale -> Char -> Maybe String
+    substituteTimeSpecifier _ _ _ = Nothing
+    -- | Get the string corresponding to the given format specifier.
+    parseTimeSpecifier :: proxy t -> TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
+    -- | Builds a time value from a parsed input string.
+    -- 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.
+              -> Maybe t
+
+-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'.
+charCI :: Char -> ReadP Char
+charCI c = satisfy (\x -> toUpper c == toUpper x)
+
+-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'.
+stringCI :: String -> ReadP String
+stringCI this = do
+    let
+        scan [] _ = return this
+        scan (x:xs) (y:ys) | toUpper x == toUpper y = do
+            _ <- get
+            scan xs ys
+        scan _ _ = pfail
+    s <- look
+    scan this s
+
+parseSpecifiers :: ParseTime t => proxy t -> TimeLocale -> String -> ReadP [(Char,String)]
+parseSpecifiers pt locale = let
+    parse :: String -> ReadP [(Char,String)]
+    parse [] = return []
+    parse ('%':cs) = parse1 cs
+    parse (c:cs) | isSpace c = do
+        _ <- satisfy isSpace
+        case cs of
+            (c':_) | isSpace c' -> return ()
+            _ -> skipSpaces
+        parse cs
+    parse (c:cs) = do
+        _ <- charCI c
+        parse cs
+
+    parse1 :: String -> ReadP [(Char,String)]
+    parse1 ('-':cs) = parse2 (Just NoPadding) cs
+    parse1 ('_':cs) = parse2 (Just SpacePadding) cs
+    parse1 ('0':cs) = parse2 (Just ZeroPadding) cs
+    parse1 cs = parse2 Nothing cs
+
+    parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char,String)]
+    parse2 mpad ('E':cs) = parse3 mpad True cs
+    parse2 mpad cs = parse3 mpad False cs
+
+    parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char,String)]
+    parse3 _ _ ('%':cs) = do
+        _ <- char '%'
+        parse cs
+    parse3 _ _ (c:cs) | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs
+    parse3 mpad _alt (c:cs) = do
+        str <- parseTimeSpecifier pt locale mpad c
+        specs <- parse cs
+        return $ (c,str) : specs
+    parse3 _ _ [] = return []
+    in parse
+
+parsePaddedDigits :: ParseNumericPadding -> Int -> ReadP String
+parsePaddedDigits ZeroPadding n = count n (satisfy isDigit)
+parsePaddedDigits SpacePadding _n = skipSpaces >> many1 (satisfy isDigit)
+parsePaddedDigits NoPadding _n = many1 (satisfy isDigit)
+
+parsePaddedSignedDigits :: ParseNumericPadding -> Int -> ReadP String
+parsePaddedSignedDigits pad n = do
+    sign <- option "" $ char '-' >> return "-"
+    digits <- parsePaddedDigits pad n
+    return $ sign ++ digits
+
+parseSignedDecimal :: ReadP String
+parseSignedDecimal = do
+    sign <- option "" $ char '-' >> return "-"
+    skipSpaces
+    digits <- many1 $ satisfy isDigit
+    decimaldigits <- option "" $ do
+        _ <- char '.'
+        dd <- many $ satisfy isDigit
+        return $ '.':dd
+    return $ sign ++ digits ++ decimaldigits
+
+timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
+timeParseTimeSpecifier l mpad c = let
+    digits pad = parsePaddedDigits (fromMaybe pad mpad)
+    oneOf = choice . map stringCI
+    numericTZ = do
+        s <- choice [char '+', char '-']
+        h <- parsePaddedDigits ZeroPadding 2
+        optional (char ':')
+        m <- parsePaddedDigits ZeroPadding 2
+        return (s:h++m)
+    in case c of
+        -- century
+        'C' -> digits SpacePadding 2
+        'f' -> digits SpacePadding 2
+
+        -- year
+        'Y' -> digits SpacePadding 4
+        'G' -> digits SpacePadding 4
+
+        -- year of century
+        'y' -> digits ZeroPadding 2
+        'g' -> digits ZeroPadding 2
+
+        -- month of year
+        'B' -> oneOf (map fst (months l))
+        'b' -> oneOf (map snd (months l))
+        'm' -> digits ZeroPadding 2
+
+        -- day of month
+        'd' -> digits ZeroPadding 2
+        'e' -> digits SpacePadding 2
+
+        -- week of year
+        'V' -> digits ZeroPadding 2
+        'U' -> digits ZeroPadding 2
+        'W' -> digits ZeroPadding 2
+
+        -- day of week
+        'u' -> oneOf $ map (:[]) ['1'..'7']
+        'a' -> oneOf (map snd (wDays l))
+        'A' -> oneOf (map fst (wDays l))
+        'w' -> oneOf $ map (:[]) ['0'..'6']
+
+        -- day of year
+        'j' -> digits ZeroPadding 3
+
+        -- dayhalf of day (i.e. AM or PM)
+        'P' -> oneOf (let (am,pm) = amPm l in [am, pm])
+        'p' -> oneOf (let (am,pm) = amPm l in [am, pm])
+
+        -- hour of day (i.e. 24h)
+        'H' -> digits ZeroPadding 2
+        'k' -> digits SpacePadding 2
+
+        -- hour of dayhalf (i.e. 12h)
+        'I' -> digits ZeroPadding 2
+        'l' -> digits SpacePadding 2
+
+        -- minute of hour
+        'M' -> digits ZeroPadding 2
+
+        -- second of minute
+        'S' -> digits ZeroPadding 2
+
+        -- picosecond of second
+        'q' -> digits ZeroPadding 12
+        'Q' -> liftA2 (:) (char '.') (munch isDigit) <++ return ""
+
+        -- time zone
+        'z' -> numericTZ
+        'Z' -> munch1 isAlpha <++
+             numericTZ
+
+        -- seconds since epoch
+        's' -> (char '-' >> fmap ('-':) (munch1 isDigit))
+             <++ munch1 isDigit
+
+        _   -> fail $ "Unknown format character: " ++ show c
+
+timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String
+timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l
+timeSubstituteTimeSpecifier _ 'R' = Just "%H:%M"
+timeSubstituteTimeSpecifier _ 'T' = Just "%H:%M:%S"
+timeSubstituteTimeSpecifier l 'X' = Just $ timeFmt l
+timeSubstituteTimeSpecifier l 'r' = Just $ time12Fmt l
+timeSubstituteTimeSpecifier _ 'D' = Just "%m/%d/%y"
+timeSubstituteTimeSpecifier _ 'F' = Just "%Y-%m-%d"
+timeSubstituteTimeSpecifier l 'x' = Just $ dateFmt l
+timeSubstituteTimeSpecifier _ 'h' = Just "%b"
+timeSubstituteTimeSpecifier _  _ = Nothing
+
+durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
+durationParseTimeSpecifier _ mpad c = let
+    padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad
+    in case c of
+        'Y' -> padopt 1
+        'B' -> padopt 1
+        'b' -> padopt 2
+        'W' -> padopt 1
+        'D' -> padopt 1
+        'd' -> padopt 1
+        'H' -> padopt 1
+        'h' -> padopt 2
+        'M' -> padopt 1
+        'm' -> padopt 2
+        'S' -> parseSignedDecimal
+        's' -> parseSignedDecimal
+        _   -> fail $ "Unknown format character: " ++ show c
diff --git a/lib/Data/Time/Format/Parse/Instances.hs b/lib/Data/Time/Format/Parse/Instances.hs
new file mode 100644 (file)
index 0000000..92df1d5
--- /dev/null
@@ -0,0 +1,390 @@
+{-# OPTIONS -fno-warn-orphans #-}
+-- #include "HsConfigure.h"
+module Data.Time.Format.Parse.Instances() where
+
+import Data.Char
+import Data.Fixed
+import Data.List
+import Data.Ratio
+import Data.Traversable
+import Text.Read(readMaybe)
+import Data.Time.Clock.Internal.DiffTime
+import Data.Time.Clock.Internal.NominalDiffTime
+import Data.Time.Clock.Internal.UniversalTime
+import Data.Time.Clock.POSIX
+import Data.Time.Clock.Internal.UTCTime
+import Data.Time.Calendar.Days
+import Data.Time.Calendar.Gregorian
+import Data.Time.Calendar.CalendarDiffDays
+import Data.Time.Calendar.OrdinalDate
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.Private(clipValid)
+import Data.Time.LocalTime.Internal.CalendarDiffTime
+import Data.Time.LocalTime.Internal.TimeZone
+import Data.Time.LocalTime.Internal.TimeOfDay
+import Data.Time.LocalTime.Internal.LocalTime
+import Data.Time.LocalTime.Internal.ZonedTime
+import Data.Time.Format.Locale
+import Data.Time.Format.Parse.Class
+
+data DayComponent = Century Integer -- century of all years
+                  | CenturyYear Integer -- 0-99, last two digits of both real years and week years
+                  | YearMonth Int -- 1-12
+                  | MonthDay Int -- 1-31
+                  | YearDay Int -- 1-366
+                  | WeekDay Int -- 1-7 (mon-sun)
+                  | YearWeek WeekType Int -- 1-53 or 0-53
+
+data WeekType = ISOWeek | SundayWeek | MondayWeek
+
+instance ParseTime Day where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l = let
+
+        -- 'Nothing' indicates a parse failure,
+        -- while 'Just []' means no information
+        f :: Char -> String -> Maybe [DayComponent]
+        f c x = let
+            ra :: (Read a) => Maybe a
+            ra = readMaybe x
+
+            zeroBasedListIndex :: [String] -> Maybe Int
+            zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss
+
+            oneBasedListIndex :: [String] -> Maybe Int
+            oneBasedListIndex ss = do
+                index <- zeroBasedListIndex ss
+                return $ 1 + index
+
+            in case c of
+            -- %C: century (all but the last two digits of the year), 00 - 99
+            'C' -> do
+                a <- ra
+                return [Century a]
+            -- %f century (all but the last two digits of the year), 00 - 99
+            'f' -> do
+                a <- ra
+                return [Century a]
+            -- %Y: year
+            'Y' -> do
+                a <- ra
+                return [Century (a `div` 100), CenturyYear (a `mod` 100)]
+            -- %G: year for Week Date format
+            'G' -> do
+                a <- ra
+                return [Century (a `div` 100), CenturyYear (a `mod` 100)]
+            -- %y: last two digits of year, 00 - 99
+            'y' -> do
+                a <- ra
+                return [CenturyYear a]
+            -- %g: last two digits of year for Week Date format, 00 - 99
+            'g' -> do
+                a <- ra
+                return [CenturyYear a]
+            -- %B: month name, long form (fst from months locale), January - December
+            'B' -> do
+                a <- oneBasedListIndex $ fmap fst $ months l
+                return [YearMonth a]
+            -- %b: month name, short form (snd from months locale), Jan - Dec
+            'b' -> do
+                a <- oneBasedListIndex $ fmap snd $ months l
+                return [YearMonth a]
+            -- %m: month of year, leading 0 as needed, 01 - 12
+            'm' -> do
+                raw <- ra
+                a <- clipValid 1 12 raw
+                return [YearMonth a]
+            -- %d: day of month, leading 0 as needed, 01 - 31
+            'd' -> do
+                raw <- ra
+                a <- clipValid 1 31 raw
+                return [MonthDay a]
+            -- %e: day of month, leading space as needed, 1 - 31
+            'e' -> do
+                raw <- ra
+                a <- clipValid 1 31 raw
+                return [MonthDay a]
+            -- %V: week for Week Date format, 01 - 53
+            'V' -> do
+                raw <- ra
+                a <- clipValid 1 53 raw
+                return [YearWeek ISOWeek a]
+            -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53
+            'U' -> do
+                raw <- ra
+                a <- clipValid 0 53 raw
+                return [YearWeek SundayWeek a]
+            -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53
+            'W' -> do
+                raw <- ra
+                a <- clipValid 0 53 raw
+                return [YearWeek MondayWeek a]
+            -- %u: day for Week Date format, 1 - 7
+            'u' -> do
+                raw <- ra
+                a <- clipValid 1 7 raw
+                return [WeekDay a]
+            -- %a: day of week, short form (snd from wDays locale), Sun - Sat
+            'a' -> do
+                a' <- zeroBasedListIndex $ fmap snd $ wDays l
+                let a = if a' == 0 then 7 else a'
+                return [WeekDay a]
+            -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday
+            'A' -> do
+                a' <- zeroBasedListIndex $ fmap fst $ wDays l
+                let a = if a' == 0 then 7 else a'
+                return [WeekDay a]
+            -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
+            'w' -> do
+                raw <- ra
+                a' <- clipValid 0 6 raw
+                let a = if a' == 0 then 7 else a'
+                return [WeekDay a]
+            -- %j: day of year for Ordinal Date format, 001 - 366
+            'j' -> do
+                raw <- ra
+                a <- clipValid 1 366 raw
+                return [YearDay a]
+            -- unrecognised, pass on to other parsers
+            _   -> return []
+
+        buildDay :: [DayComponent] -> Maybe Day
+        buildDay cs = let
+            safeLast x xs = last (x:xs)
+            y = let
+                d = safeLast 70 [x | CenturyYear x <- cs]
+                c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs]
+                in 100 * c + d
+            rest (YearMonth m:_) = let
+                d = safeLast 1 [x | MonthDay x <- cs]
+                in fromGregorianValid y m d
+            rest (YearDay d:_) = fromOrdinalDateValid y d
+            rest (YearWeek wt w:_) = let
+                d = safeLast 4 [x | WeekDay x <- cs]
+                in case wt of
+                    ISOWeek    -> fromWeekDateValid y w d
+                    SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
+                    MondayWeek -> fromMondayStartWeekValid y w d
+            rest (_:xs)        = rest xs
+            rest []            = rest [YearMonth 1]
+
+            in rest cs
+
+        in \pairs -> do
+            components <- mapM (uncurry f) pairs
+            buildDay $ concat components
+
+mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
+mfoldl f = let
+    mf ma b = do
+        a <- ma
+        f a b
+    in foldl mf
+
+instance ParseTime TimeOfDay where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l = let
+        f t@(TimeOfDay h m s) (c,x) = let
+            ra :: (Read a) => Maybe a
+            ra = readMaybe x
+
+            getAmPm = let
+                upx = map toUpper x
+                (amStr,pmStr) = amPm l
+                in if upx == amStr
+                    then Just $ TimeOfDay (h `mod` 12) m s
+                    else if upx == pmStr
+                    then Just $ TimeOfDay (if h < 12 then h + 12 else h) m s
+                    else Nothing
+
+            in case c of
+                'P' -> getAmPm
+                'p' -> getAmPm
+                'H' -> do
+                    raw <- ra
+                    a <- clipValid 0 23 raw
+                    return $ TimeOfDay a m s
+                'I' -> do
+                    raw <- ra
+                    a <- clipValid 1 12 raw
+                    return $ TimeOfDay a m s
+                'k' -> do
+                    raw <- ra
+                    a <- clipValid 0 23 raw
+                    return $ TimeOfDay a m s
+                'l' -> do
+                    raw <- ra
+                    a <- clipValid 1 12 raw
+                    return $ TimeOfDay a m s
+                'M' -> do
+                    raw <- ra
+                    a <- clipValid 0 59 raw
+                    return $ TimeOfDay h a s
+                'S' -> do
+                    raw <- ra
+                    a <- clipValid 0 60 raw
+                    return $ TimeOfDay h m (fromInteger a)
+                'q' -> do
+                    a <- ra
+                    return $ TimeOfDay h m (mkPico (floor s) a)
+                'Q' -> if null x then Just t else do
+                    ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x
+                    return $ TimeOfDay h m (mkPico (floor s) ps)
+                _   -> Just t
+
+        in mfoldl f (Just midnight)
+
+rpad :: Int -> a -> [a] -> [a]
+rpad n c xs = xs ++ replicate (n - length xs) c
+
+mkPico :: Integer -> Integer -> Pico
+mkPico i f = fromInteger i + fromRational (f % 1000000000000)
+
+instance ParseTime LocalTime where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs)
+
+enumDiff :: (Enum a) => a -> a -> Int
+enumDiff a b = (fromEnum a) - (fromEnum b)
+
+getMilZoneHours :: Char -> Maybe Int
+getMilZoneHours c | c < 'A' = Nothing
+getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A'
+getMilZoneHours 'J' = Nothing
+getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K'
+getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1
+getMilZoneHours 'Z' = Just 0
+getMilZoneHours _ = Nothing
+
+getMilZone :: Char -> Maybe TimeZone
+getMilZone c = let
+    yc = toUpper c
+    in do
+        hours <- getMilZoneHours yc
+        return $ TimeZone (hours * 60) False [yc]
+
+getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
+getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale)
+
+instance ParseTime TimeZone where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l = let
+        f :: Char -> String -> TimeZone -> Maybe TimeZone
+        f 'z' str (TimeZone _ dst name) | Just offset <- readTzOffset str = Just $ TimeZone offset dst name
+        f 'z' _ _ = Nothing
+        f 'Z' str _ | Just offset <- readTzOffset str = Just $ TimeZone offset False ""
+        f 'Z' str _ | Just zone <- getKnownTimeZone l str = Just zone
+        f 'Z' "UTC" _ = Just utc
+        f 'Z' [c] _ | Just zone <- getMilZone c = Just zone
+        f 'Z' _ _ = Nothing
+        f _ _ tz = Just tz
+        in foldl (\mt (c,s) -> mt >>= f c s) (Just $ minutesToTimeZone 0)
+
+readTzOffset :: String -> Maybe Int
+readTzOffset str = let
+
+    getSign '+' = Just 1
+    getSign '-' = Just (-1)
+    getSign _ = Nothing
+
+    calc s h1 h2 m1 m2 = do
+        sign <- getSign s
+        h <- readMaybe [h1,h2]
+        m <- readMaybe [m1,m2]
+        return $ sign * (60 * h + m)
+
+    in case str of
+        (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2
+        (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2
+        _ -> Nothing
+
+instance ParseTime ZonedTime where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l xs = let
+        f (ZonedTime (LocalTime _ tod) z) ('s',x) = do
+            a <- readMaybe x
+            let
+                s = fromInteger a
+                (_,ps) = properFraction (todSec tod) :: (Integer,Pico)
+                s' = s + fromRational (toRational ps)
+            return $ utcToZonedTime z (posixSecondsToUTCTime s')
+        f t _ = Just t
+        in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs
+
+instance ParseTime UTCTime where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l xs = zonedTimeToUTC <$> buildTime l xs
+
+instance ParseTime UniversalTime where
+    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
+    parseTimeSpecifier _ = timeParseTimeSpecifier
+    buildTime l xs = localTimeToUT1 0 <$> buildTime l xs
+
+buildTimeMonths :: [(Char,String)] -> Maybe Integer
+buildTimeMonths xs = do
+    tt <- for xs $ \(c,s) -> case c of
+        'Y' -> fmap ((*) 12) $ readMaybe s
+        'B' -> readMaybe s
+        'b' -> readMaybe s
+        _ -> return 0
+    return $ sum tt
+
+buildTimeDays :: [(Char,String)] -> Maybe Integer
+buildTimeDays xs = do
+    tt <- for xs $ \(c,s) -> case c of
+        'W' -> fmap ((*) 7) $ readMaybe s
+        'D' -> readMaybe s
+        'd' -> readMaybe s
+        _ -> return 0
+    return $ sum tt
+
+buildTimeSeconds :: [(Char,String)] -> Maybe Pico
+buildTimeSeconds xs = do
+    tt <- for xs $ \(c,s) -> let
+        readInt :: Integer -> Maybe Pico
+        readInt t = do
+            i <- readMaybe s
+            return $ fromInteger $ i * t
+        in case c of
+            'H' -> readInt 3600
+            'h' -> readInt 3600
+            'M' -> readInt 60
+            'm' -> readInt 60
+            'S' -> readMaybe s
+            's' -> readMaybe s
+            _ -> return 0
+    return $ sum tt
+
+instance ParseTime NominalDiffTime where
+    parseTimeSpecifier _ = durationParseTimeSpecifier
+    buildTime _ xs = do
+        dd <- buildTimeDays xs
+        tt <- buildTimeSeconds xs
+        return $ (fromInteger dd * 86400) + realToFrac tt
+
+instance ParseTime DiffTime where
+    parseTimeSpecifier _ = durationParseTimeSpecifier
+    buildTime _ xs = do
+        dd <- buildTimeDays xs
+        tt <- buildTimeSeconds xs
+        return $ (fromInteger dd * 86400) + realToFrac tt
+
+instance ParseTime CalendarDiffDays where
+    parseTimeSpecifier _ = durationParseTimeSpecifier
+    buildTime _ xs = do
+        mm <- buildTimeMonths xs
+        dd <- buildTimeDays xs
+        return $ CalendarDiffDays mm dd
+
+instance ParseTime CalendarDiffTime where
+    parseTimeSpecifier _ = durationParseTimeSpecifier
+    buildTime locale xs = do
+        mm <- buildTimeMonths xs
+        tt <- buildTime locale xs
+        return $ CalendarDiffTime mm tt
index 3987603..8c88df9 100644 (file)
@@ -100,19 +100,29 @@ testAFormat fmt expected t = testCase fmt $ assertEqual "" expected $ formatTime
 testNominalDiffTime :: TestTree
 testNominalDiffTime = testGroup "NominalDiffTime"
     [
-        testAFormat "%Ww%dd%hh%mm%s%Qs" "3w2d2h22m8.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime),
-        testAFormat "%Dd %Hh %Mm %S%Qs" "23d 554h 33262m 1995728.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime),
-        testAFormat "%Ww%dd%hh%mm%s%Qs" "-3w-2d-2h-22m-8.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime),
-        testAFormat "%Dd %Hh %Mm %S%Qs" "-23d -554h -33262m -1995728.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime)
+        testAFormat "%Ww%dd%hh%mm%Ess" "3w2d2h22m8.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime),
+        testAFormat "%Dd %Hh %Mm %Ss %ESs" "0d 0h 0m 0s 0.74s" $ (fromRational $ 0.74 :: NominalDiffTime),
+        testAFormat "%Dd %Hh %Mm %Ss %ESs" "0d 0h 0m 0s -0.74s" $ (fromRational $ negate $ 0.74 :: NominalDiffTime),
+        testAFormat "%Dd %Hh %Mm %Ss %ESs %0ESs" "23d 554h 33262m 1995728s 1995728.21s 1995728.210000000000s" $ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime),
+        testAFormat "%Ww%dd%hh%mm%ss" "-3w-2d-2h-22m-8s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime),
+        testAFormat "%Ww%dd%hh%mm%Ess" "-3w-2d-2h-22m-8.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime),
+        testAFormat "%Ww%dd%hh%mm%ss" "-3w-2d-2h-22m0s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime),
+        testAFormat "%Ww%dd%hh%mm%Ess" "-3w-2d-2h-22m-0.21s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime),
+        testAFormat "%Dd %Hh %Mm %ESs" "-23d -554h -33262m -1995728.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime)
     ]
 
 testDiffTime :: TestTree
 testDiffTime = testGroup "DiffTime"
     [
-        testAFormat "%Ww%dd%hh%mm%s%Qs" "3w2d2h22m8.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime),
-        testAFormat "%Dd %Hh %Mm %S%Qs" "23d 554h 33262m 1995728.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime),
-        testAFormat "%Ww%dd%hh%mm%s%Qs" "-3w-2d-2h-22m-8.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime),
-        testAFormat "%Dd %Hh %Mm %S%Qs" "-23d -554h -33262m -1995728.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime)
+        testAFormat "%Ww%dd%hh%mm%Ess" "3w2d2h22m8.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime),
+        testAFormat "%Dd %Hh %Mm %Ss %ESs" "0d 0h 0m 0s 0.74s" $ (fromRational $ 0.74 :: DiffTime),
+        testAFormat "%Dd %Hh %Mm %Ss %ESs" "0d 0h 0m 0s -0.74s" $ (fromRational $ negate $ 0.74 :: DiffTime),
+        testAFormat "%Dd %Hh %Mm %Ss %ESs %0ESs" "23d 554h 33262m 1995728s 1995728.21s 1995728.210000000000s" $ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime),
+        testAFormat "%Ww%dd%hh%mm%ss" "-3w-2d-2h-22m-8s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime),
+        testAFormat "%Ww%dd%hh%mm%Ess" "-3w-2d-2h-22m-8.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime),
+        testAFormat "%Ww%dd%hh%mm%ss" "-3w-2d-2h-22m0s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime),
+        testAFormat "%Ww%dd%hh%mm%Ess" "-3w-2d-2h-22m-0.21s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime),
+        testAFormat "%Dd %Hh %Mm %ESs" "-23d -554h -33262m -1995728.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime)
     ]
 
 testCalenderDiffDays :: TestTree
@@ -127,10 +137,13 @@ testCalenderDiffDays = testGroup "CalenderDiffDays"
 testCalenderDiffTime :: TestTree
 testCalenderDiffTime = testGroup "CalenderDiffTime"
     [
-        testAFormat "%Yy%bm%Ww%dd%hh%mm%s%Qs" "5y4m3w2d2h22m8.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21,
-        testAFormat "%Bm %Dd %Hh %Mm %S%Qs" "64m 23d 554h 33262m 1995728.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21,
-        testAFormat "%Yy%bm%Ww%dd%hh%mm%s%Qs" "-5y-4m-3w-2d-2h-22m-8.21s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21,
-        testAFormat "%Bm %Dd %Hh %Mm %S%Qs" "-64m -23d -554h -33262m -1995728.21s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21
+        testAFormat "%Yy%bm%Ww%dd%hh%mm%ss" "5y4m3w2d2h22m8s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21,
+        testAFormat "%Yy%bm%Ww%dd%hh%mm%Ess" "5y4m3w2d2h22m8.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21,
+        testAFormat "%Yy%bm%Ww%dd%hh%mm%0Ess" "5y4m3w2d2h22m08.210000000000s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21,
+        testAFormat "%Bm %Dd %Hh %Mm %ESs" "64m 23d 554h 33262m 1995728.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21,
+        testAFormat "%Yy%bm%Ww%dd%hh%mm%ss" "-5y-4m-3w-2d-2h-22m-8s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21,
+        testAFormat "%Yy%bm%Ww%dd%hh%mm%Ess" "-5y-4m-3w-2d-2h-22m-8.21s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21,
+        testAFormat "%Bm %Dd %Hh %Mm %ESs" "-64m -23d -554h -33262m -1995728.21s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21
     ]
 
 testFormat :: TestTree
index 1f8d61c..2969e03 100644 (file)
@@ -3,6 +3,7 @@ module Test.Format.ParseTime(testParseTime,test_parse_format) where
 
 import Control.Monad
 import Data.Char
+import Text.Read
 import Data.Time
 import Data.Time.Calendar.OrdinalDate
 import Data.Time.Calendar.WeekDate
@@ -259,7 +260,7 @@ test_parse_format f t = let s = format f t in (show t, s, parse False f s `asTyp
 --
 
 prop_read_show :: (Read a, Show a, Eq a) => a -> Result
-prop_read_show t = compareResult [(t,"")] (reads (show t))
+prop_read_show t = compareResult (Just t) (readMaybe (show t))
 
 --
 -- * special show functions
@@ -353,7 +354,11 @@ typedTests prop = [
     nameTest "TimeZone" $ tgroup timeZoneFormats prop,
     nameTest "ZonedTime" $ tgroup zonedTimeFormats prop,
     nameTest "UTCTime" $ tgroup utcTimeFormats prop,
-    nameTest "UniversalTime" $ tgroup universalTimeFormats prop
+    nameTest "UniversalTime" $ tgroup universalTimeFormats prop,
+    nameTest "CalendarDiffDays" $ tgroup calendarDiffDaysFormats prop,
+    nameTest "CalenderDiffTime" $ tgroup calendarDiffTimeFormats prop,
+    nameTest "DiffTime" $ tgroup diffTimeFormats prop,
+    nameTest "NominalDiffTime" $ tgroup nominalDiffTimeFormats prop
     ]
 
 formatParseFormatTests :: TestTree
@@ -385,7 +390,9 @@ readShowTests = nameTest "read_show" [
     nameTest "TimeZone" (prop_read_show :: TimeZone -> Result),
     nameTest "ZonedTime" (prop_read_show :: ZonedTime -> Result),
     nameTest "UTCTime" (prop_read_show :: UTCTime -> Result),
-    nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result)
+    nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result),
+    nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result),
+    nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result)
     ]
 
 parseShowTests :: TestTree
@@ -455,6 +462,18 @@ utcTimeFormats = map FormatString
 universalTimeFormats :: [FormatString UniversalTime]
 universalTimeFormats = map FormatString []
 
+calendarDiffDaysFormats :: [FormatString CalendarDiffDays]
+calendarDiffDaysFormats = map FormatString ["%Yy%bm%Ww%dd","%Yy%bm%Dd","%Bm%Ww%dd","%Bm%Dd"]
+
+calendarDiffTimeFormats :: [FormatString CalendarDiffTime]
+calendarDiffTimeFormats = map FormatString ["%Yy%bm%Ww%dd%hh%mm%Ess","%Bm%Ww%dd%hh%mm%Ess","%Bm%Dd%hh%mm%Ess","%Bm%Hh%mm%Ess","%Bm%Mm%Ess","%Bm%Mm%0Ess","%Bm%ESs","%Bm%0ESs"]
+
+diffTimeFormats :: [FormatString DiffTime]
+diffTimeFormats = map FormatString ["%Ww%dd%hh%mm%Ess","%Dd%hh%mm%Ess","%Hh%mm%Ess","%Mm%Ess","%Mm%0Ess","%ESs","%0ESs"]
+
+nominalDiffTimeFormats :: [FormatString NominalDiffTime]
+nominalDiffTimeFormats = map FormatString ["%Ww%dd%hh%mm%Ess","%Dd%hh%mm%Ess","%Hh%mm%Ess","%Mm%Ess","%Mm%0Ess","%ESs","%0ESs"]
+
 --
 -- * Formats that do not include all the information
 --
index 406dce8..293fc63 100644 (file)
@@ -92,8 +92,12 @@ library
         Data.Time.LocalTime.Internal.CalendarDiffTime
         Data.Time.LocalTime.Internal.LocalTime,
         Data.Time.LocalTime.Internal.ZonedTime,
-        Data.Time.Format.Parse
-        Data.Time.Format.Locale
+        Data.Time.Format.Parse,
+        Data.Time.Format.Locale,
+        Data.Time.Format.Format.Class,
+        Data.Time.Format.Format.Instances,
+        Data.Time.Format.Parse.Class,
+        Data.Time.Format.Parse.Instances
     include-dirs: lib/include
     if os(windows)
         install-includes: