new module for ISO 8601 format (#40)
authorAshley Yakeley <ashley@semantic.org>
Wed, 24 Jan 2018 06:13:23 +0000 (22:13 -0800)
committerAshley Yakeley <ashley@semantic.org>
Wed, 24 Jan 2018 06:13:23 +0000 (22:13 -0800)
14 files changed:
lib/Data/Format.hs [new file with mode: 0644]
lib/Data/Time/Calendar/CalendarDiffDays.hs
lib/Data/Time/Calendar/Private.hs
lib/Data/Time/Format.hs
lib/Data/Time/Format/Format/Class.hs
lib/Data/Time/Format/ISO8601.hs [new file with mode: 0644]
lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs
test/main/Main.hs
test/main/Test/Arbitrary.hs
test/main/Test/Calendar/Duration.hs
test/main/Test/Format/ISO8601.hs [new file with mode: 0644]
test/main/Test/Format/ParseTime.hs
test/main/Test/LocalTime/CalendarDiffTime.hs
time.cabal

diff --git a/lib/Data/Format.hs b/lib/Data/Format.hs
new file mode 100644 (file)
index 0000000..07dcb13
--- /dev/null
@@ -0,0 +1,229 @@
+module Data.Format
+    ( Productish(..)
+    , Summish(..)
+    , parseReader
+    , Format(..)
+    , formatShow
+    , formatParseM
+    , isoMap
+    , mapMFormat
+    , filterFormat
+    , clipFormat
+    , enumMap
+    , literalFormat
+    , specialCaseShowFormat
+    , specialCaseFormat
+    , optionalFormat
+    , SignOption(..)
+    , integerFormat
+    , decimalFormat
+    ) where
+
+#if MIN_VERSION_base(4,9,0)
+import Control.Monad.Fail
+import Prelude hiding (fail)
+#endif
+#if MIN_VERSION_base(4,8,0)
+import Data.Void
+#endif
+import Data.Char
+import Text.ParserCombinators.ReadP
+
+
+#if MIN_VERSION_base(4,8,0)
+#else
+newtype Void = Void Void
+absurd :: Void -> a
+absurd v = seq v $ error "absurd"
+#endif
+
+class IsoVariant f where
+    isoMap :: (a -> b) -> (b -> a) -> f a -> f b
+
+enumMap :: (IsoVariant f,Enum a) => f Int -> f a
+enumMap = isoMap toEnum fromEnum
+
+infixr 3 <**>, **>, <**
+class IsoVariant f => Productish f where
+    pUnit :: f ()
+    (<**>) :: f a -> f b -> f (a,b)
+    (**>) ::  f () -> f a -> f a
+    fu **> fa = isoMap (\((),a) -> a) (\a -> ((),a)) $ fu <**> fa
+    (<**) ::  f a -> f () -> f a
+    fa <** fu = isoMap (\(a,()) -> a) (\a -> (a,())) $ fa <**> fu
+
+infixr 2 <++>
+class IsoVariant f => Summish f where
+    pVoid :: f Void
+    (<++>) :: f a -> f b -> f (Either a b)
+
+
+parseReader :: (
+#if MIN_VERSION_base(4,9,0)
+    MonadFail m
+#else
+    Monad m
+#endif
+    ) => ReadP t -> String -> m t
+parseReader readp s = case [ t | (t,"") <- readP_to_S readp s] of
+    [t] -> return t
+    []  -> fail $ "no parse of " ++ show s
+    _   -> fail $ "multiple parses of " ++ show s
+
+-- | A text format for a type
+data Format t = MkFormat
+    { formatShowM :: t -> Maybe String
+        -- ^ Show a value in the format, if valid
+    , formatReadP :: ReadP t
+        -- ^ Read a value in the format
+    }
+
+-- | Show a value in the format, or error if invalid
+formatShow :: Format t -> t -> String
+formatShow fmt t = case formatShowM fmt t of
+    Just str -> str
+    Nothing -> error "formatShow: bad value"
+
+-- | Parse a value in the format
+formatParseM :: (
+#if MIN_VERSION_base(4,9,0)
+    MonadFail m
+#else
+    Monad m
+#endif
+    ) => Format t -> String -> m t
+formatParseM format = parseReader $ formatReadP format
+
+instance IsoVariant Format where
+    isoMap ab ba (MkFormat sa ra) = MkFormat (\b -> sa $ ba b) (fmap ab ra)
+
+mapMFormat :: (a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b
+mapMFormat amb bma (MkFormat sa ra) = MkFormat (\b -> bma b >>= sa) $ do
+    a <- ra
+    case amb a of
+        Just b -> return b
+        Nothing -> pfail
+
+filterFormat :: (a -> Bool) -> Format a -> Format a
+filterFormat test = mapMFormat (\a -> if test a then Just a else Nothing) (\a -> if test a then Just a else Nothing)
+
+-- | Limits are inclusive
+clipFormat :: Ord a => (a,a) -> Format a -> Format a
+clipFormat (lo,hi) = filterFormat (\a -> a >= lo && a <= hi)
+
+instance Productish Format where
+    pUnit = MkFormat {formatShowM = \_ -> Just "", formatReadP = return ()}
+    (<**>) (MkFormat sa ra) (MkFormat sb rb) = let
+        sab (a, b) = do
+            astr <- sa a
+            bstr <- sb b
+            return $ astr ++ bstr
+        rab = do
+            a <- ra
+            b <- rb
+            return (a, b)
+        in MkFormat sab rab
+    (MkFormat sa ra) **> (MkFormat sb rb) = let
+        s b = do
+            astr <- sa ()
+            bstr <- sb b
+            return $ astr ++ bstr
+        r = do
+            ra
+            rb
+        in MkFormat s r
+    (MkFormat sa ra) <** (MkFormat sb rb) = let
+        s a = do
+            astr <- sa a
+            bstr <- sb ()
+            return $ astr ++ bstr
+        r = do
+            a <- ra
+            rb
+            return a
+        in MkFormat s r
+
+instance Summish Format where
+    pVoid = MkFormat absurd pfail
+    (MkFormat sa ra) <++> (MkFormat sb rb) = let
+        sab (Left a) = sa a
+        sab (Right b) = sb b
+        rab = (fmap Left ra) +++ (fmap Right rb)
+        in MkFormat sab rab
+
+literalFormat :: String -> Format ()
+literalFormat s = MkFormat {formatShowM = \_ -> Just s, formatReadP = string s >> return ()}
+
+specialCaseShowFormat :: Eq a => (a,String) -> Format a -> Format a
+specialCaseShowFormat (val,str) (MkFormat s r) = let
+    s' t | t == val = Just str
+    s' t = s t
+    in MkFormat s' r
+
+specialCaseFormat :: Eq a => (a,String) -> Format a -> Format a
+specialCaseFormat (val,str) (MkFormat s r) = let
+    s' t | t == val = Just str
+    s' t = s t
+    r' = (string str >> return val) +++ r
+    in MkFormat s' r'
+
+optionalFormat :: Eq a => a -> Format a -> Format a
+optionalFormat val = specialCaseFormat (val,"")
+
+data SignOption
+    = NoSign
+    | NegSign
+    | PosNegSign
+
+readSign :: Num t => SignOption -> ReadP (t -> t)
+readSign NoSign = return id
+readSign NegSign = option id $ char '-' >> return negate
+readSign PosNegSign = (char '+' >> return id) +++ (char '-' >> return negate)
+
+readNumber :: (Num t, Read t) => SignOption -> Maybe Int -> Bool -> ReadP t
+readNumber signOpt mdigitcount allowDecimal = do
+    sign <- readSign signOpt
+    digits <-
+        case mdigitcount of
+            Just digitcount -> count digitcount $ satisfy isDigit
+            Nothing -> many1 $ satisfy isDigit
+    moredigits <-
+        case allowDecimal of
+            False -> return ""
+            True ->
+                option "" $ do
+                    _ <- char '.' +++ char ','
+                    dd <- many1 (satisfy isDigit)
+                    return $ '.' : dd
+    return $ sign $ read $ digits ++ moredigits
+
+zeroPad :: Maybe Int -> String -> String
+zeroPad Nothing s = s
+zeroPad (Just i) s = replicate (i - length s) '0' ++ s
+
+trimTrailing :: String -> String
+trimTrailing "" = ""
+trimTrailing "." = ""
+trimTrailing s | last s == '0' = trimTrailing $ init s
+trimTrailing s = s
+
+showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String
+showNumber signOpt mdigitcount t = let
+    showIt str = let
+        (intPart, decPart) = break ((==) '.') str
+        in (zeroPad mdigitcount intPart) ++ trimTrailing decPart
+    in case show t of
+           ('-':str) ->
+               case signOpt of
+                   NoSign -> Nothing
+                   _ -> Just $ '-' : showIt str
+           str ->
+               Just $ case signOpt of
+                   PosNegSign -> '+' : showIt str
+                   _ -> showIt str
+
+integerFormat :: (Show t,Read t,Num t) => SignOption -> Maybe Int -> Format t
+integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount False)
+
+decimalFormat :: (Show t,Read t,Num t) => SignOption -> Maybe Int -> Format t
+decimalFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount True)
index bb9a383..bbaca0a 100644 (file)
@@ -11,8 +11,6 @@ import Data.Monoid
 #if MIN_VERSION_base(4,9,0)
 import Data.Semigroup hiding (option)
 #endif
-import Data.Char
-import Text.ParserCombinators.ReadP hiding (string)
 
 data CalendarDiffDays = CalendarDiffDays
     { cdMonths :: Integer
@@ -34,39 +32,8 @@ instance Monoid CalendarDiffDays where
     mappend (CalendarDiffDays m1 d1) (CalendarDiffDays m2 d2) = CalendarDiffDays (m1 + m2) (d1 + d2)
 #endif
 
--- | Show in ISO 8601 \"PyyYmmMddD\" format. (Zero items will be omitted, except zero time will be \"P0D\".)
 instance Show CalendarDiffDays where
-    show dur@(CalendarDiffDays m d) = let
-        (y,my) = quotRem m 12
-        ys = if y == 0 then "" else show y ++ "Y"
-        ms = if my == 0 then "" else show my ++ "M"
-        ds = if d == 0 then "" else show d ++ "D"
-        in if dur == mempty then "P0D" else "P" ++ ys ++ ms ++ ds
-
--- | Read in ISO 8601 \"PyyYmmMwwWddD\" format. (Items may be omitted.)
-instance Read CalendarDiffDays where
-    readsPrec _ = readParen False $ readP_to_S $ skipSpaces >> do
-        let
-            ch :: Char -> ReadP ()
-            ch c = char c >> return ()
-
-            readInteger :: ReadP Integer
-            readInteger = do
-                neg <- option False $ ch '-' >> return True
-                digits <- many1 (satisfy isDigit)
-                return $ (if neg then negate else id) $ read digits
-
-            readItem :: Char -> ReadP Integer
-            readItem c = option 0 $ do
-                i <- readInteger
-                ch c
-                return i
-        ch 'P'
-        y <- readItem 'Y'
-        m <- readItem 'M'
-        w <- readItem 'W'
-        d <- readItem 'D'
-        return $ CalendarDiffDays (y * 12 + m) (w * 7 + d)
+    show (CalendarDiffDays m d) = "P" ++ show m ++ "M" ++ show d ++ "D"
 
 calendarDay :: CalendarDiffDays
 calendarDay = CalendarDiffDays 0 1
index 4a67193..9f192f9 100644 (file)
@@ -50,3 +50,15 @@ clipValid :: (Ord t) => t -> t -> t -> Maybe t
 clipValid a _ x | x < a = Nothing
 clipValid _ b x | x > b = Nothing
 clipValid _ _ x = Just x
+
+quotBy :: (Real a,Integral b) => a -> a -> b
+quotBy d n = truncate ((toRational n) / (toRational d))
+
+remBy :: Real a => a -> a -> a
+remBy d n = n - (fromInteger f) * d where
+    f = quotBy d n
+
+quotRemBy :: (Real a,Integral b) => a -> a -> (b,a)
+quotRemBy d n = let
+    f = quotBy d n
+    in (f,n - (fromIntegral f) * d)
index 88f9f9e..749223d 100644 (file)
@@ -1,4 +1,3 @@
-{-# OPTIONS -fno-warn-orphans #-}
 module Data.Time.Format
     (
     -- * UNIX-style formatting
index 46245a6..54d2ac8 100644 (file)
@@ -63,14 +63,6 @@ formatNumber fdef idef cdef ff = formatGeneral False fdef idef cdef $ \_ pado ->
 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
diff --git a/lib/Data/Time/Format/ISO8601.hs b/lib/Data/Time/Format/ISO8601.hs
new file mode 100644 (file)
index 0000000..c713917
--- /dev/null
@@ -0,0 +1,322 @@
+module Data.Time.Format.ISO8601
+    (
+        -- * Format
+        Format,
+        formatShowM,
+        formatShow,
+        formatReadP,
+        formatParseM,
+        -- * ISO 8601
+        FormatExtension(..),
+        formatReadPExtension,
+        parseFormatExtension,
+        calendarFormat,
+        yearMonthFormat,
+        yearFormat,
+        centuryFormat,
+        expandedCalendarFormat,
+        expandedYearMonthFormat,
+        expandedYearFormat,
+        expandedCenturyFormat,
+        ordinalDateFormat,
+        expandedOrdinalDateFormat,
+        weekDateFormat,
+        yearWeekFormat,
+        expandedWeekDateFormat,
+        expandedYearWeekFormat,
+        timeOfDayFormat,
+        hourMinuteFormat,
+        hourFormat,
+        withTimeDesignator,
+        withUTCDesignator,
+        timeOffsetFormat,
+        timeOfDayAndOffsetFormat,
+        localTimeFormat,
+        dayAndTimeFormat,
+        timeAndOffsetFormat,
+        durationDaysFormat,
+        durationTimeFormat,
+        alternativeDurationDaysFormat,
+        alternativeDurationTimeFormat,
+        intervalFormat,
+        recurringIntervalFormat,
+    ) where
+
+#if MIN_VERSION_base(4,9,0)
+import Control.Monad.Fail
+import Prelude hiding (fail)
+#endif
+import Data.Ratio
+import Data.Fixed
+import Text.ParserCombinators.ReadP
+import Data.Format
+import Data.Time
+import Data.Time.Calendar.OrdinalDate
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.Private
+
+-- | You probably want 'ExtendedFormat'.
+data FormatExtension =
+    -- | ISO 8601:2004(E) sec. 2.3.4
+    ExtendedFormat |
+    -- | ISO 8601:2004(E) sec. 2.3.3 "The basic format should be avoided in plain text."
+    BasicFormat
+
+-- | Read a value in either extended or basic format
+formatReadPExtension :: (FormatExtension -> Format t) -> ReadP t
+formatReadPExtension ff = formatReadP (ff ExtendedFormat) +++ formatReadP (ff BasicFormat)
+
+-- | Parse a value in either extended or basic format
+parseFormatExtension :: (
+#if MIN_VERSION_base(4,9,0)
+    MonadFail m
+#else
+    Monad m
+#endif
+    ) => (FormatExtension -> Format t) -> String -> m t
+parseFormatExtension ff = parseReader $ formatReadPExtension ff
+
+sepFormat :: String -> Format a -> Format b -> Format (a,b)
+sepFormat sep fa fb = (fa <** literalFormat sep) <**> fb
+
+dashFormat :: Format a -> Format b -> Format (a,b)
+dashFormat = sepFormat "-"
+
+colnFormat :: Format a -> Format b -> Format (a,b)
+colnFormat = sepFormat ":"
+
+extDashFormat :: FormatExtension -> Format a -> Format b -> Format (a,b)
+extDashFormat ExtendedFormat = dashFormat
+extDashFormat BasicFormat = (<**>)
+
+extColonFormat :: FormatExtension -> Format a -> Format b -> Format (a,b)
+extColonFormat ExtendedFormat = colnFormat
+extColonFormat BasicFormat = (<**>)
+
+expandedYearFormat' :: Int -> Format Integer
+expandedYearFormat' n = integerFormat PosNegSign (Just n)
+
+yearFormat' :: Format Integer
+yearFormat' = integerFormat NegSign (Just 4)
+
+monthFormat :: Format Int
+monthFormat = integerFormat NoSign (Just 2)
+
+dayOfMonthFormat :: Format Int
+dayOfMonthFormat = integerFormat NoSign (Just 2)
+
+dayOfYearFormat :: Format Int
+dayOfYearFormat = integerFormat NoSign (Just 3)
+
+weekOfYearFormat :: Format Int
+weekOfYearFormat = literalFormat "W" **> integerFormat NoSign (Just 2)
+
+dayOfWeekFormat :: Format Int
+dayOfWeekFormat = integerFormat NoSign (Just 1)
+
+hourFormat' :: Format Int
+hourFormat' = integerFormat NoSign (Just 2)
+
+data E14
+instance HasResolution E14 where
+    resolution _ = 100000000000000
+data E16
+instance HasResolution E16 where
+    resolution _ = 10000000000000000
+
+hourDecimalFormat :: Format (Fixed E16) -- need four extra decimal places for hours
+hourDecimalFormat = decimalFormat NoSign (Just 2)
+
+minuteFormat :: Format Int
+minuteFormat = integerFormat NoSign (Just 2)
+
+minuteDecimalFormat :: Format (Fixed E14) -- need two extra decimal places for minutes
+minuteDecimalFormat = decimalFormat NoSign (Just 2)
+
+secondFormat :: Format Pico
+secondFormat = decimalFormat NoSign (Just 2)
+
+mapGregorian :: Format (Integer,(Int,Int)) -> Format Day
+mapGregorian = mapMFormat (\(y,(m,d)) -> fromGregorianValid y m d) (\day -> (\(y,m,d) -> Just (y,(m,d))) $ toGregorian day)
+
+mapOrdinalDate :: Format (Integer,Int) -> Format Day
+mapOrdinalDate = mapMFormat (\(y,d) -> fromOrdinalDateValid y d) (Just . toOrdinalDate)
+
+mapWeekDate :: Format (Integer,(Int,Int)) -> Format Day
+mapWeekDate = mapMFormat (\(y,(w,d)) -> fromWeekDateValid y w d) (\day -> (\(y,w,d) -> Just (y,(w,d))) $ toWeekDate day)
+
+mapTimeOfDay :: Format (Int,(Int,Pico)) -> Format TimeOfDay
+mapTimeOfDay = mapMFormat (\(h,(m,s)) -> makeTimeOfDayValid h m s) (\(TimeOfDay h m s) -> Just (h,(m,s)))
+
+
+-- | ISO 8601:2004(E) sec. 4.1.2.2
+calendarFormat :: FormatExtension -> Format Day
+calendarFormat fe = mapGregorian $ extDashFormat fe yearFormat $ extDashFormat fe monthFormat dayOfMonthFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.2.3(a)
+yearMonthFormat :: Format (Integer,Int)
+yearMonthFormat = yearFormat <**> literalFormat "-" **> monthFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.2.3(b)
+yearFormat :: Format Integer
+yearFormat = yearFormat'
+
+-- | ISO 8601:2004(E) sec. 4.1.2.3(c)
+centuryFormat :: Format Integer
+centuryFormat = integerFormat NegSign (Just 2)
+
+-- | ISO 8601:2004(E) sec. 4.1.2.4(a)
+expandedCalendarFormat :: Int -> FormatExtension -> Format Day
+expandedCalendarFormat n fe = mapGregorian $ extDashFormat fe (expandedYearFormat n) $ extDashFormat fe monthFormat dayOfMonthFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.2.4(b)
+expandedYearMonthFormat :: Int -> Format (Integer,Int)
+expandedYearMonthFormat n = dashFormat (expandedYearFormat n) monthFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.2.4(c)
+expandedYearFormat :: Int -> Format Integer
+expandedYearFormat = expandedYearFormat'
+
+-- | ISO 8601:2004(E) sec. 4.1.2.4(d)
+expandedCenturyFormat :: Int -> Format Integer
+expandedCenturyFormat n = integerFormat PosNegSign (Just n)
+
+-- | ISO 8601:2004(E) sec. 4.1.3.2
+ordinalDateFormat :: FormatExtension -> Format Day
+ordinalDateFormat fe = mapOrdinalDate $ extDashFormat fe yearFormat dayOfYearFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.3.3
+expandedOrdinalDateFormat :: Int -> FormatExtension -> Format Day
+expandedOrdinalDateFormat n fe = mapOrdinalDate $ extDashFormat fe (expandedYearFormat n) dayOfYearFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.4.2
+weekDateFormat :: FormatExtension -> Format Day
+weekDateFormat fe = mapWeekDate $ extDashFormat fe yearFormat $ extDashFormat fe weekOfYearFormat dayOfWeekFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.4.3
+yearWeekFormat :: FormatExtension -> Format  (Integer,Int)
+yearWeekFormat fe = extDashFormat fe yearFormat weekOfYearFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.4.2
+expandedWeekDateFormat :: Int -> FormatExtension -> Format Day
+expandedWeekDateFormat n fe = mapWeekDate $ extDashFormat fe (expandedYearFormat n) $ extDashFormat fe weekOfYearFormat dayOfWeekFormat
+
+-- | ISO 8601:2004(E) sec. 4.1.4.3
+expandedYearWeekFormat :: Int -> FormatExtension -> Format (Integer,Int)
+expandedYearWeekFormat n fe = extDashFormat fe (expandedYearFormat n) weekOfYearFormat
+
+-- | ISO 8601:2004(E) sec. 4.2.2.2, 4.2.2.4(a)
+timeOfDayFormat :: FormatExtension -> Format TimeOfDay
+timeOfDayFormat fe = mapTimeOfDay $ extColonFormat fe hourFormat' $ extColonFormat fe minuteFormat secondFormat
+
+-- workaround for the 'fromRational' in 'Fixed', which uses 'floor' instead of 'round'
+fromRationalRound :: Rational -> NominalDiffTime
+fromRationalRound r = fromRational $ round (r * 1000000000000) % 1000000000000
+
+-- | ISO 8601:2004(E) sec. 4.2.2.3(a), 4.2.2.4(b)
+hourMinuteFormat :: FormatExtension -> Format TimeOfDay
+hourMinuteFormat fe = let
+    toTOD (h,m) = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of
+        (0,tod) -> Just tod
+        _ -> Nothing
+    fromTOD tod = let
+        mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60
+        in Just $ quotRemBy 60 mm
+    in mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat
+
+-- | ISO 8601:2004(E) sec. 4.2.2.3(b), 4.2.2.4(c)
+hourFormat :: Format TimeOfDay
+hourFormat = let
+    toTOD h = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of
+        (0,tod) -> Just tod
+        _ -> Nothing
+    fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600
+    in mapMFormat toTOD fromTOD $ hourDecimalFormat
+
+-- | ISO 8601:2004(E) sec. 4.2.2.5
+withTimeDesignator :: Format t -> Format t
+withTimeDesignator f = literalFormat "T" **> f
+
+-- | ISO 8601:2004(E) sec. 4.2.4
+withUTCDesignator :: Format t -> Format t
+withUTCDesignator f = f <** literalFormat "Z"
+
+-- | ISO 8601:2004(E) sec. 4.2.5.1
+timeOffsetFormat :: FormatExtension -> Format TimeZone
+timeOffsetFormat fe = isoMap (\(h,m) -> minutesToTimeZone $ h * 60 + m) (\tz -> (\m -> quotRem m 60) $ timeZoneMinutes tz) $
+    extColonFormat fe (integerFormat PosNegSign (Just 2)) (integerFormat NoSign (Just 2))
+
+-- | ISO 8601:2004(E) sec. 4.2.5.2
+timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay,TimeZone)
+timeOfDayAndOffsetFormat fe = timeOfDayFormat fe <**> timeOffsetFormat fe
+
+-- | ISO 8601:2004(E) sec. 4.3.2
+localTimeFormat :: Format Day -> Format TimeOfDay -> Format LocalTime
+localTimeFormat fday ftod = isoMap (\(day,tod) -> LocalTime day tod) (\(LocalTime day tod) -> (day,tod)) $ fday <**> withTimeDesignator ftod
+
+-- | ISO 8601:2004(E) sec. 4.3.3
+dayAndTimeFormat :: Format Day -> Format time -> Format (Day,time)
+dayAndTimeFormat fday ft = fday <**> withTimeDesignator ft
+
+-- | ISO 8601:2004(E) sec. 4.3.3
+timeAndOffsetFormat :: Format t -> FormatExtension -> Format (t,TimeZone)
+timeAndOffsetFormat ft fe = ft <**> timeOffsetFormat fe
+
+intDesignator :: (Eq t,Show t,Read t,Num t) => Char -> Format t
+intDesignator c = optionalFormat 0 $ integerFormat NoSign Nothing <** literalFormat [c]
+
+decDesignator :: (Eq t,Show t,Read t,Num t) => Char -> Format t
+decDesignator c = optionalFormat 0 $ decimalFormat NoSign Nothing <** literalFormat [c]
+
+daysDesigs :: Format CalendarDiffDays
+daysDesigs = let
+    toCD (y,(m,(w,d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d)
+    fromCD (CalendarDiffDays mm d) = (quot mm 12,(rem mm 12,(0,d)))
+    in isoMap toCD fromCD $
+        intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D'
+
+-- | ISO 8601:2004(E) sec. 4.4.3.2
+durationDaysFormat :: Format CalendarDiffDays
+durationDaysFormat = (**>) (literalFormat "P") $ specialCaseShowFormat (mempty,"0D") $ daysDesigs
+
+-- | ISO 8601:2004(E) sec. 4.4.3.2
+durationTimeFormat :: Format CalendarDiffTime
+durationTimeFormat = let
+    toCT (cd,(h,(m,s))) = mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s)
+    fromCT (CalendarDiffTime mm t) = let
+        (d,TimeOfDay h m s) = timeToDaysAndTimeOfDay t
+        in (CalendarDiffDays mm d,(h,(m,s)))
+    in (**>) (literalFormat "P") $ specialCaseShowFormat (mempty,"0S") $ isoMap toCT fromCT $
+        daysDesigs <**> literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S'
+
+-- | ISO 8601:2004(E) sec. 4.4.3.3
+alternativeDurationDaysFormat :: FormatExtension -> Format CalendarDiffDays
+alternativeDurationDaysFormat fe = let
+    toCD (y,(m,d)) = CalendarDiffDays (y * 12 + m) d
+    fromCD (CalendarDiffDays mm d) = (quot mm 12,(rem mm 12,d))
+    in isoMap toCD fromCD $ (**>) (literalFormat "P") $
+        extDashFormat fe (clipFormat (0,9999) $ integerFormat NegSign $ Just 4) $
+        extDashFormat fe (clipFormat (0,12) $ integerFormat NegSign $ Just 2) $
+        (clipFormat (0,30) $ integerFormat NegSign $ Just 2)
+
+-- | ISO 8601:2004(E) sec. 4.4.3.3
+alternativeDurationTimeFormat :: FormatExtension -> Format CalendarDiffTime
+alternativeDurationTimeFormat fe = let
+    toCT (cd,(h,(m,s))) = mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s)
+    fromCT (CalendarDiffTime mm t) = let
+        (d,TimeOfDay h m s) = timeToDaysAndTimeOfDay t
+        in (CalendarDiffDays mm d,(h,(m,s)))
+    in isoMap toCT fromCT $
+        (<**>) (alternativeDurationDaysFormat fe) $
+        withTimeDesignator $
+        extColonFormat fe (clipFormat (0,24) $ integerFormat NegSign (Just 2)) $
+        extColonFormat fe (clipFormat (0,60) $ integerFormat NegSign (Just 2)) $
+        (clipFormat (0,60) $ decimalFormat NegSign (Just 2))
+
+-- | ISO 8601:2004(E) sec. 4.4.4.1
+intervalFormat :: Format a -> Format b -> Format (a,b)
+intervalFormat = sepFormat "/"
+
+-- | ISO 8601:2004(E) sec. 4.5
+recurringIntervalFormat :: Format a -> Format b -> Format (Int,a,b)
+recurringIntervalFormat fa fb = isoMap (\(r,(a,b)) -> (r,a,b)) (\(r,a,b) -> (r,(a,b))) $ sepFormat "/" (literalFormat "R" **> integerFormat NoSign Nothing) $ intervalFormat fa fb
index 3a56ede..64372af 100644 (file)
@@ -11,11 +11,8 @@ import Data.Monoid
 import Data.Semigroup hiding (option)
 #endif
 import Data.Fixed
-import Data.Char
 import Data.Time.Calendar.CalendarDiffDays
 import Data.Time.Clock.Internal.NominalDiffTime
-import Data.Time.LocalTime.Internal.TimeOfDay
-import Text.ParserCombinators.ReadP hiding (string)
 
 data CalendarDiffTime = CalendarDiffTime
     { ctMonths :: Integer
@@ -34,84 +31,16 @@ instance Monoid CalendarDiffTime where
 #else
     mappend (CalendarDiffTime m1 d1) (CalendarDiffTime m2 d2) = CalendarDiffTime (m1 + m2) (d1 + d2)
 #endif
--- | Show in ISO 8601 \"PyyYmmMddDThhHmmMssS\" format. (Zero items will be omitted, and a zero time part with be entirely omitted, except zero time will be \"P0D\".)
-instance Show CalendarDiffTime where
-    show (CalendarDiffTime months t) = let
-        part :: (Eq t, Num t, Show t) => t -> String -> String
-        part x s =
-            if x == 0
-                then ""
-                else show x ++ s
-        part' :: Pico -> String -> String
-        part' x s =
-            if x == 0
-                then ""
-                else showFixed True x ++ s
-        (y, ym) = quotRem months 12
-        (d, dh, hm, ms) =
-            if t >= 0
-                then let
-                         (d', TimeOfDay dh' hm' ms') = timeToDaysAndTimeOfDay t
-                         in (d', dh', hm', ms')
-                else let
-                         (d', TimeOfDay dh' hm' ms') = timeToDaysAndTimeOfDay $ negate t
-                         in (negate d', negate dh', negate hm', negate ms')
-        dpart = mconcat [part y "Y", part ym "M", part d "D"]
-        tpart = mconcat [part dh "H", part hm "M", part' ms "S"]
-        in "P" ++
-           case (dpart, tpart) of
-               ("", "") -> "0D"
-               (_, "") -> dpart
-               (_, _) -> dpart ++ "T" ++ tpart
 
--- | Read in ISO 8601 \"PyyYmmMwwWddDThhHmmMssS\" format. (Items may be omitted, and the \"T\" time section may be entirely omitted.)
-instance Read CalendarDiffTime where
-    readsPrec _ =
-        readParen False $
-        readP_to_S $
-        skipSpaces >> do
-            let
-                ch :: Char -> ReadP ()
-                ch c = char c >> return ()
-                readPositiveInteger ::  ReadP Integer
-                readPositiveInteger = do
-                    digits <- many1 (satisfy isDigit)
-                    return $ read digits
-                readPositivePico :: ReadP Pico
-                readPositivePico = do
-                    digits <- many1 (satisfy isDigit)
-                    moredigits <- option "" $ do
-                        ch '.'
-                        dd <- many1 (satisfy isDigit)
-                        return $ '.':dd
-                    return $ read $ digits ++ moredigits
-                readItem :: Num t => ReadP t -> Char -> ReadP t
-                readItem readPositive c =
-                    option 0 $ do
-                        neg <- option False $ ch '-' >> return True
-                        x <- readPositive
-                        ch c
-                        return $ if neg then negate x else x
-            ch 'P'
-            y <- readItem readPositiveInteger 'Y'
-            m <- readItem readPositiveInteger 'M'
-            w <- readItem readPositiveInteger 'W'
-            d <- readItem readPositiveInteger 'D'
-            let
-                months = y * 12 + m
-                days = w * 7 + d
-            seconds <-
-                option 0 $ do
-                    ch 'T'
-                    dh <- readItem readPositiveInteger 'H'
-                    hm <- readItem readPositiveInteger 'M'
-                    ms <- readItem readPositivePico 'S'
-                    return $ ms + 60 * (fromInteger hm + 60 * fromInteger dh)
-            return $ CalendarDiffTime months $ (fromInteger days * nominalDay) + realToFrac seconds
+instance Show CalendarDiffTime where
+    show (CalendarDiffTime m t) = "P" ++ show m ++ "M" ++ showFixed True (realToFrac t :: Pico) ++ "S"
 
 calendarTimeDays :: CalendarDiffDays -> CalendarDiffTime
 calendarTimeDays (CalendarDiffDays m d) = CalendarDiffTime m $ fromInteger d * nominalDay
 
+calendarTimeTime :: NominalDiffTime -> CalendarDiffTime
+calendarTimeTime dt = CalendarDiffTime 0 dt
+
 -- | Scale by a factor. Note that @scaleCalendarDiffTime (-1)@ will not perfectly invert a duration, due to variable month lengths.
 scaleCalendarDiffTime :: Integer -> CalendarDiffTime -> CalendarDiffTime
 scaleCalendarDiffTime k (CalendarDiffTime m d) = CalendarDiffTime (k * m) (fromInteger k * d)
index 425ce7a..480e555 100644 (file)
@@ -16,6 +16,7 @@ import Test.Clock.Resolution
 import Test.Clock.TAI
 import Test.Format.Format
 import Test.Format.ParseTime
+import Test.Format.ISO8601
 import Test.LocalTime.Time
 import Test.LocalTime.TimeOfDay
 import Test.LocalTime.CalendarDiffTime
@@ -42,7 +43,8 @@ tests = testGroup "Time" [
         ],
     testGroup "Format" [
         testFormat,
-        testParseTime
+        testParseTime,
+        testISO8601
         ],
     testGroup "LocalTime" [
         testTime,
index 73da83e..48fc1ac 100644 (file)
@@ -8,6 +8,9 @@ import Data.Time
 import Data.Time.Clock.POSIX
 import Test.Tasty.QuickCheck hiding (reason)
 
+instance Arbitrary DayOfWeek where
+    arbitrary = fmap toEnum $ choose (1,7)
+
 instance Arbitrary Day where
     arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
     shrink day = let
index aec769d..8b8938d 100644 (file)
@@ -42,8 +42,5 @@ testDiffs =
         , testClip (2017, 02, 01) (2017, 04, 07) (-2, -6)
         ]
 
-testReadShow :: TestTree
-testReadShow = testProperty "read . show" $ \(t :: CalendarDiffDays) -> read (show t) == t
-
 testDuration :: TestTree
-testDuration = testGroup "CalendarDiffDays" [testAddDiff, testDiffs, testReadShow]
+testDuration = testGroup "CalendarDiffDays" [testAddDiff, testDiffs]
diff --git a/test/main/Test/Format/ISO8601.hs b/test/main/Test/Format/ISO8601.hs
new file mode 100644 (file)
index 0000000..5352b13
--- /dev/null
@@ -0,0 +1,102 @@
+module Test.Format.ISO8601(testISO8601) where
+
+import Data.Ratio
+import Data.Time
+import Data.Time.Format.ISO8601
+import Test.QuickCheck.Property
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck hiding (reason)
+import Test.TestUtil
+import Test.Arbitrary()
+
+
+readShowProperty :: (Eq a,Show a) => Format a -> a -> Property
+readShowProperty fmt val = case formatShowM fmt val of
+    Nothing -> property Discard
+    Just str -> let
+        found = formatParseM fmt str
+        expected = Just val
+        in property $ if expected == found then succeeded else
+            failed {reason = show str ++ ": expected " ++ (show expected) ++ ", found " ++ (show found)}
+
+readBoth :: NameTest t => (FormatExtension -> t) -> [TestTree]
+readBoth fmts =
+    [
+        nameTest "extended" $ fmts ExtendedFormat,
+        nameTest "basic" $ fmts BasicFormat
+    ]
+
+readShowProperties :: (Eq a,Show a,Arbitrary a) => (FormatExtension -> Format a) -> [TestTree]
+readShowProperties fmts = readBoth $ \fe -> readShowProperty $ fmts fe
+
+newtype Durational t = MkDurational t
+
+instance Show t => Show (Durational t) where
+    show (MkDurational t) = show t
+
+instance Arbitrary (Durational CalendarDiffDays) where
+    arbitrary = do
+        mm <- choose (-10000,10000)
+        dd <- choose (-40,40)
+        return $ MkDurational $ CalendarDiffDays mm dd
+
+instance Arbitrary (Durational CalendarDiffTime) where
+    arbitrary = let
+        limit = 40 * 86400
+        picofactor = 10 ^ (12 :: Int)
+        in do
+            mm <- choose (-10000,10000)
+            ss <- choose (negate limit * picofactor, limit * picofactor)
+            return $ MkDurational $ CalendarDiffTime mm $ fromRational $ ss % picofactor
+
+testReadShowFormat :: TestTree
+testReadShowFormat = nameTest "read-show format"
+    [
+        nameTest "calendarFormat" $ readShowProperties $ calendarFormat,
+        nameTest "yearMonthFormat" $ readShowProperty $ yearMonthFormat,
+        nameTest "yearFormat" $ readShowProperty $ yearFormat,
+        nameTest "centuryFormat" $ readShowProperty $ centuryFormat,
+        nameTest "expandedCalendarFormat" $ readShowProperties $ expandedCalendarFormat 6,
+        nameTest "expandedYearMonthFormat" $ readShowProperty $ expandedYearMonthFormat 6,
+        nameTest "expandedYearFormat" $ readShowProperty $ expandedYearFormat 6,
+        nameTest "expandedCenturyFormat" $ readShowProperty $ expandedCenturyFormat 4,
+        nameTest "ordinalDateFormat" $ readShowProperties $ ordinalDateFormat,
+        nameTest "expandedOrdinalDateFormat" $ readShowProperties $ expandedOrdinalDateFormat 6,
+        nameTest "weekDateFormat" $ readShowProperties $ weekDateFormat,
+        nameTest "yearWeekFormat" $ readShowProperties $ yearWeekFormat,
+        nameTest "expandedWeekDateFormat" $ readShowProperties $ expandedWeekDateFormat 6,
+        nameTest "expandedYearWeekFormat" $ readShowProperties $ expandedYearWeekFormat 6,
+        nameTest "timeOfDayFormat" $ readShowProperties $ timeOfDayFormat,
+        nameTest "hourMinuteFormat" $ readShowProperties $ hourMinuteFormat,
+        nameTest "hourFormat" $ readShowProperty $ hourFormat,
+        nameTest "withTimeDesignator" $ readShowProperties $ \fe -> withTimeDesignator $ timeOfDayFormat fe,
+        nameTest "withUTCDesignator" $ readShowProperties $ \fe -> withUTCDesignator $ timeOfDayFormat fe,
+        nameTest "timeOffsetFormat" $ readShowProperties $ timeOffsetFormat,
+        nameTest "timeOfDayAndOffsetFormat" $ readShowProperties $ timeOfDayAndOffsetFormat,
+        nameTest "localTimeFormat" $ readShowProperties $ \fe -> localTimeFormat (calendarFormat fe) (timeOfDayFormat fe),
+        nameTest "dayAndTimeFormat" $ readShowProperties $ \fe -> dayAndTimeFormat (calendarFormat fe) (timeOfDayFormat fe),
+        nameTest "timeAndOffsetFormat" $ readShowProperties $ \fe -> timeAndOffsetFormat (timeOfDayFormat fe) fe,
+        nameTest "durationDaysFormat" $ readShowProperty $ durationDaysFormat,
+        nameTest "durationTimeFormat" $ readShowProperty $ durationTimeFormat,
+        nameTest "alternativeDurationDaysFormat" $ readBoth $ \fe (MkDurational t) -> readShowProperty (alternativeDurationDaysFormat fe) t,
+        nameTest "alternativeDurationTimeFormat" $ readBoth $ \fe (MkDurational t) -> readShowProperty (alternativeDurationTimeFormat fe) t,
+        nameTest "intervalFormat" $ readShowProperties $ \fe -> intervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat,
+        nameTest "recurringIntervalFormat" $ readShowProperties $ \fe -> recurringIntervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat
+    ]
+
+testShowFormat :: TestTree
+testShowFormat = nameTest "show format"
+    [
+        nameTest "alternativeDurationDaysFormat" $
+            assertEqual "" (Just "P0001-00-00") $ formatShowM (alternativeDurationDaysFormat ExtendedFormat) $ CalendarDiffDays 12 0,
+        nameTest "alternativeDurationTimeFormat" $
+            assertEqual "" (Just "P0000-00-01T00:00:00") $ formatShowM (alternativeDurationTimeFormat ExtendedFormat) $ CalendarDiffTime 0 86400
+    ]
+
+testISO8601 :: TestTree
+testISO8601 = nameTest "ISO8601"
+    [
+        testShowFormat,
+        testReadShowFormat
+    ]
index a57c1e7..770fdf2 100644 (file)
@@ -390,9 +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 "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result),
-    nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result)
+    nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result)
+    --nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result),
+    --nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result)
     ]
 
 parseShowTests :: TestTree
index f4ceb25..bfd5437 100644 (file)
@@ -2,17 +2,17 @@ module Test.LocalTime.CalendarDiffTime
     ( testCalendarDiffTime
     ) where
 
-import Data.Time.LocalTime
+--import Data.Time.LocalTime
 import Test.Arbitrary ()
 import Test.Tasty
-import Test.Tasty.QuickCheck hiding (reason)
+--import Test.Tasty.QuickCheck hiding (reason)
 
-testReadShow :: TestTree
-testReadShow = testProperty "read . show" $ \(t :: CalendarDiffTime) -> read (show t) == t
+--testReadShow :: TestTree
+--testReadShow = testProperty "read . show" $ \(t :: CalendarDiffTime) -> read (show t) == t
 
 testCalendarDiffTime :: TestTree
 testCalendarDiffTime =
     testGroup
         "CalendarDiffTime"
-        [ testReadShow
+        [ --testReadShow
         ]
index 293fc63..6e0e280 100644 (file)
@@ -67,10 +67,12 @@ library
         Data.Time.Clock.TAI,
         Data.Time.LocalTime,
         Data.Time.Format,
+        Data.Time.Format.ISO8601,
         Data.Time
     default-extensions:    CPP
     c-sources: lib/cbits/HsTime.c
     other-modules:
+        Data.Format
         Data.Time.Calendar.Private,
         Data.Time.Calendar.Days,
         Data.Time.Calendar.Gregorian,
@@ -166,6 +168,7 @@ test-suite test-main
         Test.Clock.TAI
         Test.Format.Format
         Test.Format.ParseTime
+        Test.Format.ISO8601
         Test.LocalTime.CalendarDiffTime
         Test.LocalTime.Time
         Test.LocalTime.TimeOfDay