diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,24 +1,30 @@ -Copyright (c) 2013, Dag Odenhall +Copyright (c) 2019 time contibutors, Oleg Grenrus + All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -* Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/src/Data/Format.hs b/src/Data/Format.hs new file mode 100644 --- /dev/null +++ b/src/Data/Format.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE CPP #-} +module Data.Format + ( Productish(..) + , Summish(..) + , parseReader + , Format(..) + , formatShow + , formatParseM + , isoMap + , mapMFormat + , filterFormat + , clipFormat + , enumMap + , literalFormat + , specialCaseShowFormat + , specialCaseFormat + , optionalFormat + , casesFormat + , optionalSignFormat + , mandatorySignFormat + , 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 +data 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 representable + , formatReadP :: ReadP t + -- ^ Read a value in the format + } + +-- | Show a value in the format, or error if unrepresentable +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,"") + +casesFormat :: Eq a => [(a,String)] -> Format a +casesFormat pairs = let + s t = lookup t pairs + r [] = pfail + r ((v,str):pp) = (string str >> return v) <++ r pp + in MkFormat s $ r pairs + +optionalSignFormat :: (Eq t,Num t) => Format t +optionalSignFormat = casesFormat + [ + (1,""), + (1,"+"), + (0,""), + (-1,"-") + ] + +mandatorySignFormat :: (Eq t,Num t) => Format t +mandatorySignFormat = casesFormat + [ + (1,"+"), + (0,"+"), + (-1,"-") + ] + +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) diff --git a/src/Data/Time/Calendar/Compat.hs b/src/Data/Time/Calendar/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/Compat.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.Time.Calendar.Compat ( + -- * Days + Day(..),addDays,diffDays, + + -- * CalendarDiffTime + CalendarDiffDays (..), + calendarDay,calendarWeek,calendarMonth,calendarYear,scaleCalendarDiffDays, + + -- * Gregorian calendar + toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength, + + -- calendrical arithmetic + -- e.g. "one month after March 31st" + addGregorianMonthsClip,addGregorianMonthsRollOver, + addGregorianYearsClip,addGregorianYearsRollOver, + addGregorianDurationClip,addGregorianDurationRollOver, + diffGregorianDurationClip,diffGregorianDurationRollOver, + + -- re-exported from OrdinalDate + isLeapYear , + + -- * Week + DayOfWeek(..), dayOfWeek, + ) where + +import Data.Time.Calendar +import Data.Time.Format +import Data.Time.Orphans () + +#if !MIN_VERSION_time(1,5,0) +import System.Locale (TimeLocale (..)) +#endif + +import Data.Data (Data, Typeable) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) + + +------------------------------------------------------------------------------- +-- CalendarDiffTime +------------------------------------------------------------------------------- + +#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_base(1,9,2) +deriving instance Typeable CalendarDiffDays +deriving instance Data CalendarDiffDays +#endif + +#if !MIN_VERSION_time(1,9,0) + +data CalendarDiffDays = CalendarDiffDays + { cdMonths :: Integer + , cdDays :: Integer + } deriving (Eq, + Data +#if __GLASGOW_HASKELL__ >= 802 +#endif + ,Typeable +#if __GLASGOW_HASKELL__ >= 802 +#endif + ) + +-- | Additive +instance Semigroup CalendarDiffDays where + CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2) + +-- | Additive +instance Monoid CalendarDiffDays where + mempty = CalendarDiffDays 0 0 + mappend = (<>) + +instance Show CalendarDiffDays where + show (CalendarDiffDays m d) = "P" ++ show m ++ "M" ++ show d ++ "D" + +calendarDay :: CalendarDiffDays +calendarDay = CalendarDiffDays 0 1 + +calendarWeek :: CalendarDiffDays +calendarWeek = CalendarDiffDays 0 7 + +calendarMonth :: CalendarDiffDays +calendarMonth = CalendarDiffDays 1 0 + +calendarYear :: CalendarDiffDays +calendarYear = CalendarDiffDays 12 0 + +-- | Scale by a factor. Note that @scaleCalendarDiffDays (-1)@ will not perfectly invert a duration, due to variable month lengths. +scaleCalendarDiffDays :: Integer -> CalendarDiffDays -> CalendarDiffDays +scaleCalendarDiffDays k (CalendarDiffDays m d) = CalendarDiffDays (k * m) (k * d) + +#endif + +------------------------------------------------------------------------------- +-- Gregorian +------------------------------------------------------------------------------- + +#if !MIN_VERSION_time(1,9,0) + +-- | Add months (clipped to last day), then add days +addGregorianDurationClip :: CalendarDiffDays -> Day -> Day +addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day + +-- | Add months (rolling over to next month), then add days +addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day +addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day + +-- | Calendrical difference, with as many whole months as possible +diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays +diffGregorianDurationClip day2 day1 = let + (y1,m1,d1) = toGregorian day1 + (y2,m2,d2) = toGregorian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed + +-- | Calendrical difference, with as many whole months as possible. +-- Same as 'diffGregorianDurationClip' for positive durations. +diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays +diffGregorianDurationRollOver day2 day1 = let + (y1,m1,d1) = toGregorian day1 + (y2,m2,d2) = toGregorian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed + +#endif + +------------------------------------------------------------------------------- +-- DayOfWeek +------------------------------------------------------------------------------- + +#if !MIN_VERSION_time(1,9,0) + +data DayOfWeek + = Monday + | Tuesday + | Wednesday + | Thursday + | Friday + | Saturday + | Sunday + deriving (Eq, Show, Read, Typeable) + +-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence. +-- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days. +instance Enum DayOfWeek where + toEnum i = + case mod i 7 of + 0 -> Sunday + 1 -> Monday + 2 -> Tuesday + 3 -> Wednesday + 4 -> Thursday + 5 -> Friday + _ -> Saturday + fromEnum Monday = 1 + fromEnum Tuesday = 2 + fromEnum Wednesday = 3 + fromEnum Thursday = 4 + fromEnum Friday = 5 + fromEnum Saturday = 6 + fromEnum Sunday = 7 + enumFromTo wd1 wd2 + | wd1 == wd2 = [wd1] + enumFromTo wd1 wd2 = wd1 : enumFromTo (succ wd1) wd2 + enumFromThenTo wd1 wd2 wd3 + | wd2 == wd3 = [wd1, wd2] + enumFromThenTo wd1 wd2 wd3 = wd1 : enumFromThenTo wd2 (toEnum $ (2 * fromEnum wd2) - (fromEnum wd1)) wd3 + +dayOfWeek :: Day -> DayOfWeek +dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3 + +toSomeDay :: DayOfWeek -> Day +toSomeDay d = ModifiedJulianDay (fromIntegral $ fromEnum d + 4) + +#if MIN_VERSION_time(1,8,0) +#define FORMAT_OPTS tl mpo i +#else +#define FORMAT_OPTS tl mpo +#endif + +instance FormatTime DayOfWeek where + formatCharacter 'u' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'u') + formatCharacter 'w' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'w') + formatCharacter 'a' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'a') + formatCharacter 'A' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'A') + formatCharacter _ = Nothing + +#endif diff --git a/src/Data/Time/Calendar/Easter/Compat.hs b/src/Data/Time/Calendar/Easter/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/Easter/Compat.hs @@ -0,0 +1,9 @@ +module Data.Time.Calendar.Easter.Compat ( + sundayAfter, + orthodoxPaschalMoon,orthodoxEaster, + gregorianPaschalMoon,gregorianEaster + )where + +import Data.Time.Orphans () + +import Data.Time.Calendar.Easter diff --git a/src/Data/Time/Calendar/Julian/Compat.hs b/src/Data/Time/Calendar/Julian/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/Julian/Compat.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +module Data.Time.Calendar.Julian.Compat ( + + toJulianYearAndDay, + fromJulianYearAndDay, + fromJulianYearAndDayValid, + showJulianYearAndDay, + isJulianLeapYear, + + toJulian,fromJulian,fromJulianValid,showJulian,julianMonthLength, + + -- calendrical arithmetic + -- e.g. "one month after March 31st" + addJulianMonthsClip,addJulianMonthsRollOver, + addJulianYearsClip,addJulianYearsRollOver, + addJulianDurationClip,addJulianDurationRollOver, + diffJulianDurationClip,diffJulianDurationRollOver, + ) where + +import Data.Time.Orphans () + +import Data.Time.Calendar.Julian +import Data.Time.Calendar.Compat + +#if !MIN_VERSION_time(1,9,0) + +-- | Add months (clipped to last day), then add days +addJulianDurationClip :: CalendarDiffDays -> Day -> Day +addJulianDurationClip (CalendarDiffDays m d) day = addDays d $ addJulianMonthsClip m day + +-- | Add months (rolling over to next month), then add days +addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day +addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMonthsRollOver m day + +-- | Calendrical difference, with as many whole months as possible +diffJulianDurationClip :: Day -> Day -> CalendarDiffDays +diffJulianDurationClip day2 day1 = let + (y1,m1,d1) = toJulian day1 + (y2,m2,d2) = toJulian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed + +-- | Calendrical difference, with as many whole months as possible. +-- Same as 'diffJulianDurationClip' for positive durations. +diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays +diffJulianDurationRollOver day2 day1 = let + (y1,m1,d1) = toJulian day1 + (y2,m2,d2) = toJulian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed + +#endif diff --git a/src/Data/Time/Calendar/MonthDay/Compat.hs b/src/Data/Time/Calendar/MonthDay/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/MonthDay/Compat.hs @@ -0,0 +1,7 @@ +module Data.Time.Calendar.MonthDay.Compat ( + monthAndDayToDayOfYear,monthAndDayToDayOfYearValid,dayOfYearToMonthAndDay,monthLength, + ) where + +import Data.Time.Orphans () + +import Data.Time.Calendar.MonthDay diff --git a/src/Data/Time/Calendar/OrdinalDate/Compat.hs b/src/Data/Time/Calendar/OrdinalDate/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/OrdinalDate/Compat.hs @@ -0,0 +1,17 @@ +module Data.Time.Calendar.OrdinalDate.Compat ( + toOrdinalDate, + fromOrdinalDate, + fromOrdinalDateValid, + showOrdinalDate, + isLeapYear, + mondayStartWeek, + sundayStartWeek, + fromMondayStartWeek, + fromMondayStartWeekValid, + fromSundayStartWeek, + fromSundayStartWeekValid, + ) where + +import Data.Time.Orphans () + +import Data.Time.Calendar.OrdinalDate diff --git a/src/Data/Time/Calendar/Private.hs b/src/Data/Time/Calendar/Private.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/Private.hs @@ -0,0 +1,65 @@ +module Data.Time.Calendar.Private where + +import Data.Time.Orphans () +import Data.Fixed + +data PadOption = Pad Int Char | NoPad + +showPadded :: PadOption -> String -> String +showPadded NoPad s = s +showPadded (Pad i c) s = replicate (i - length s) c ++ s + +class (Num t,Ord t,Show t) => ShowPadded t where + showPaddedNum :: PadOption -> t -> String + +instance ShowPadded Integer where + showPaddedNum NoPad i = show i + showPaddedNum pad i | i < 0 = '-':(showPaddedNum pad (negate i)) + showPaddedNum pad i = showPadded pad $ show i + +instance ShowPadded Int where + showPaddedNum NoPad i = show i + showPaddedNum _pad i | i == minBound = show i + showPaddedNum pad i | i < 0 = '-':(showPaddedNum pad (negate i)) + showPaddedNum pad i = showPadded pad $ show i + +show2Fixed :: Pico -> String +show2Fixed x | x < 10 = '0':(showFixed True x) +show2Fixed x = showFixed True x + +show2 :: (ShowPadded t) => t -> String +show2 = showPaddedNum $ Pad 2 '0' + +show3 :: (ShowPadded t) => t -> String +show3 = showPaddedNum $ Pad 3 '0' + +show4 :: (ShowPadded t) => t -> String +show4 = showPaddedNum $ Pad 4 '0' + +mod100 :: (Integral i) => i -> i +mod100 x = mod x 100 + +div100 :: (Integral i) => i -> i +div100 x = div x 100 + +clip :: (Ord t) => t -> t -> t -> t +clip a _ x | x < a = a +clip _ b x | x > b = b +clip _ _ x = x + +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) diff --git a/src/Data/Time/Calendar/WeekDate/Compat.hs b/src/Data/Time/Calendar/WeekDate/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/WeekDate/Compat.hs @@ -0,0 +1,10 @@ +module Data.Time.Calendar.WeekDate.Compat ( + toWeekDate, + fromWeekDate, + fromWeekDateValid, + showWeekDate, + ) where + +import Data.Time.Orphans () + +import Data.Time.Calendar.WeekDate diff --git a/src/Data/Time/Clock/Compat.hs b/src/Data/Time/Clock/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/Compat.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} +module Data.Time.Clock.Compat ( + -- * Universal Time + -- | Time as measured by the Earth. + UniversalTime(..), + + -- * Absolute intervals, DiffTime + DiffTime, + secondsToDiffTime, + picosecondsToDiffTime, + diffTimeToPicoseconds, + + -- * UTCTime + UTCTime (..), + + -- * NominalDiffTime + NominalDiffTime, + secondsToNominalDiffTime, + nominalDiffTimeToSeconds, + nominalDay, + + -- * UTC differences + addUTCTime, + diffUTCTime, + + -- * Current time + getCurrentTime, + getTime_resolution + ) where + +import Data.Time.Orphans () + +import Data.Time.Clock +import Data.Fixed (Pico) + +#if !MIN_VERSION_time(1,9,1) + +-- | Create a 'NominalDiffTime' from a number of seconds. +secondsToNominalDiffTime :: Pico -> NominalDiffTime +secondsToNominalDiffTime = realToFrac + +-- | Get the seconds in a 'NominalDiffTime'. +nominalDiffTimeToSeconds :: NominalDiffTime -> Pico +nominalDiffTimeToSeconds = realToFrac + +#endif + +#if !MIN_VERSION_time(1,8,0) +-- | One day in 'NominalDiffTime'. +nominalDay :: NominalDiffTime +nominalDay = 86400 +#endif + +#if !MIN_VERSION_time(1,8,0) +-- | The resolution of 'getSystemTime', 'getCurrentTime', 'getPOSIXTime' +getTime_resolution :: DiffTime +getTime_resolution = 1E-6 -- microsecond +#endif + +#if !MIN_VERSION_time(1,6,0) +-- | Get the number of picoseconds in a 'DiffTime'. +diffTimeToPicoseconds :: DiffTime -> Integer +#if MIN_VERSION_time(1,4,0) +diffTimeToPicoseconds = truncate . (1000000000000 *) +#else +diffTimeToPicoseconds = truncate . toRational . (1000000000000 *) +#endif +#endif diff --git a/src/Data/Time/Clock/POSIX/Compat.hs b/src/Data/Time/Clock/POSIX/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/POSIX/Compat.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} +module Data.Time.Clock.POSIX.Compat ( + posixDayLength,POSIXTime,posixSecondsToUTCTime,utcTimeToPOSIXSeconds,getPOSIXTime,getCurrentTime, + systemToPOSIXTime, + ) where + +import Data.Time.Orphans () + +import Data.Time +import Data.Time.Clock.POSIX +import Data.Time.Clock.System.Compat + +#if !MIN_VERSION_time(1,8,0) +systemToPOSIXTime :: SystemTime -> POSIXTime +systemToPOSIXTime (MkSystemTime s ns) = (fromIntegral s) + (fromIntegral ns) * 1E-9 +#endif diff --git a/src/Data/Time/Clock/System/Compat.hs b/src/Data/Time/Clock/System/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/System/Compat.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.Time.Clock.System.Compat ( + systemEpochDay, + SystemTime(..), + truncateSystemTimeLeapSecond, + getSystemTime, + systemToUTCTime, + utcToSystemTime, + systemToTAITime, + ) where + +import Data.Time.Orphans () + +#if MIN_VERSION_time(1,8,0) +import Data.Time.Clock.System +#else + +import Control.DeepSeq (NFData (..)) +import Data.Int (Int64) +import Data.Word (Word32) +import Data.Typeable (Typeable) + +import Data.Time.Clock.TAI.Compat +import Data.Time.Clock.POSIX +import Data.Time.Compat + +-- | 'SystemTime' is time returned by system clock functions. +-- Its semantics depends on the clock function, but the epoch is typically the beginning of 1970. +-- Note that 'systemNanoseconds' of 1E9 to 2E9-1 can be used to represent leap seconds. +data SystemTime = MkSystemTime + { systemSeconds :: {-# UNPACK #-} !Int64 + , systemNanoseconds :: {-# UNPACK #-} !Word32 + } deriving (Eq,Ord,Show,Typeable) + +instance NFData SystemTime where + rnf a = a `seq` () + +-- | Get the system time, epoch start of 1970 UTC, leap-seconds ignored. +-- 'getSystemTime' is typically much faster than 'getCurrentTime'. +getSystemTime :: IO SystemTime + + +-- Use gettimeofday +getSystemTime = do + t <- getPOSIXTime + let secs = truncate t + let nsecs = truncate $ 1000000000 * (t - fromIntegral secs) + return (MkSystemTime secs nsecs) + +-- | Map leap-second values to the start of the following second. +-- The resulting 'systemNanoseconds' will always be in the range 0 to 1E9-1. +truncateSystemTimeLeapSecond :: SystemTime -> SystemTime +truncateSystemTimeLeapSecond (MkSystemTime seconds nanoseconds) | nanoseconds >= 1000000000 = MkSystemTime (succ seconds) 0 +truncateSystemTimeLeapSecond t = t + +-- | Convert 'SystemTime' to 'UTCTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. +systemToUTCTime :: SystemTime -> UTCTime +systemToUTCTime (MkSystemTime seconds nanoseconds) = let + days :: Int64 + timeSeconds :: Int64 + (days, timeSeconds) = seconds `divMod` 86400 + + day :: Day + day = addDays (fromIntegral days) systemEpochDay + + timeNanoseconds :: Int64 + timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds) + + timePicoseconds :: Int64 + timePicoseconds = timeNanoseconds * 1000 + + time :: DiffTime + time = picosecondsToDiffTime $ fromIntegral timePicoseconds + in UTCTime day time + +-- | Convert 'UTCTime' to 'SystemTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. +utcToSystemTime :: UTCTime -> SystemTime +utcToSystemTime (UTCTime day time) = let + days :: Int64 + days = fromIntegral $ diffDays day systemEpochDay + + timePicoseconds :: Int64 + timePicoseconds = fromIntegral $ diffTimeToPicoseconds time + + timeNanoseconds :: Int64 + timeNanoseconds = timePicoseconds `div` 1000 + + timeSeconds :: Int64 + nanoseconds :: Int64 + (timeSeconds,nanoseconds) = if timeNanoseconds >= 86400000000000 then (86399,timeNanoseconds - 86399000000000) else timeNanoseconds `divMod` 1000000000 + + seconds :: Int64 + seconds = days * 86400 + timeSeconds + + in MkSystemTime seconds $ fromIntegral nanoseconds + +systemEpochAbsolute :: AbsoluteTime +systemEpochAbsolute = taiNominalDayStart systemEpochDay + +-- | Convert 'SystemTime' to 'AbsoluteTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' TAI. +systemToTAITime :: SystemTime -> AbsoluteTime +systemToTAITime (MkSystemTime s ns) = let + diff :: DiffTime + diff = (fromIntegral s) + (fromIntegral ns) * 1E-9 + in addAbsoluteTime diff systemEpochAbsolute + +-- | The day of the epoch of 'SystemTime', 1970-01-01 +systemEpochDay :: Day +systemEpochDay = ModifiedJulianDay 40587 + +#endif diff --git a/src/Data/Time/Clock/TAI/Compat.hs b/src/Data/Time/Clock/TAI/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/TAI/Compat.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +module Data.Time.Clock.TAI.Compat ( + -- * TAI arithmetic + AbsoluteTime,taiEpoch,addAbsoluteTime,diffAbsoluteTime, + taiNominalDayStart, + + -- * leap-second map type + LeapSecondMap', + + -- * conversion between UTC and TAI with map + utcDayLength,utcToTAITime,taiToUTCTime, + + taiClock, + ) where + +import Data.Time.Orphans () + +import Data.Time.Compat +import Data.Time.Clock.TAI + +-- | This type is either 'LeapSecondMap' or 'LeapSecondTable', depending +-- on the version of @time@ (changed in @time-1.7.0@). +#if MIN_VERSION_time(1,7,0) +type LeapSecondMap' = LeapSecondMap +#else +type LeapSecondMap' = LeapSecondTable +#endif + +#if !(MIN_VERSION_time(1,8,0)) +taiNominalDayStart :: Day -> AbsoluteTime +taiNominalDayStart (ModifiedJulianDay ds) = + addAbsoluteTime (secondsToDiffTime (ds * 86400)) taiEpoch + +-- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention. +taiClock :: Maybe (DiffTime,IO AbsoluteTime) +taiClock = Nothing +#endif diff --git a/src/Data/Time/Compat.hs b/src/Data/Time/Compat.hs --- a/src/Data/Time/Compat.hs +++ b/src/Data/Time/Compat.hs @@ -1,54 +1,13 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Compatibility with the --- package for the --- \"new\" package. --- --- This is useful for writing portable code; in particular, if you're --- using the --- package and you want your code to build with both GHC 7.6 and earlier --- versions. The version of @directory@ used with GHC 7.6 changed --- a dependency from @old-time@ to @time@ which means its --- @getModificationTime@ function now returns a 'Time.UTCTime' instead of --- a 'OldTime.ClockTime'. This type affects the public API of many --- libraries that use it. To make such libraries portable, port your --- code to use the @time@ package and to only rely on 'Time.UTCTime' in --- its public API, and call 'toUTCTime' on the values returned by --- functions like @getModificationTime@, for example: --- --- >fmap toUTCTime getModificationTime --- --- If you're using @directory-1.2@, 'toUTCTime' will just be 'id' and the --- original value is returned intact. If you're using an older --- @directory@, for example because you're building with GHC 7.4, the --- 'OldTime.ClockTime' returned by @getModificationTime@ will be --- converted to a 'Time.UTCTime' and will be compatible with your code --- ported to the new @time@ package. -module Data.Time.Compat - ( -- * Converting between representations - ToUTCTime(..) - ) - where - -import qualified Data.Time as Time -import qualified System.Time as OldTime - -class ToUTCTime a where - toUTCTime :: a -> Time.UTCTime - -instance ToUTCTime Time.UTCTime where - toUTCTime = id +module Data.Time.Compat ( + module Data.Time.Calendar.Compat, + module Data.Time.Clock.Compat, + module Data.Time.LocalTime.Compat, + module Data.Time.Format.Compat, + ) where -instance ToUTCTime OldTime.ClockTime where - toUTCTime = toUTCTime . OldTime.toUTCTime +import Data.Time.Orphans () -instance ToUTCTime OldTime.CalendarTime where - toUTCTime OldTime.CalendarTime{..} = - Time.UTCTime day diffTime - where - year = fromIntegral ctYear - month = fromEnum ctMonth + 1 - day = Time.fromGregorian year month ctDay - sec = ctHour*60^2 + ctMin*60 + ctSec - pico = fromIntegral sec*10^12 + ctPicosec - diffTime = Time.picosecondsToDiffTime pico +import Data.Time.Calendar.Compat +import Data.Time.Clock.Compat +import Data.Time.LocalTime.Compat +import Data.Time.Format.Compat diff --git a/src/Data/Time/Format/Compat.hs b/src/Data/Time/Format/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Format/Compat.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} +module Data.Time.Format.Compat ( + -- * UNIX-style formatting + FormatTime(),formatTime, + + -- * UNIX-style parsing + -- ** __Note__ in compat mode acceptWS argument is ignored, it's always 'True'. + parseTimeM, parseTimeOrError, + readSTime, readPTime, + parseTime, readTime, readsTime, + ParseTime(), + + -- * Locale + TimeLocale(..), + + defaultTimeLocale, + + iso8601DateFormat, + rfc822DateFormat, + ) where + +import Data.Time.Orphans () + +import Data.Time.Format + +#if !MIN_VERSION_time(1,5,0) +import System.Locale (TimeLocale, defaultTimeLocale, iso8601DateFormat, rfc822DateFormat) +import qualified Control.Monad.Fail as Fail +import Text.ParserCombinators.ReadP (readP_to_S, readS_to_P, ReadP) + +parseTimeM + :: (Fail.MonadFail m, ParseTime t) + => Bool -- ^ Accept leading and trailing whitespace? + -> TimeLocale -- ^ Time locale. + -> String -- ^ Format string. + -> String -- ^ Input string. + -> m t -- ^ Return the time value, or fail if the in +parseTimeM _acceptWS l fmt s = case parseTime l fmt s of + Just x -> return x + Nothing -> Fail.fail "parseTimeM: no parse" + +parseTimeOrError + :: ParseTime t + => Bool -- ^ Accept leading and trailing whitespace? + -> TimeLocale -- ^ Time locale. + -> String -- ^ Format string. + -> String -- ^ Input string. + -> t -- ^ The time value. +parseTimeOrError _acceptWS l fmt s = case parseTime l fmt s of + Just x -> x + Nothing -> error "parseTimeOrError: no parse" + +-- | Parse a time value given a format string. See 'parseTimeM' for details. +readSTime :: ParseTime t => + Bool -- ^ Accept leading whitespace? + -> TimeLocale -- ^ Time locale. + -> String -- ^ Format string + -> ReadS t +readSTime _acceptWS l f = readsTime l f + +-- | Parse a time value given a format string. See 'parseTimeM' for details. +readPTime :: ParseTime t => + Bool -- ^ Accept leading whitespace? + -> TimeLocale -- ^ Time locale. + -> String -- ^ Format string + -> ReadP t +readPTime acceptWS l f = readS_to_P (readSTime acceptWS l f) +#endif diff --git a/src/Data/Time/Format/ISO8601/Compat.hs b/src/Data/Time/Format/ISO8601/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Format/ISO8601/Compat.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE CPP #-} +module Data.Time.Format.ISO8601.Compat ( + -- * Format + Format, + formatShowM, + formatShow, + formatReadP, + formatParseM, + -- * Common formats + ISO8601(..), + iso8601Show, + iso8601ParseM, + -- * All formats + 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, + zonedTimeFormat, + utcTimeFormat, + dayAndTimeFormat, + timeAndOffsetFormat, + durationDaysFormat, + durationTimeFormat, + alternativeDurationDaysFormat, + alternativeDurationTimeFormat, + intervalFormat, + recurringIntervalFormat, + ) where + +import Data.Time.Orphans () + +#if MIN_VERSION_time(1,9,0) +import Data.Time.Format.ISO8601 +#else + +import Control.Monad.Fail +import Prelude hiding (fail) +import Data.Monoid +import Data.Ratio +import Data.Fixed +import Text.ParserCombinators.ReadP +import Data.Format +import Data.Time +import Data.Time.Calendar.Compat +import Data.Time.Calendar.OrdinalDate.Compat +import Data.Time.Calendar.WeekDate.Compat +import Data.Time.LocalTime.Compat +import Data.Time.Calendar.Private + +data FormatExtension = + -- | ISO 8601:2004(E) sec. 2.3.4. Use hyphens and colons. + ExtendedFormat | + -- | ISO 8601:2004(E) sec. 2.3.3. Omit hyphens and colons. "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 = let + toTimeZone (sign,(h,m)) = minutesToTimeZone $ sign * (h * 60 + m) + fromTimeZone tz = let + mm = timeZoneMinutes tz + hm = quotRem (abs mm) 60 + in (signum mm,hm) + in isoMap toTimeZone fromTimeZone $ + mandatorySignFormat <**> extColonFormat fe (integerFormat NoSign (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.2 +zonedTimeFormat :: Format Day -> Format TimeOfDay -> FormatExtension -> Format ZonedTime +zonedTimeFormat fday ftod fe = isoMap (\(lt,tz) -> ZonedTime lt tz) (\(ZonedTime lt tz) -> (lt,tz)) $ timeAndOffsetFormat (localTimeFormat fday ftod) fe + +-- | ISO 8601:2004(E) sec. 4.3.2 +utcTimeFormat :: Format Day -> Format TimeOfDay -> Format UTCTime +utcTimeFormat fday ftod = isoMap (localTimeToUTC utc) (utcToLocalTime utc) $ withUTCDesignator $ localTimeFormat fday 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,"0D") $ isoMap toCT fromCT $ + (<**>) daysDesigs $ optionalFormat (0,(0,0)) $ 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 + +class ISO8601 t where + -- | The most commonly used ISO 8601 format for this type. + iso8601Format :: Format t + +-- | Show in the most commonly used ISO 8601 format. +iso8601Show :: ISO8601 t => t -> String +iso8601Show = formatShow iso8601Format + +-- | Parse the most commonly used ISO 8601 format. +iso8601ParseM :: ( +#if MIN_VERSION_base(4,9,0) + MonadFail m +#else + Monad m +#endif + ,ISO8601 t) => String -> m t +iso8601ParseM = formatParseM iso8601Format + +-- | @yyyy-mm-dd@ (ISO 8601:2004(E) sec. 4.1.2.2 extended format) +instance ISO8601 Day where + iso8601Format = calendarFormat ExtendedFormat +-- | @hh:mm:ss[.sss]@ (ISO 8601:2004(E) sec. 4.2.2.2, 4.2.2.4(a) extended format) +instance ISO8601 TimeOfDay where + iso8601Format = timeOfDayFormat ExtendedFormat +-- | @±hh:mm@ (ISO 8601:2004(E) sec. 4.2.5.1 extended format) +instance ISO8601 TimeZone where + iso8601Format = timeOffsetFormat ExtendedFormat +-- | @yyyy-mm-ddThh:mm:ss[.sss]@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +instance ISO8601 LocalTime where + iso8601Format = localTimeFormat iso8601Format iso8601Format +-- | @yyyy-mm-ddThh:mm:ss[.sss]±hh:mm@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +instance ISO8601 ZonedTime where + iso8601Format = zonedTimeFormat iso8601Format iso8601Format ExtendedFormat +-- | @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +instance ISO8601 UTCTime where + iso8601Format = utcTimeFormat iso8601Format iso8601Format +-- | @PyYmMdD@ (ISO 8601:2004(E) sec. 4.4.3.2) +instance ISO8601 CalendarDiffDays where + iso8601Format = durationDaysFormat +-- | @PyYmMdDThHmMs[.sss]S@ (ISO 8601:2004(E) sec. 4.4.3.2) +instance ISO8601 CalendarDiffTime where + iso8601Format = durationTimeFormat + +#endif diff --git a/src/Data/Time/LocalTime/Compat.hs b/src/Data/Time/LocalTime/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/LocalTime/Compat.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +module Data.Time.LocalTime.Compat ( + -- * Time zones + TimeZone(..),timeZoneOffsetString,timeZoneOffsetString',minutesToTimeZone,hoursToTimeZone,utc, + + -- getting the locale time zone + getTimeZone,getCurrentTimeZone, + + -- * Time of day + TimeOfDay(..),midnight,midday,makeTimeOfDayValid, + timeToDaysAndTimeOfDay,daysAndTimeOfDayToTime, + utcToLocalTimeOfDay,localToUTCTimeOfDay, + timeToTimeOfDay,timeOfDayToTime, + dayFractionToTimeOfDay,timeOfDayToDayFraction, + + -- * CalendarDiffTime + CalendarDiffTime (..), + calendarTimeDays, calendarTimeTime, scaleCalendarDiffTime, + + -- * Local Time + LocalTime(..), + + addLocalTime,diffLocalTime, + + -- converting UTC and UT1 times to LocalTime + utcToLocalTime,localTimeToUTC,ut1ToLocalTime,localTimeToUT1, + + -- * Zoned Time + ZonedTime(..),utcToZonedTime,zonedTimeToUTC,getZonedTime,utcToLocalZonedTime, + ) where + +import Data.Time.Orphans () + +import Data.Time.LocalTime +import Data.Time.Clock.Compat +import Data.Time.Calendar.Compat + +import Data.Fixed (Pico (..), showFixed, divMod') +import Data.Monoid (Monoid (..)) +import Data.Data (Data, Typeable) +import Data.Semigroup (Semigroup (..)) + +------------------------------------------------------------------------------- +-- TimeOfDay +------------------------------------------------------------------------------- + +#if !MIN_VERSION_time(1,9,0) + +-- | Convert a period of time into a count of days and a time of day since midnight. +-- The time of day will never have a leap second. +timeToDaysAndTimeOfDay :: NominalDiffTime -> (Integer,TimeOfDay) +timeToDaysAndTimeOfDay dt = let + s = realToFrac dt + (m,ms) = divMod' s 60 + (h,hm) = divMod' m 60 + (d,dh) = divMod' h 24 + in (d,TimeOfDay dh hm ms) + +-- | Convert a count of days and a time of day since midnight into a period of time. +daysAndTimeOfDayToTime :: Integer -> TimeOfDay -> NominalDiffTime +daysAndTimeOfDayToTime d (TimeOfDay dh hm ms) = (+) (realToFrac ms) $ (*) 60 $ (+) (realToFrac hm) $ (*) 60 $ (+) (realToFrac dh) $ (*) 24 $ realToFrac d + +#endif + +------------------------------------------------------------------------------- +-- CalendarDiffTime +------------------------------------------------------------------------------- + +#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_base(1,9,2) +deriving instance Typeable CalendarDiffTime +deriving instance Data CalendarDiffTime +#endif + +#if !MIN_VERSION_time(1,9,2) + +data CalendarDiffTime = CalendarDiffTime + { ctMonths :: Integer + , ctTime :: NominalDiffTime + } deriving (Eq, + Data + ,Typeable + ) + +-- | Additive +instance Semigroup CalendarDiffTime where + + CalendarDiffTime m1 d1 <> CalendarDiffTime m2 d2 = CalendarDiffTime (m1 + m2) (d1 + d2) +instance Monoid CalendarDiffTime where + mempty = CalendarDiffTime 0 0 + mappend = (<>) + +instance Show CalendarDiffTime where + show (CalendarDiffTime m t) = "P" ++ show m ++ "MT" ++ 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) +#endif + +------------------------------------------------------------------------------- +-- LocalTime +------------------------------------------------------------------------------- + +#if !MIN_VERSION_time(1,9,0) + +-- | addLocalTime a b = a + b +addLocalTime :: NominalDiffTime -> LocalTime -> LocalTime +addLocalTime x = utcToLocalTime utc . addUTCTime x . localTimeToUTC utc + +-- | diffLocalTime a b = a - b +diffLocalTime :: LocalTime -> LocalTime -> NominalDiffTime +diffLocalTime a b = diffUTCTime (localTimeToUTC utc a) (localTimeToUTC utc b) + +#endif diff --git a/src/Data/Time/Orphans.hs b/src/Data/Time/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Orphans.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +module Data.Time.Orphans where + +import Data.Orphans () + +import Control.DeepSeq (NFData (..)) +import Data.Time +import Data.Time.Clock +import Data.Time.Clock.TAI +import Data.Time.Format + +#if !MIN_VERSION_time(1,4,0) +instance NFData Day where + rnf (ModifiedJulianDay d) = rnf d + +instance NFData UniversalTime where + rnf (ModJulianDate d) = rnf d + +instance NFData DiffTime where + rnf d = d `seq` () + +instance NFData AbsoluteTime where + rnf d = d `seq` () + +instance NFData UTCTime where + rnf (UTCTime d t) = rnf d `seq` rnf t + +instance NFData NominalDiffTime where + rnf d = d `seq` () + +instance NFData LocalTime where + rnf (LocalTime d tod) = rnf d `seq` rnf tod + +instance NFData ZonedTime where + rnf (ZonedTime lt tz) = rnf lt `seq` rnf tz + +instance NFData TimeOfDay where + rnf (TimeOfDay h m s) = rnf h `seq` rnf m `seq` rnf s + +instance NFData TimeZone where + rnf (TimeZone a b c) = rnf a `seq` rnf b `seq` rnf c +#endif + +#if !MIN_VERSION_time(1,6,0) +instance ParseTime UniversalTime where + -- substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + -- parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l xs = localTimeToUT1 0 (buildTime l xs) + +instance FormatTime UniversalTime where + formatCharacter c = fmap (\f tl fo t -> f tl fo (ut1ToLocalTime 0 t)) (formatCharacter c) +#endif diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,68 @@ +module Main where + +import Control.DeepSeq (force) + +import Data.Time.Calendar.Compat +import Data.Time.Clock.System.Compat +import Data.Time.Clock.TAI.Compat +import Data.Time.Compat +import Data.Time.Format.Compat +import Test.HUnit.Base ((@?=)) + +main :: IO () +main = do + utc <- getCurrentTime + + -- UTCTime + putStrLn $ formatTime defaultTimeLocale rfc822DateFormat (force utc) + + -- ZonedTime + zt <- getZonedTime + putStrLn $ formatTime defaultTimeLocale rfc822DateFormat (force zt) + + -- SystemTime + st <- getSystemTime + print $ force st + + -- FormatTime DayOfWeek + formatTime defaultTimeLocale "%u %w %a %A" Monday @?= "1 1 Mon Monday" + + -- TAI taiNominalDayStart + show (taiNominalDayStart (ModifiedJulianDay 123)) @?= "1859-03-20 00:00:00 TAI" + +_ParseTimeInstances :: [()] +_ParseTimeInstances = + [ () -- test (undefined :: CalendarDiffTime) + , test (undefined :: Day) + , () -- test (undefined :: DiffTime) + , () -- test (undefined :: NominalDiffTime) + , test (undefined :: UTCTime) + , test (undefined :: UniversalTime) + , () -- test (undefined :: CalendarDiffTime) + , test (undefined :: TimeZone) + , test (undefined :: TimeOfDay) + , test (undefined :: LocalTime) + , test (undefined :: ZonedTime) + ] + where + test :: ParseTime t => t -> () + test _ = () + +_FormatTimeInstances :: [()] +_FormatTimeInstances = + [ () -- test (undefined :: CalendarDiffTime) + , test (undefined :: Day) + , () -- test (undefined :: DiffTime) + , () -- test (undefined :: NominalDiffTime) + , test (undefined :: UTCTime) + , test (undefined :: UniversalTime) + , () -- test (undefined :: CalendarDiffTime) + , test (undefined :: TimeZone) + , test (undefined :: TimeOfDay) + , test (undefined :: LocalTime) + , test (undefined :: ZonedTime) + , test (undefined :: DayOfWeek) + ] + where + test :: FormatTime t => t -> () + test _ = () diff --git a/time-compat.cabal b/time-compat.cabal --- a/time-compat.cabal +++ b/time-compat.cabal @@ -1,29 +1,97 @@ -name : time-compat -version : 0.1.0.3 -homepage : http://hub.darcs.net/dag/time-compat -bug-reports : http://hub.darcs.net/dag/time-compat/issues -category : System -cabal-version : >= 1.10 -build-type : Simple +cabal-version: 2.2 +name: time-compat +version: 1.9.2 +tested-with: GHC ==7.8.4 || ==7.6.3 || ==7.4.2 +synopsis: Compatibility package for time +description: + This packages tries to compat as much of @time@ features as possible. + . + /TODO:/ Difference type @ParseTime@ and @FormatTime@ instances are missing. -license : BSD3 -license-file : LICENSE -author : Dag Odenhall -maintainer : dag.odenhall@gmail.com +category: Time, Compatibility +license: BSD-3-Clause +license-file: LICENSE +maintainer: Oleg Grenrus +author: Ashley Yakeley -synopsis : Compatibility with old-time for the time package -description : Compatibility with the package for the \"new\" -