diff --git a/Data/Micro.hs b/Data/Micro.hs deleted file mode 100644 --- a/Data/Micro.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- #hide -module Data.Micro where - -import Prelude -import Control.DeepSeq -import Data.AdditiveGroup -import Data.Basis -import Data.Data -import Data.Int -import Data.Ix -import Data.Ratio -import Data.VectorSpace -#if !SHOW_INTERNAL -import Text.Printf -#endif - -newtype Micro = Micro Int64 - deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) - -#if SHOW_INTERNAL -deriving instance Show Micro -#else -instance Show Micro where - show (Micro a) = case compare a 0 of - LT -> printf "-%d.%06u" `uncurry` quotRem (negate a) 1000000 - EQ -> "0" - GT -> printf "%d.%06u" `uncurry` quotRem a 1000000 -#endif - -{-# INLINE toMicro #-} -toMicro :: Rational -> Micro -toMicro r = Micro (fromInteger $ 1000000 * numerator r `div` denominator r) - -#if INSTANCE_NUM -instance Num Micro where - {-# INLINE (+) #-} - {-# INLINE (-) #-} - {-# INLINE (*) #-} - {-# INLINE negate #-} - {-# INLINE abs #-} - {-# INLINE signum #-} - {-# INLINE fromInteger #-} - Micro a + Micro b = Micro (a + b) - Micro a - Micro b = Micro (a - b) - Micro a * Micro b = Micro ((quot a 1000) * (quot b 1000)) - negate (Micro a) = Micro (negate a) - abs (Micro a) = Micro (abs a) - signum (Micro a) = Micro (signum a * 1000000) - fromInteger a = Micro (fromInteger a * 1000000) - -instance Real Micro where - {-# INLINE toRational #-} - toRational (Micro a) = toInteger a % 1000000 - -instance Fractional Micro where - {-# INLINE (/) #-} - {-# INLINE recip #-} - {-# INLINE fromRational #-} - Micro a / Micro b = Micro (quot (a * 1000) (b * 1000)) - recip (Micro a) = Micro (quot 1000000 a) - fromRational = toMicro - -instance RealFrac Micro where - {-# INLINE properFraction #-} - properFraction a = (fromIntegral q, r) where - (q, r) = microQuotRem a (Micro 1000000) -#endif - -{-# INLINE microQuotRem #-} -microQuotRem :: Micro -> Micro -> (Int64, Micro) -microQuotRem (Micro a) (Micro b) = (n, Micro f) where - (n, f) = quotRem a b - -instance AdditiveGroup Micro where - {-# INLINE zeroV #-} - zeroV = Micro 0 - {-# INLINE (^+^) #-} - Micro a ^+^ Micro b = Micro (a + b) - {-# INLINE negateV #-} - negateV (Micro a) = Micro (negate a) - -instance VectorSpace Micro where - type Scalar Micro = Rational - {-# INLINE (*^) #-} - s *^ Micro a = Micro . fromInteger $ - toInteger a * numerator s `quot` denominator s - -instance HasBasis Micro where - type Basis Micro = () - {-# INLINE basisValue #-} - basisValue () = Micro 1000000 - {-# INLINE decompose #-} - decompose (Micro a) = [((), fromIntegral a % 1000000)] - {-# INLINE decompose' #-} - decompose' (Micro a) = const (fromIntegral a % 1000000) - -{-# INLINE (^/^) #-} -(^/^) :: (HasBasis v, Basis v ~ (), Scalar v ~ s, Fractional s) => v -> v -> s -x ^/^ y = decompose' x () / decompose' y () - diff --git a/Data/Thyme.hs b/Data/Thyme.hs deleted file mode 100644 --- a/Data/Thyme.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Data.Thyme - ( module Data.Thyme.Calendar - , module Data.Thyme.Clock - , module Data.Thyme.Format - , module Data.Thyme.LocalTime - ) where - -import Data.Thyme.Calendar -import Data.Thyme.Clock -import Data.Thyme.Format -import Data.Thyme.LocalTime - diff --git a/Data/Thyme/Calendar.hs b/Data/Thyme/Calendar.hs deleted file mode 100644 --- a/Data/Thyme/Calendar.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module Data.Thyme.Calendar ( - -- * Days - Day (..) - -- * Gregorian calendar - , Year, Month, DayOfMonth - , YearMonthDay (..) - , isLeapYear - , module Data.Thyme.Calendar - ) where - -import Prelude hiding ((.)) -import Control.Applicative -import Control.Category -import Control.Lens -import Data.Thyme.Calendar.OrdinalDate -import Data.Thyme.Calendar.MonthDay -import Data.Thyme.Calendar.Internal -import Data.Thyme.Format.Internal -import Data.Thyme.TH - -{-# INLINE yearMonthDay #-} -yearMonthDay :: Simple Iso OrdinalDate YearMonthDay -yearMonthDay = iso fromOrdinal toOrdinal where - - {-# INLINEABLE fromOrdinal #-} - fromOrdinal :: OrdinalDate -> YearMonthDay - fromOrdinal (OrdinalDate y yd) = (YearMonthDay y m d) where - MonthDay m d = view (monthDay (isLeapYear y)) yd - - {-# INLINEABLE toOrdinal #-} - toOrdinal :: YearMonthDay -> OrdinalDate - toOrdinal (YearMonthDay y m d) = OrdinalDate y $ - review (monthDay (isLeapYear y)) (MonthDay m d) - -{-# INLINE gregorian #-} -gregorian :: Simple Iso Day YearMonthDay -gregorian = ordinalDate . yearMonthDay - -{-# INLINEABLE fromGregorianValid #-} -fromGregorianValid :: YearMonthDay -> Maybe Day -fromGregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y - <$> monthDayToDayOfYearValid (isLeapYear y) (MonthDay m d) - -{-# INLINEABLE showGregorian #-} -showGregorian :: Day -> String -showGregorian (view gregorian -> YearMonthDay y m d) = - shows04 y . (:) '-' . shows02 m . (:) '-' . shows02 d $ "" - -{-# INLINE gregorianMonthLength #-} -gregorianMonthLength :: Year -> Month -> Int -gregorianMonthLength = monthLength . isLeapYear - --- TODO: addGregorianMonthsClip addGregorianMonthsRollover --- TODO: addGregorianYearsClip addGregorianYearsRollover - --- * Lenses -thymeLenses ''Day -thymeLenses ''YearMonthDay - diff --git a/Data/Thyme/Calendar/Internal.hs b/Data/Thyme/Calendar/Internal.hs deleted file mode 100644 --- a/Data/Thyme/Calendar/Internal.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- #hide -module Data.Thyme.Calendar.Internal where - -import Prelude -import Control.DeepSeq -import Control.Lens -import Data.AffineSpace -import Data.Data -import Data.Int -import Data.Ix - --- | The Modified Julian Day is a standard count of days, with zero being --- the day 1858-11-17. -newtype Day = ModifiedJulianDay - { toModifiedJulianDay :: Int64 - } deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) - -#if 1 /*SHOW_INTERNAL*/ -deriving instance Show Day -#endif - -instance AffineSpace Day where - type Diff Day = Int - {-# INLINE (.-.) #-} - ModifiedJulianDay a .-. ModifiedJulianDay b = fromIntegral (a - b) - {-# INLINE (.+^) #-} - ModifiedJulianDay a .+^ d = ModifiedJulianDay (a + fromIntegral d) - ------------------------------------------------------------------------- - -type Year = Int -type Month = Int -type DayOfMonth = Int - -data YearMonthDay = YearMonthDay - { ymdYear :: {-# UNPACK #-}!Year - , ymdMonth :: {-# UNPACK #-}!Month - , ymdDay :: {-# UNPACK #-}!DayOfMonth - } deriving (Eq, Ord, Data, Typeable, Show) - -instance NFData YearMonthDay - ------------------------------------------------------------------------- - --- | Gregorian leap year? -{-# INLINE isLeapYear #-} -isLeapYear :: Year -> Bool -isLeapYear y = mod y 4 == 0 && (mod y 400 == 0 || mod y 100 /= 0) - -type DayOfYear = Int -data OrdinalDate = OrdinalDate - { odYear :: {-# UNPACK #-}!Year - , odDay :: {-# UNPACK #-}!DayOfYear - } deriving (Eq, Ord, Data, Typeable, Show) - -instance NFData OrdinalDate - -{-# INLINE ordinalDate #-} -ordinalDate :: Simple Iso Day OrdinalDate -ordinalDate = iso toOrd fromOrd where - - {-# INLINEABLE toOrd #-} - toOrd :: Day -> OrdinalDate - toOrd (ModifiedJulianDay mjd) = OrdinalDate - (fromIntegral year) (fromIntegral yd) where - -- pilfered - a = mjd + 678575 - quadcent = div a 146097 - b = mod a 146097 - cent = min (div b 36524) 3 - c = b - cent * 36524 - quad = div c 1461 - d = mod c 1461 - y = min (div d 365) 3 - yd = d - y * 365 + 1 - year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 - - {-# INLINEABLE fromOrd #-} - fromOrd :: OrdinalDate -> Day - fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where - -- pilfered - y = fromIntegral (year - 1) - mjd = 365 * y + div y 4 - div y 100 + div y 400 - 678576 - + clip 1 (if isLeapYear year then 366 else 365) (fromIntegral yd) - clip a b = max a . min b - ------------------------------------------------------------------------- - -type WeekOfYear = Int -type DayOfWeek = Int -data WeekDate = WeekDate - { wdYear :: {-# UNPACK #-}!Year - , wdWeek :: {-# UNPACK #-}!WeekOfYear - , wdDay :: {-# UNPACK #-}!DayOfWeek - } deriving (Eq, Ord, Data, Typeable, Show) - -instance NFData WeekDate - --- | Accepts 0-based 'DayOfWeek' and 'WeekOfYear' when 'review'ing. -{-# INLINE weekDate #-} -weekDate :: Simple Iso Day WeekDate -weekDate = iso toWeek fromWeek where - - {-# INLINEABLE toWeek #-} - toWeek :: Day -> WeekDate - toWeek day@(ModifiedJulianDay mjd) = WeekDate - y1 (fromIntegral $ w1 + 1) (fromIntegral $ mod d 7 + 1) where - -- pilfered and refactored; no idea what foo and bar mean - OrdinalDate y0 yd = view ordinalDate day - d = mjd + 2 - foo :: Year -> {-WeekOfYear-1-}Int64 - foo y = bar $ review ordinalDate (OrdinalDate y 6) - bar :: Day -> {-WeekOfYear-1-}Int64 - bar (ModifiedJulianDay k) = div d 7 - div k 7 - w0 = bar $ ModifiedJulianDay (d - fromIntegral yd + 4) - (y1, w1) = case w0 of - -1 -> (y0 - 1, foo (y0 - 1)) - 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0) - _ -> (y0, w0) - - {-# INLINEABLE fromWeek #-} - fromWeek :: WeekDate -> Day - fromWeek wd@(WeekDate y _ _) = fromWeekMax wMax wd where - WeekDate _ wMax _ = toWeek $ review ordinalDate (OrdinalDate y 365) - -{-# INLINE fromWeekMax #-} -fromWeekMax :: WeekOfYear -> WeekDate -> Day -fromWeekMax wMax (WeekDate y w d) = ModifiedJulianDay mjd where - -- pilfered and refactored - ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6) - -- FIXME: Is it okay to clip d to 0 in the case of Sunday-starting - -- weeks, and clip w to 0 for OrdinalDate.{sun,mon}dayStartWeek? - mjd = k - mod k 7 - 10 + clip 0 7 (fromIntegral d) - + fromIntegral (clip 0 wMax w) * 7 - clip a b = max a . min b - diff --git a/Data/Thyme/Calendar/MonthDay.hs b/Data/Thyme/Calendar/MonthDay.hs deleted file mode 100644 --- a/Data/Thyme/Calendar/MonthDay.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Julian or Gregorian. -module Data.Thyme.Calendar.MonthDay - ( Month, DayOfMonth - , module Data.Thyme.Calendar.MonthDay - ) where - -import Prelude -import Control.Applicative -import Control.DeepSeq -import Control.Lens -import Control.Monad -import Data.Data -import qualified Data.Time.Calendar.MonthDay as T -import Data.Thyme.Calendar.Internal -import Data.Thyme.TH - -data MonthDay = MonthDay - { mdMonth :: {-# UNPACK #-}!Month - , mdDay :: {-# UNPACK #-}!DayOfMonth - } deriving (Eq, Ord, Data, Typeable, Show) - -instance NFData MonthDay - --- | Convert between day of year in the Gregorian or Julian calendars, and --- month and day of month. First arg is leap year flag. -{-# INLINE monthDay #-} -monthDay :: Bool -> Simple Iso DayOfYear MonthDay -monthDay leap = iso fromOrdinal toOrdinal where - -- TODO: Calls non-inlineable code from @time@. Pilfer and optimise? - - {-# INLINE fromOrdinal #-} - fromOrdinal :: DayOfYear -> MonthDay - fromOrdinal yd = (MonthDay m d) where - (m, d) = T.dayOfYearToMonthAndDay leap yd - - {-# INLINE toOrdinal #-} - toOrdinal :: MonthDay -> DayOfYear - toOrdinal (MonthDay m d) = T.monthAndDayToDayOfYear leap m d - -{-# INLINEABLE monthDayToDayOfYearValid #-} -monthDayToDayOfYearValid :: Bool -> MonthDay -> Maybe DayOfYear -monthDayToDayOfYearValid leap md@(MonthDay m d) = review (monthDay leap) md - <$ guard (1 <= m && m <= 12 && 1 <= d && d <= T.monthLength leap m) - -{-# INLINE monthLength #-} -monthLength :: Bool -> Month -> Int -monthLength = T.monthLength - --- * Lenses -thymeLenses ''MonthDay - diff --git a/Data/Thyme/Calendar/OrdinalDate.hs b/Data/Thyme/Calendar/OrdinalDate.hs deleted file mode 100644 --- a/Data/Thyme/Calendar/OrdinalDate.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | ISO 8601 Ordinal Date format - -module Data.Thyme.Calendar.OrdinalDate - ( Year, isLeapYear - , DayOfYear, OrdinalDate (..), ordinalDate - , module Data.Thyme.Calendar.OrdinalDate - ) where - -import Prelude -import Control.Applicative -import Control.Lens -import Control.Monad -import Data.Thyme.Calendar.Internal -import Data.Thyme.TH - -{-# INLINE fromOrdinalDateValid #-} -fromOrdinalDateValid :: OrdinalDate -> Maybe Day -fromOrdinalDateValid od@(OrdinalDate y d) = review ordinalDate od - <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365) - --- | Use @'review' 'weekDate'@ to convert back to 'Day'. -{-# INLINE sundayStartWeek #-} -sundayStartWeek :: Day -> WeekDate -sundayStartWeek day@(ModifiedJulianDay mjd) = WeekDate y - (fromIntegral $ div d 7 - div k 7) (fromIntegral $ mod d 7) where - OrdinalDate y yd = view ordinalDate day - d = mjd + 3 - k = d - fromIntegral yd - --- | Accepts 0−6 for 'DayOfWeek', and 0-based 'WeekOfYear's. -{-# INLINEABLE fromSundayStartWeekValid #-} -fromSundayStartWeekValid :: WeekDate -> Maybe Day -fromSundayStartWeekValid wd@(WeekDate y w d) = fromWeekMax wMax wd - <$ guard (0 <= d && d <= 6 && 0 <= w && w <= wMax) where - WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) - --- | Use @'review' 'weekDate'@ to convert back to 'Day'. -{-# INLINE mondayStartWeek #-} -mondayStartWeek :: Day -> WeekDate -mondayStartWeek day@(ModifiedJulianDay mjd) = WeekDate y - (fromIntegral $ div d 7 - div k 7) (fromIntegral $ mod d 7 + 1) where - OrdinalDate y yd = view ordinalDate day - d = mjd + 2 - k = d - fromIntegral yd - --- | Accepts 1−7 for 'DayOfWeek', and 0-based 'WeekOfYear's. -{-# INLINEABLE fromMondayStartWeekValid #-} -fromMondayStartWeekValid :: WeekDate -> Maybe Day -fromMondayStartWeekValid wd@(WeekDate y w d) = fromWeekMax wMax wd - <$ guard (1 <= d && d <= 7 && 0 <= w && w <= wMax) where - WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) - --- * Lenses -thymeLenses ''OrdinalDate - diff --git a/Data/Thyme/Calendar/WeekDate.hs b/Data/Thyme/Calendar/WeekDate.hs deleted file mode 100644 --- a/Data/Thyme/Calendar/WeekDate.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} - --- | ISO 8601 Week Date format -module Data.Thyme.Calendar.WeekDate - ( Year, WeekOfYear, DayOfWeek - , WeekDate (..), weekDate - , module Data.Thyme.Calendar.WeekDate - ) where - -import Prelude -import Control.Applicative -import Control.Lens -import Control.Monad -import Data.Thyme.Calendar.OrdinalDate -import Data.Thyme.Calendar.Internal -import Data.Thyme.TH -import Text.Printf - --- | Rejects 0-based 'DayOfWeek' and 'WeekOfYear'. -{-# INLINEABLE fromWeekDateValid #-} -fromWeekDateValid :: WeekDate -> Maybe Day -fromWeekDateValid wd@(WeekDate y w d) = fromWeekMax wMax wd - <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) where - WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) - -{-# INLINEABLE showWeekDate #-} -showWeekDate :: Day -> String -showWeekDate day = printf "%04d-W%02d-%d" y w d where - WeekDate y w d = view weekDate day - --- * Lenses -thymeLenses ''WeekDate - diff --git a/Data/Thyme/Clock.hs b/Data/Thyme/Clock.hs deleted file mode 100644 --- a/Data/Thyme/Clock.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Data.Thyme.Clock ( - -- * Universal Time - - -- * Absolute intervals - DiffTime - , microsecondsToDiffTime - - -- * UTC - , UTCTime, UTCView (..) - , utcTime - , NominalDiffTime - , module Data.Thyme.Clock - - -- * Lenses - , _utctDay, _utctDayTime - ) where - -import Prelude -import Control.Lens -import Data.Thyme.Clock.Scale -import Data.Thyme.Clock.UTC -import Data.Thyme.Clock.POSIX - -getCurrentTime :: IO UTCTime -getCurrentTime = fmap (review posixTime) getPOSIXTime - diff --git a/Data/Thyme/Clock/POSIX.hs b/Data/Thyme/Clock/POSIX.hs deleted file mode 100644 --- a/Data/Thyme/Clock/POSIX.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Data.Thyme.Clock.POSIX - ( posixDayLength - , module Data.Thyme.Clock.POSIX - ) where - -import Prelude -import Control.Lens -import Data.AdditiveGroup -import Data.AffineSpace -import Data.Micro -import qualified Data.Time.Clock.POSIX as T -import Data.Thyme.Calendar.Internal -import Data.Thyme.Clock.Scale -import Data.Thyme.Clock.UTC - -type POSIXTime = NominalDiffTime - -{-# INLINE posixTime #-} -posixTime :: Simple Iso UTCTime POSIXTime -posixTime = iso toPOSIX fromPOSIX where - unixEpochDay = ModifiedJulianDay 40587 - - {-# INLINE toPOSIX #-} - toPOSIX :: UTCTime -> POSIXTime - toPOSIX t = t .-. review utcTime (UTCTime unixEpochDay zeroV) - - {-# INLINE fromPOSIX #-} - fromPOSIX :: POSIXTime -> UTCTime - fromPOSIX (NominalDiffTime d) = review utcTime $ - UTCTime unixEpochDay (DiffTime d) - --- TODO: reimplement without 'T.getPOSIXTime' to avoid 'Integer'? -{-# INLINE getPOSIXTime #-} -getPOSIXTime :: IO POSIXTime -getPOSIXTime = fmap (NominalDiffTime . toMicro . toRational) T.getPOSIXTime - diff --git a/Data/Thyme/Clock/Scale.hs b/Data/Thyme/Clock/Scale.hs deleted file mode 100644 --- a/Data/Thyme/Clock/Scale.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- #hide -module Data.Thyme.Clock.Scale where - -import Prelude -import Control.DeepSeq -import Data.AdditiveGroup -import Data.Basis -import Data.Data -import Data.Int -import Data.Ix -import Data.Micro -import Data.VectorSpace - --- TODO: UniversalTime - -newtype DiffTime = DiffTime Micro - deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup) - -#if SHOW_INTERNAL -deriving instance Show DiffTime -#else -instance Show DiffTime where - showsPrec p (DiffTime a) rest = showsPrec p a ('s' : rest) -#endif - -instance VectorSpace DiffTime where - type Scalar DiffTime = Rational - {-# INLINE (*^) #-} - s *^ DiffTime t = DiffTime (s *^ t) - -instance HasBasis DiffTime where - type Basis DiffTime = () - {-# INLINE basisValue #-} - basisValue () = DiffTime (basisValue ()) - {-# INLINE decompose #-} - decompose (DiffTime a) = decompose a - {-# INLINE decompose' #-} - decompose' (DiffTime a) = decompose' a - -#if INSTANCE_NUM -deriving instance Num DiffTime -deriving instance Real DiffTime -deriving instance Fractional DiffTime -deriving instance RealFrac DiffTime -#endif - -{-# INLINE microsecondsToDiffTime #-} -microsecondsToDiffTime :: Int64 -> DiffTime -microsecondsToDiffTime = DiffTime . Micro diff --git a/Data/Thyme/Clock/UTC.hs b/Data/Thyme/Clock/UTC.hs deleted file mode 100644 --- a/Data/Thyme/Clock/UTC.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- #hide -module Data.Thyme.Clock.UTC where - -import Prelude -import Control.DeepSeq -import Control.Lens -import Data.AdditiveGroup -import Data.AffineSpace -import Data.Basis -import Data.Bits -import Data.Data -import Data.Int -import Data.Ix -import Data.Micro -import Data.Thyme.Calendar.Internal -import Data.Thyme.Clock.Scale -import Data.VectorSpace - -newtype NominalDiffTime = NominalDiffTime Micro - deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup) - -#if SHOW_INTERNAL -deriving instance Show NominalDiffTime -#else -instance Show NominalDiffTime where - showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest) -#endif - -instance VectorSpace NominalDiffTime where - type Scalar NominalDiffTime = Rational - {-# INLINE (*^) #-} - s *^ NominalDiffTime t = NominalDiffTime (s *^ t) - -instance HasBasis NominalDiffTime where - type Basis NominalDiffTime = () - {-# INLINE basisValue #-} - basisValue () = NominalDiffTime (basisValue ()) - {-# INLINE decompose #-} - decompose (NominalDiffTime a) = decompose a - {-# INLINE decompose' #-} - decompose' (NominalDiffTime a) = decompose' a - -#if INSTANCE_NUM -deriving instance Num NominalDiffTime -deriving instance Real NominalDiffTime -deriving instance Fractional NominalDiffTime -deriving instance RealFrac NominalDiffTime -#endif - -{-# INLINE posixDayLength #-} -posixDayLength :: NominalDiffTime -posixDayLength = NominalDiffTime (toMicro 86400) - ------------------------------------------------------------------------- - -newtype UTCTime = UTCPacked Int64 - deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) - -data UTCView = UTCTime - { utctDay :: {-# UNPACK #-}!Day - , utctDayTime :: {-# UNPACK #-}!DiffTime - } deriving (Eq, Ord, Data, Typeable, Show) - -instance NFData UTCView - -_utctDay :: Simple Lens UTCTime Day -_utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t) - -_utctDayTime :: Simple Lens UTCTime DiffTime -_utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t) - -instance AffineSpace UTCTime where - type Diff UTCTime = NominalDiffTime - {-# INLINE (.-.) #-} - (view utcTime -> UTCTime da ta) .-. (view utcTime -> UTCTime db tb) = - fromIntegral (da .-. db) *^ posixDayLength ^+^ NominalDiffTime td where - DiffTime td = ta ^-^ tb - {-# INLINE (.+^) #-} - (view utcTime -> UTCTime day (DiffTime dt)) .+^ NominalDiffTime d - = review utcTime $ UTCTime day (DiffTime (dt ^+^ d)) - -{-# INLINE utcTime #-} -utcTime :: Simple Iso UTCTime UTCView -utcTime = iso unpack pack where - - {-# INLINE unpack #-} - unpack :: UTCTime -> UTCView - unpack (UTCPacked n) = UTCTime - (ModifiedJulianDay mjd) (DiffTime (Micro dt)) where - mjd = shiftR n bitsDayTime - dt = n .&. maskDayTime - - {-# INLINE pack #-} - pack :: UTCView -> UTCTime - pack (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) = - UTCPacked (shiftL (mjd + dd) bitsDayTime .|. pt) where - NominalDiffTime posixDay = posixDayLength - (dd, Micro pt) = microQuotRem dt posixDay - - {-# INLINE bitsDayTime #-} - bitsDayTime :: Int - bitsDayTime = 37 -- enough for 86400 microseconds - - {-# INLINE maskDayTime #-} - maskDayTime :: Int64 - maskDayTime = shiftL 1 bitsDayTime - 1 - diff --git a/Data/Thyme/Format.hs b/Data/Thyme/Format.hs deleted file mode 100644 --- a/Data/Thyme/Format.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Thyme.Format - ( FormatTime (..) - , formatTime - ) where - -import Prelude -import Control.Applicative -import Control.Lens -import Data.Char -import Data.Int -import Data.Micro -import Data.Thyme.Calendar -import Data.Thyme.Calendar.OrdinalDate -import Data.Thyme.Calendar.WeekDate -import Data.Thyme.Calendar.MonthDay -import Data.Thyme.Clock.POSIX -import Data.Thyme.Clock.Scale -import Data.Thyme.Clock.UTC -import Data.Thyme.LocalTime -import Data.Thyme.Format.Internal -import System.Locale - -class FormatTime t where - showsTime :: TimeLocale -> t -> (Char -> ShowS) -> (Char -> ShowS) - -{-# INLINEABLE formatTime #-} -formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String -formatTime l@TimeLocale {..} spec t = go spec "" where - -- leave unrecognised codes as they are - format = showsTime l t (\ c s -> '%' : c : s) - go s = case s of - '%' : c : rest -> case c of - -- aggregate - 'c' -> go (dateTimeFmt ++ rest) - 'r' -> go (time12Fmt ++ rest) - 'X' -> go (timeFmt ++ rest) - 'x' -> go (dateFmt ++ rest) - -- modifier (whatever) - '-' -> go ('%' : rest) - '_' -> go ('%' : rest) - '0' -> go ('%' : rest) - '^' -> go ('%' : rest) - '#' -> go ('%' : rest) - -- escape (why would anyone need %t and %n?) - '%' -> (:) '%' . go rest - -- default - _ -> format c . go rest - c : rest -> (:) c . go rest - [] -> id - -instance FormatTime TimeOfDay where - {-# INLINEABLE showsTime #-} - showsTime TimeLocale {..} (TimeOfDay h m (DiffTime s)) = \ def c -> case c of - -- aggregate - 'R' -> shows02 h . (:) ':' . shows02 m - 'T' -> shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 si - -- AM/PM - 'P' -> (++) $ toLower <$> if h < 12 then fst amPm else snd amPm - 'p' -> (++) $ if h < 12 then fst amPm else snd amPm - -- Hour - 'H' -> shows02 h - 'I' -> shows02 $ 1 + mod (h - 1) 12 - 'k' -> shows_2 h - 'l' -> shows_2 $ 1 + mod (h - 1) 12 - -- Minute - 'M' -> shows02 m - -- Second - 'S' -> shows02 si - 'q' -> fills06 su . shows su - 'Q' -> if su == 0 then id else (:) '.' . fills06 su . drop0 su - -- default - _ -> def c - - where - (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000) - - {-# INLINE fills06 #-} - fills06 :: Int64 -> ShowS - fills06 n = case () of - _ | n < 10 -> (:) '0' . (:) '0' . (:) '0' . (:) '0' . (:) '0' - _ | n < 100 -> (:) '0' . (:) '0' . (:) '0' . (:) '0' - _ | n < 1000 -> (:) '0' . (:) '0' . (:) '0' - _ | n < 10000 -> (:) '0' . (:) '0' - _ | n < 100000 -> (:) '0' - _ -> id - - {-# INLINE drop0 #-} - drop0 :: Int64 -> ShowS - drop0 n = case divMod n 10 of - (q, 0) -> drop0 q - _ -> shows n - -instance FormatTime YearMonthDay where - {-# INLINEABLE showsTime #-} - showsTime TimeLocale {..} (YearMonthDay y m d) = \ def c -> case c of - -- aggregate - 'D' -> shows02 m . (:) '/' . shows02 d . (:) '/' . shows02 (mod y 100) - 'F' -> shows04 y . (:) '-' . shows02 m . (:) '-' . shows02 d - -- Year - 'Y' -> shows04 y - 'y' -> shows02 (mod y 100) - 'C' -> shows02 (div y 100) - -- Month - 'B' -> (++) . fst $ months !! (m - 1) - 'b' -> (++) . snd $ months !! (m - 1) - 'h' -> (++) . snd $ months !! (m - 1) - 'm' -> shows02 m - -- DayOfMonth - 'd' -> shows02 d - 'e' -> shows_2 d - -- default - _ -> def c - -instance FormatTime MonthDay where - {-# INLINEABLE showsTime #-} - showsTime TimeLocale {..} (MonthDay m d) = \ def c -> case c of - -- Month - 'B' -> (++) . fst $ months !! (m - 1) - 'b' -> (++) . snd $ months !! (m - 1) - 'h' -> (++) . snd $ months !! (m - 1) - 'm' -> shows02 m - -- DayOfMonth - 'd' -> shows02 d - 'e' -> shows_2 d - -- default - _ -> def c - -instance FormatTime OrdinalDate where - {-# INLINEABLE showsTime #-} - showsTime TimeLocale {..} (OrdinalDate y d) = \ def c -> case c of - -- Year - 'Y' -> shows04 y - 'y' -> shows02 (mod y 100) - 'C' -> shows02 (div y 100) - -- DayOfYear - 'j' -> shows03 d - -- default - _ -> def c - -instance FormatTime WeekDate where - {-# INLINEABLE showsTime #-} - showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of - -- Year - 'G' -> shows04 y - 'g' -> shows02 (mod y 100) - 'f' -> shows02 (div y 100) - -- WeekOfYear - 'V' -> shows02 w - -- DayOfWeek - 'u' -> shows d - 'A' -> (++) . fst $ wDays !! mod d 7 - 'a' -> (++) . snd $ wDays !! mod d 7 - 'w' -> shows (mod d 7) - -- default - _ -> def c - -instance FormatTime LocalTime where - {-# INLINEABLE showsTime #-} - showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod - -instance FormatTime Day where - {-# INLINEABLE showsTime #-} - showsTime l d = showsTime l ordinal - . showsTime l (view yearMonthDay ordinal) - . showsTime l (view weekDate d) . other where - ordinal = view ordinalDate d - other :: (Char -> ShowS) -> (Char -> ShowS) - other def c = case c of - -- Non-standard WeekOfYear - 'U' -> shows02 . wdWeek $ sundayStartWeek d - 'W' -> shows02 . wdWeek $ mondayStartWeek d - -- default - _ -> def c - -instance FormatTime TimeZone where - {-# INLINEABLE showsTime #-} - showsTime _ tz@(TimeZone _ _ name) = \ def c -> case c of - 'z' -> (++) (timeZoneOffsetString tz) - 'Z' -> (++) (if null name then timeZoneOffsetString tz else name) - _ -> def c - -instance FormatTime ZonedTime where - {-# INLINEABLE showsTime #-} - showsTime l (ZonedTime lt tz) = showsTime l lt . showsTime l tz - -instance FormatTime UTCTime where - {-# INLINEABLE showsTime #-} - showsTime l t = \ def c -> case c of - 's' -> shows . fst $ microQuotRem s (Micro 1000000) - _ -> showsTime l (view zonedTime (utc, t)) def c - where - NominalDiffTime s = view posixTime t - diff --git a/Data/Thyme/Format/Internal.hs b/Data/Thyme/Format/Internal.hs deleted file mode 100644 --- a/Data/Thyme/Format/Internal.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Data.Thyme.Format.Internal where - -import Prelude - -{-# INLINE shows02 #-} -shows02 :: Int -> String -> String -shows02 n = if n < 10 then (:) '0' . shows n else shows n - -{-# INLINE shows_2 #-} -shows_2 :: Int -> String -> String -shows_2 n = if n < 10 then (:) ' ' . shows n else shows n - -{-# INLINE shows03 #-} -shows03 :: Int -> ShowS -shows03 n = case () of - _ | n < 10 -> (:) '0' . (:) '0' . shows n - _ | n < 100 -> (:) '0' . shows n - _ -> shows n - -{-# INLINE shows04 #-} -shows04 :: Int -> String -> String -shows04 n = case () of - _ | n < 10 -> (:) '0' . (:) '0' . (:) '0' . shows n - _ | n < 100 -> (:) '0' . (:) '0' . shows n - _ | n < 1000 -> (:) '0' . shows n - _ -> shows n - diff --git a/Data/Thyme/LocalTime.hs b/Data/Thyme/LocalTime.hs deleted file mode 100644 --- a/Data/Thyme/LocalTime.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Thyme.LocalTime ( - -- * Time zones - T.TimeZone (..) - , T.timeZoneOffsetString - , T.timeZoneOffsetString' - , T.minutesToTimeZone - , T.hoursToTimeZone - , T.utc - , T.getCurrentTimeZone - , module Data.Thyme.LocalTime - ) where - -import Prelude hiding ((.)) -import Control.Applicative -import Control.Category -import Control.Lens -import Control.Monad -import Data.AffineSpace -import Data.Data -import Data.Micro -import qualified Data.Time as T -import Data.Thyme.Calendar.Internal -import Data.Thyme.Clock -import Data.Thyme.Clock.Scale -import Data.Thyme.Clock.UTC -import Data.Thyme.TH -import Data.VectorSpace - -getTimeZone :: UTCTime -> IO T.TimeZone -getTimeZone time = T.getTimeZone (T.UTCTime day dayTime) where - day = T.ModifiedJulianDay (fromIntegral mjd) - dayTime = fromRational $ dt ^/^ DiffTime (toMicro 1) - UTCTime (ModifiedJulianDay mjd) dt = view utcTime time - ------------------------------------------------------------------------- --- * Time of day - -type Hour = Int -type Minute = Int -data TimeOfDay = TimeOfDay - { todHour :: {-# UNPACK #-}!Hour - , todMin :: {-# UNPACK #-}!Minute - , todSec :: {-# UNPACK #-}!DiffTime - } deriving (Eq, Ord, Data, Typeable, Show) - -{-# INLINE makeTimeOfDayValid #-} -makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay -makeTimeOfDayValid h m s@(DiffTime u) = TimeOfDay h m s - <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59) - <* guard (Micro 0 <= u && u < Micro 61000000) - -{-# INLINE timeOfDay #-} -timeOfDay :: Simple Iso DiffTime TimeOfDay -timeOfDay = iso fromDiff toDiff where - - {-# INLINEABLE fromDiff #-} - fromDiff :: DiffTime -> TimeOfDay - fromDiff (DiffTime t) = TimeOfDay - (fromIntegral h) (fromIntegral m) (DiffTime s) where - (h, ms) = microQuotRem t (toMicro 3600) - (m, s) = microQuotRem ms (toMicro 60) - - {-# INLINEABLE toDiff #-} - toDiff :: TimeOfDay -> DiffTime - toDiff (TimeOfDay h m s) = s - ^+^ fromIntegral m *^ DiffTime (toMicro 60) - ^+^ fromIntegral h *^ DiffTime (toMicro 3600) - -type Minutes = Int -type Days = Int - --- | Add some minutes to a 'TimeOfDay'; result comes with a day adjustment. -{-# INLINE addMinutes #-} -addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay) -addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where - (dd, h') = divMod (h + dh) 24 - (dh, m') = divMod (m + dm) 60 - -{-# INLINE timeOfDayFraction #-} -timeOfDayFraction :: Simple Iso Rational TimeOfDay -timeOfDayFraction = iso fromRatio toRatio . timeOfDay where - NominalDiffTime posixDay = posixDayLength - - fromRatio :: Rational -> DiffTime - fromRatio r = DiffTime (r *^ posixDay) where - - toRatio :: DiffTime -> Rational - toRatio (DiffTime t) = t ^/^ posixDay - ------------------------------------------------------------------------- --- * Local Time - -data LocalTime = LocalTime - { localDay :: {-# UNPACK #-}!Day - , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay - } deriving (Eq, Ord, Data, Typeable, Show) - -{-# INLINE utcLocalTime #-} -utcLocalTime :: T.TimeZone -> Simple Iso UTCTime LocalTime -utcLocalTime T.TimeZone {..} = utcTime . iso localise globalise where - - {-# INLINEABLE localise #-} - localise :: UTCView -> LocalTime - localise (UTCTime day dt) = LocalTime (day .+^ dd) tod where - (dd, tod) = addMinutes timeZoneMinutes (view timeOfDay dt) - - {-# INLINEABLE globalise #-} - globalise :: LocalTime -> UTCView - globalise (LocalTime day tod) = UTCTime (day .+^ dd) - (review timeOfDay utcToD) where - (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod - --- TODO: ut1LocalTime - ------------------------------------------------------------------------- --- * Zoned Time - -data ZonedTime = ZonedTime - { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime - , zonedTimeZone :: !T.TimeZone - } deriving (Eq, Ord, Data, Typeable, Show) - -{-# INLINE zonedTime #-} -zonedTime :: Simple Iso (T.TimeZone, UTCTime) ZonedTime -zonedTime = iso toZoned fromZoned where - - {-# INLINE toZoned #-} - toZoned :: (T.TimeZone, UTCTime) -> ZonedTime - toZoned (tz, time) = ZonedTime (view (utcLocalTime tz) time) tz - - {-# INLINE fromZoned #-} - fromZoned :: ZonedTime -> (T.TimeZone, UTCTime) - fromZoned (ZonedTime lt tz) = (tz, review (utcLocalTime tz) lt) - -{-# INLINE getZonedTime #-} -getZonedTime :: IO ZonedTime -getZonedTime = utcToLocalZonedTime =<< getCurrentTime - -{-# INLINEABLE utcToLocalZonedTime #-} -utcToLocalZonedTime :: UTCTime -> IO ZonedTime -utcToLocalZonedTime time = do - tz <- getTimeZone time - return (view zonedTime (tz, time)) - ------------------------------------------------------------------------- --- * Lenses - -thymeLenses ''T.TimeZone -thymeLenses ''TimeOfDay -thymeLenses ''LocalTime -thymeLenses ''ZonedTime - diff --git a/Data/Thyme/TH.hs b/Data/Thyme/TH.hs deleted file mode 100644 --- a/Data/Thyme/TH.hs +++ /dev/null @@ -1,11 +0,0 @@ --- #hide -module Data.Thyme.TH (thymeLenses) where - -import Prelude -import Control.Lens -import Language.Haskell.TH - -thymeLenses :: Name -> Q [Dec] -thymeLenses = makeLensesWith $ lensRules - & lensField .~ Just . (:) '_' - diff --git a/src/Data/Micro.hs b/src/Data/Micro.hs new file mode 100644 --- /dev/null +++ b/src/Data/Micro.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- #hide +module Data.Micro where + +import Prelude +import Control.DeepSeq +import Data.AdditiveGroup +import Data.Basis +import Data.Data +import Data.Int +import Data.Ix +import Data.Ratio +import Data.VectorSpace +#if !SHOW_INTERNAL +import Text.Printf +#endif + +newtype Micro = Micro Int64 + deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) + +#if SHOW_INTERNAL +deriving instance Show Micro +#else +instance Show Micro where + show (Micro a) = case compare a 0 of + LT -> printf "-%d.%06u" `uncurry` quotRem (negate a) 1000000 + EQ -> "0" + GT -> printf "%d.%06u" `uncurry` quotRem a 1000000 +#endif + +{-# INLINE toMicro #-} +toMicro :: Rational -> Micro +toMicro r = Micro (fromInteger $ 1000000 * numerator r `div` denominator r) + +#if INSTANCE_NUM +instance Num Micro where + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE (*) #-} + {-# INLINE negate #-} + {-# INLINE abs #-} + {-# INLINE signum #-} + {-# INLINE fromInteger #-} + Micro a + Micro b = Micro (a + b) + Micro a - Micro b = Micro (a - b) + Micro a * Micro b = Micro ((quot a 1000) * (quot b 1000)) + negate (Micro a) = Micro (negate a) + abs (Micro a) = Micro (abs a) + signum (Micro a) = Micro (signum a * 1000000) + fromInteger a = Micro (fromInteger a * 1000000) + +instance Real Micro where + {-# INLINE toRational #-} + toRational (Micro a) = toInteger a % 1000000 + +instance Fractional Micro where + {-# INLINE (/) #-} + {-# INLINE recip #-} + {-# INLINE fromRational #-} + Micro a / Micro b = Micro (quot (a * 1000) (b * 1000)) + recip (Micro a) = Micro (quot 1000000 a) + fromRational = toMicro + +instance RealFrac Micro where + {-# INLINE properFraction #-} + properFraction a = (fromIntegral q, r) where + (q, r) = microQuotRem a (Micro 1000000) +#endif + +{-# INLINE microQuotRem #-} +{-# INLINE microDivMod #-} +microQuotRem, microDivMod :: Micro -> Micro -> (Int64, Micro) +microQuotRem (Micro a) (Micro b) = (n, Micro f) where (n, f) = quotRem a b +microDivMod (Micro a) (Micro b) = (n, Micro f) where (n, f) = divMod a b + +instance AdditiveGroup Micro where + {-# INLINE zeroV #-} + zeroV = Micro 0 + {-# INLINE (^+^) #-} + Micro a ^+^ Micro b = Micro (a + b) + {-# INLINE negateV #-} + negateV (Micro a) = Micro (negate a) + +instance VectorSpace Micro where + type Scalar Micro = Rational + {-# INLINE (*^) #-} + s *^ Micro a = Micro . fromInteger $ + toInteger a * numerator s `quot` denominator s + +instance HasBasis Micro where + type Basis Micro = () + {-# INLINE basisValue #-} + basisValue () = Micro 1000000 + {-# INLINE decompose #-} + decompose (Micro a) = [((), fromIntegral a % 1000000)] + {-# INLINE decompose' #-} + decompose' (Micro a) = const (fromIntegral a % 1000000) + +{-# INLINE (^/^) #-} +(^/^) :: (HasBasis v, Basis v ~ (), Scalar v ~ s, Fractional s) => v -> v -> s +x ^/^ y = decompose' x () / decompose' y () + diff --git a/src/Data/Thyme.hs b/src/Data/Thyme.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme.hs @@ -0,0 +1,12 @@ +module Data.Thyme + ( module Data.Thyme.Calendar + , module Data.Thyme.Clock + , module Data.Thyme.Format + , module Data.Thyme.LocalTime + ) where + +import Data.Thyme.Calendar +import Data.Thyme.Clock +import Data.Thyme.Format +import Data.Thyme.LocalTime + diff --git a/src/Data/Thyme/Calendar.hs b/src/Data/Thyme/Calendar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Calendar.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Thyme.Calendar ( + -- * Days + Day (..) + -- * Gregorian calendar + , Year, Month, DayOfMonth + , YearMonthDay (..) + , isLeapYear + , module Data.Thyme.Calendar + ) where + +import Prelude hiding ((.)) +import Control.Applicative +import Control.Category +import Control.Lens +import Data.Thyme.Calendar.Internal +import Data.Thyme.Calendar.MonthDay +import Data.Thyme.Format.Internal +import Data.Thyme.TH + +{-# INLINE yearMonthDay #-} +yearMonthDay :: Simple Iso OrdinalDate YearMonthDay +yearMonthDay = iso fromOrdinal toOrdinal where + + {-# INLINEABLE fromOrdinal #-} + fromOrdinal :: OrdinalDate -> YearMonthDay + fromOrdinal (OrdinalDate y yd) = (YearMonthDay y m d) where + MonthDay m d = view (monthDay (isLeapYear y)) yd + + {-# INLINEABLE toOrdinal #-} + toOrdinal :: YearMonthDay -> OrdinalDate + toOrdinal (YearMonthDay y m d) = OrdinalDate y $ + review (monthDay (isLeapYear y)) (MonthDay m d) + +{-# INLINE gregorian #-} +gregorian :: Simple Iso Day YearMonthDay +gregorian = ordinalDate . yearMonthDay + +{-# INLINEABLE fromGregorianValid #-} +fromGregorianValid :: YearMonthDay -> Maybe Day +fromGregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y + <$> monthDayToDayOfYearValid (isLeapYear y) (MonthDay m d) + +{-# INLINEABLE showGregorian #-} +showGregorian :: Day -> String +showGregorian (view gregorian -> YearMonthDay y m d) = + shows04 y . (:) '-' . shows02 m . (:) '-' . shows02 d $ "" + +#if SHOW_INTERNAL +deriving instance Show Day +#else +instance Show Day where show = showGregorian +#endif + +{-# INLINE gregorianMonthLength #-} +gregorianMonthLength :: Year -> Month -> Int +gregorianMonthLength = monthLength . isLeapYear + +-- TODO: addGregorianMonthsClip addGregorianMonthsRollover +-- TODO: addGregorianYearsClip addGregorianYearsRollover + +-- * Lenses +thymeLenses ''Day +thymeLenses ''YearMonthDay + diff --git a/src/Data/Thyme/Calendar/Internal.hs b/src/Data/Thyme/Calendar/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Calendar/Internal.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- #hide +module Data.Thyme.Calendar.Internal where + +import Prelude +import Control.DeepSeq +import Control.Lens +import Data.AffineSpace +import Data.Data +import Data.Int +import Data.Ix + +-- | The Modified Julian Day is a standard count of days, with zero being +-- the day 1858-11-17. +newtype Day = ModifiedJulianDay + { toModifiedJulianDay :: Int64 + } deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) + +instance AffineSpace Day where + type Diff Day = Int + {-# INLINE (.-.) #-} + ModifiedJulianDay a .-. ModifiedJulianDay b = fromIntegral (a - b) + {-# INLINE (.+^) #-} + ModifiedJulianDay a .+^ d = ModifiedJulianDay (a + fromIntegral d) + +------------------------------------------------------------------------ + +type Year = Int +type Month = Int +type DayOfMonth = Int + +data YearMonthDay = YearMonthDay + { ymdYear :: {-# UNPACK #-}!Year + , ymdMonth :: {-# UNPACK #-}!Month + , ymdDay :: {-# UNPACK #-}!DayOfMonth + } deriving (Eq, Ord, Data, Typeable, Show) + +instance NFData YearMonthDay + +------------------------------------------------------------------------ + +-- | Gregorian leap year? +{-# INLINE isLeapYear #-} +isLeapYear :: Year -> Bool +isLeapYear y = mod y 4 == 0 && (mod y 400 == 0 || mod y 100 /= 0) + +type DayOfYear = Int +data OrdinalDate = OrdinalDate + { odYear :: {-# UNPACK #-}!Year + , odDay :: {-# UNPACK #-}!DayOfYear + } deriving (Eq, Ord, Data, Typeable, Show) + +instance NFData OrdinalDate + +{-# INLINE ordinalDate #-} +ordinalDate :: Simple Iso Day OrdinalDate +ordinalDate = iso toOrd fromOrd where + + {-# INLINEABLE toOrd #-} + toOrd :: Day -> OrdinalDate + toOrd (ModifiedJulianDay mjd) = OrdinalDate + (fromIntegral year) (fromIntegral yd) where + -- pilfered + a = mjd + 678575 + quadcent = div a 146097 + b = mod a 146097 + cent = min (div b 36524) 3 + c = b - cent * 36524 + quad = div c 1461 + d = mod c 1461 + y = min (div d 365) 3 + yd = d - y * 365 + 1 + year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 + + {-# INLINEABLE fromOrd #-} + fromOrd :: OrdinalDate -> Day + fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where + -- pilfered + y = fromIntegral (year - 1) + mjd = 365 * y + div y 4 - div y 100 + div y 400 - 678576 + + clip 1 (if isLeapYear year then 366 else 365) (fromIntegral yd) + clip a b = max a . min b + +------------------------------------------------------------------------ + +type WeekOfYear = Int +type DayOfWeek = Int +data WeekDate = WeekDate + { wdYear :: {-# UNPACK #-}!Year + , wdWeek :: {-# UNPACK #-}!WeekOfYear + , wdDay :: {-# UNPACK #-}!DayOfWeek + } deriving (Eq, Ord, Data, Typeable, Show) + +instance NFData WeekDate + +-- | Accepts 0-based 'DayOfWeek' and 'WeekOfYear' when 'review'ing. +{-# INLINE weekDate #-} +weekDate :: Simple Iso Day WeekDate +weekDate = iso toWeek fromWeek where + + {-# INLINEABLE toWeek #-} + toWeek :: Day -> WeekDate + toWeek day@(ModifiedJulianDay mjd) = WeekDate + y1 (fromIntegral $ w1 + 1) (fromIntegral $ mod d 7 + 1) where + -- pilfered and refactored; no idea what foo and bar mean + OrdinalDate y0 yd = view ordinalDate day + d = mjd + 2 + foo :: Year -> {-WeekOfYear-1-}Int64 + foo y = bar $ review ordinalDate (OrdinalDate y 6) + bar :: Day -> {-WeekOfYear-1-}Int64 + bar (ModifiedJulianDay k) = div d 7 - div k 7 + w0 = bar $ ModifiedJulianDay (d - fromIntegral yd + 4) + (y1, w1) = case w0 of + -1 -> (y0 - 1, foo (y0 - 1)) + 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0) + _ -> (y0, w0) + + {-# INLINEABLE fromWeek #-} + fromWeek :: WeekDate -> Day + fromWeek wd@(WeekDate y _ _) = fromWeekMax wMax wd where + WeekDate _ wMax _ = toWeek $ review ordinalDate (OrdinalDate y 365) + +{-# INLINE fromWeekMax #-} +fromWeekMax :: WeekOfYear -> WeekDate -> Day +fromWeekMax wMax (WeekDate y w d) = ModifiedJulianDay mjd where + -- pilfered and refactored + ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6) + -- FIXME: Is it okay to clip d to 0 in the case of Sunday-starting + -- weeks, and clip w to 0 for OrdinalDate.{sun,mon}dayStartWeek? + mjd = k - mod k 7 - 10 + clip 0 7 (fromIntegral d) + + fromIntegral (clip 0 wMax w) * 7 + clip a b = max a . min b + diff --git a/src/Data/Thyme/Calendar/MonthDay.hs b/src/Data/Thyme/Calendar/MonthDay.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Calendar/MonthDay.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Julian or Gregorian. +module Data.Thyme.Calendar.MonthDay + ( Month, DayOfMonth + , module Data.Thyme.Calendar.MonthDay + ) where + +import Prelude +import Control.Applicative +import Control.DeepSeq +import Control.Lens +import Control.Monad +import Data.Data +import qualified Data.Time.Calendar.MonthDay as T +import Data.Thyme.Calendar.Internal +import Data.Thyme.TH + +data MonthDay = MonthDay + { mdMonth :: {-# UNPACK #-}!Month + , mdDay :: {-# UNPACK #-}!DayOfMonth + } deriving (Eq, Ord, Data, Typeable, Show) + +instance NFData MonthDay + +-- | Convert between day of year in the Gregorian or Julian calendars, and +-- month and day of month. First arg is leap year flag. +{-# INLINE monthDay #-} +monthDay :: Bool -> Simple Iso DayOfYear MonthDay +monthDay leap = iso fromOrdinal toOrdinal where + -- TODO: Calls non-inlineable code from @time@. Pilfer and optimise? + + {-# INLINE fromOrdinal #-} + fromOrdinal :: DayOfYear -> MonthDay + fromOrdinal yd = (MonthDay m d) where + (m, d) = T.dayOfYearToMonthAndDay leap yd + + {-# INLINE toOrdinal #-} + toOrdinal :: MonthDay -> DayOfYear + toOrdinal (MonthDay m d) = T.monthAndDayToDayOfYear leap m d + +{-# INLINEABLE monthDayToDayOfYearValid #-} +monthDayToDayOfYearValid :: Bool -> MonthDay -> Maybe DayOfYear +monthDayToDayOfYearValid leap md@(MonthDay m d) = review (monthDay leap) md + <$ guard (1 <= m && m <= 12 && 1 <= d && d <= T.monthLength leap m) + +{-# INLINE monthLength #-} +monthLength :: Bool -> Month -> Int +monthLength = T.monthLength + +-- * Lenses +thymeLenses ''MonthDay + diff --git a/src/Data/Thyme/Calendar/OrdinalDate.hs b/src/Data/Thyme/Calendar/OrdinalDate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Calendar/OrdinalDate.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | ISO 8601 Ordinal Date format + +module Data.Thyme.Calendar.OrdinalDate + ( Year, isLeapYear + , DayOfYear, OrdinalDate (..), ordinalDate + , module Data.Thyme.Calendar.OrdinalDate + ) where + +import Prelude +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Thyme.Calendar.Internal +import Data.Thyme.TH + +{-# INLINE fromOrdinalDateValid #-} +fromOrdinalDateValid :: OrdinalDate -> Maybe Day +fromOrdinalDateValid od@(OrdinalDate y d) = review ordinalDate od + <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365) + +-- | Use @'review' 'weekDate'@ to convert back to 'Day'. +{-# INLINE sundayStartWeek #-} +sundayStartWeek :: Day -> WeekDate +sundayStartWeek day@(ModifiedJulianDay mjd) = WeekDate y + (fromIntegral $ div d 7 - div k 7) (fromIntegral $ mod d 7) where + OrdinalDate y yd = view ordinalDate day + d = mjd + 3 + k = d - fromIntegral yd + +-- | Accepts 0−6 for 'DayOfWeek', and 0-based 'WeekOfYear's. +{-# INLINEABLE fromSundayStartWeekValid #-} +fromSundayStartWeekValid :: WeekDate -> Maybe Day +fromSundayStartWeekValid wd@(WeekDate y w d) = fromWeekMax wMax wd + <$ guard (0 <= d && d <= 6 && 0 <= w && w <= wMax) where + WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) + +-- | Use @'review' 'weekDate'@ to convert back to 'Day'. +{-# INLINE mondayStartWeek #-} +mondayStartWeek :: Day -> WeekDate +mondayStartWeek day@(ModifiedJulianDay mjd) = WeekDate y + (fromIntegral $ div d 7 - div k 7) (fromIntegral $ mod d 7 + 1) where + OrdinalDate y yd = view ordinalDate day + d = mjd + 2 + k = d - fromIntegral yd + +-- | Accepts 1−7 for 'DayOfWeek', and 0-based 'WeekOfYear's. +{-# INLINEABLE fromMondayStartWeekValid #-} +fromMondayStartWeekValid :: WeekDate -> Maybe Day +fromMondayStartWeekValid wd@(WeekDate y w d) = fromWeekMax wMax wd + <$ guard (1 <= d && d <= 7 && 0 <= w && w <= wMax) where + WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) + +-- * Lenses +thymeLenses ''OrdinalDate + diff --git a/src/Data/Thyme/Calendar/WeekDate.hs b/src/Data/Thyme/Calendar/WeekDate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Calendar/WeekDate.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | ISO 8601 Week Date format +module Data.Thyme.Calendar.WeekDate + ( Year, WeekOfYear, DayOfWeek + , WeekDate (..), weekDate + , module Data.Thyme.Calendar.WeekDate + ) where + +import Prelude +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Thyme.Calendar.OrdinalDate +import Data.Thyme.Calendar.Internal +import Data.Thyme.TH +import Text.Printf + +-- | Rejects 0-based 'DayOfWeek' and 'WeekOfYear'. +{-# INLINEABLE fromWeekDateValid #-} +fromWeekDateValid :: WeekDate -> Maybe Day +fromWeekDateValid wd@(WeekDate y w d) = fromWeekMax wMax wd + <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) where + WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) + +{-# INLINEABLE showWeekDate #-} +showWeekDate :: Day -> String +showWeekDate day = printf "%04d-W%02d-%d" y w d where + WeekDate y w d = view weekDate day + +-- * Lenses +thymeLenses ''WeekDate + diff --git a/src/Data/Thyme/Clock.hs b/src/Data/Thyme/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Clock.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Thyme.Clock ( + -- * Universal Time + + -- * Absolute intervals + DiffTime + , microsecondsToDiffTime + + -- * UTC + , UTCTime, UTCView (..) + , utcTime + , NominalDiffTime + , module Data.Thyme.Clock + + -- * Lenses + , _utctDay, _utctDayTime + ) where + +import Prelude +import Control.Lens +import Data.Thyme.Clock.Scale +import Data.Thyme.Clock.UTC +import Data.Thyme.Clock.POSIX +#if !SHOW_INTERNAL +import Data.Thyme.LocalTime.Internal +import Data.Thyme.LocalTime.TimeZone +#endif + +#if SHOW_INTERNAL +instance Show UTCTime where + showsPrec p = showsPrec p . view utcTime +#else +instance Show UTCTime where + showsPrec p = showsPrec p . view (utcLocalTime utc) +#endif + +getCurrentTime :: IO UTCTime +getCurrentTime = fmap (review posixTime) getPOSIXTime + diff --git a/src/Data/Thyme/Clock/POSIX.hs b/src/Data/Thyme/Clock/POSIX.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Clock/POSIX.hs @@ -0,0 +1,36 @@ +module Data.Thyme.Clock.POSIX + ( posixDayLength + , module Data.Thyme.Clock.POSIX + ) where + +import Prelude +import Control.Lens +import Data.AdditiveGroup +import Data.AffineSpace +import Data.Micro +import qualified Data.Time.Clock.POSIX as T +import Data.Thyme.Calendar.Internal +import Data.Thyme.Clock.Scale +import Data.Thyme.Clock.UTC + +type POSIXTime = NominalDiffTime + +{-# INLINE posixTime #-} +posixTime :: Simple Iso UTCTime POSIXTime +posixTime = iso toPOSIX fromPOSIX where + unixEpochDay = ModifiedJulianDay 40587 + + {-# INLINE toPOSIX #-} + toPOSIX :: UTCTime -> POSIXTime + toPOSIX t = t .-. review utcTime (UTCTime unixEpochDay zeroV) + + {-# INLINE fromPOSIX #-} + fromPOSIX :: POSIXTime -> UTCTime + fromPOSIX (NominalDiffTime d) = review utcTime $ + UTCTime unixEpochDay (DiffTime d) + +-- TODO: reimplement without 'T.getPOSIXTime' to avoid 'Integer'? +{-# INLINE getPOSIXTime #-} +getPOSIXTime :: IO POSIXTime +getPOSIXTime = fmap (NominalDiffTime . toMicro . toRational) T.getPOSIXTime + diff --git a/src/Data/Thyme/Clock/Scale.hs b/src/Data/Thyme/Clock/Scale.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Clock/Scale.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- #hide +module Data.Thyme.Clock.Scale where + +import Prelude +import Control.DeepSeq +import Data.AdditiveGroup +import Data.Basis +import Data.Data +import Data.Int +import Data.Ix +import Data.Micro +import Data.VectorSpace + +-- TODO: UniversalTime + +newtype DiffTime = DiffTime Micro + deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup) + +#if SHOW_INTERNAL +deriving instance Show DiffTime +#else +instance Show DiffTime where + showsPrec p (DiffTime a) rest = showsPrec p a ('s' : rest) +#endif + +instance VectorSpace DiffTime where + type Scalar DiffTime = Rational + {-# INLINE (*^) #-} + s *^ DiffTime t = DiffTime (s *^ t) + +instance HasBasis DiffTime where + type Basis DiffTime = () + {-# INLINE basisValue #-} + basisValue () = DiffTime (basisValue ()) + {-# INLINE decompose #-} + decompose (DiffTime a) = decompose a + {-# INLINE decompose' #-} + decompose' (DiffTime a) = decompose' a + +#if INSTANCE_NUM +deriving instance Num DiffTime +deriving instance Real DiffTime +deriving instance Fractional DiffTime +deriving instance RealFrac DiffTime +#endif + +{-# INLINE microsecondsToDiffTime #-} +microsecondsToDiffTime :: Int64 -> DiffTime +microsecondsToDiffTime = DiffTime . Micro diff --git a/src/Data/Thyme/Clock/UTC.hs b/src/Data/Thyme/Clock/UTC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Clock/UTC.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- #hide +module Data.Thyme.Clock.UTC where + +import Prelude +import Control.DeepSeq +import Control.Lens +import Data.AdditiveGroup +import Data.AffineSpace +import Data.Basis +import Data.Bits +import Data.Data +import Data.Int +import Data.Ix +import Data.Micro +import Data.Thyme.Calendar +import Data.Thyme.Clock.Scale +import Data.VectorSpace + +newtype NominalDiffTime = NominalDiffTime Micro + deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup) + +#if SHOW_INTERNAL +deriving instance Show NominalDiffTime +#else +instance Show NominalDiffTime where + showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest) +#endif + +instance VectorSpace NominalDiffTime where + type Scalar NominalDiffTime = Rational + {-# INLINE (*^) #-} + s *^ NominalDiffTime t = NominalDiffTime (s *^ t) + +instance HasBasis NominalDiffTime where + type Basis NominalDiffTime = () + {-# INLINE basisValue #-} + basisValue () = NominalDiffTime (basisValue ()) + {-# INLINE decompose #-} + decompose (NominalDiffTime a) = decompose a + {-# INLINE decompose' #-} + decompose' (NominalDiffTime a) = decompose' a + +#if INSTANCE_NUM +deriving instance Num NominalDiffTime +deriving instance Real NominalDiffTime +deriving instance Fractional NominalDiffTime +deriving instance RealFrac NominalDiffTime +#endif + +{-# INLINE posixDayLength #-} +posixDayLength :: NominalDiffTime +posixDayLength = NominalDiffTime (toMicro 86400) + +------------------------------------------------------------------------ + +newtype UTCTime = UTCPacked Int64 + deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) + +data UTCView = UTCTime + { utctDay :: {-# UNPACK #-}!Day + , utctDayTime :: {-# UNPACK #-}!DiffTime + } deriving (Eq, Ord, Data, Typeable, Show) + +instance NFData UTCView + +_utctDay :: Simple Lens UTCTime Day +_utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t) + +_utctDayTime :: Simple Lens UTCTime DiffTime +_utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t) + +instance AffineSpace UTCTime where + type Diff UTCTime = NominalDiffTime + {-# INLINE (.-.) #-} + (view utcTime -> UTCTime da ta) .-. (view utcTime -> UTCTime db tb) = + fromIntegral (da .-. db) *^ posixDayLength ^+^ NominalDiffTime td where + DiffTime td = ta ^-^ tb + {-# INLINE (.+^) #-} + (view utcTime -> UTCTime day (DiffTime dt)) .+^ NominalDiffTime d + = review utcTime $ UTCTime day (DiffTime (dt ^+^ d)) + +{-# INLINE utcTime #-} +utcTime :: Simple Iso UTCTime UTCView +utcTime = iso unpack pack where + + {-# INLINE unpack #-} + unpack :: UTCTime -> UTCView + unpack (UTCPacked n) = UTCTime + (ModifiedJulianDay mjd) (DiffTime (Micro dt)) where + mjd = shiftR n bitsDayTime + dt = n .&. maskDayTime + + {-# INLINE pack #-} + pack :: UTCView -> UTCTime + pack (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) = + UTCPacked (shiftL (mjd + dd) bitsDayTime .|. pt) where + NominalDiffTime posixDay = posixDayLength + (dd, Micro pt) = microDivMod dt posixDay + + {-# INLINE bitsDayTime #-} + bitsDayTime :: Int + bitsDayTime = 37 -- enough for 86400 microseconds + + {-# INLINE maskDayTime #-} + maskDayTime :: Int64 + maskDayTime = shiftL 1 bitsDayTime - 1 + diff --git a/src/Data/Thyme/Format.hs b/src/Data/Thyme/Format.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Format.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Thyme.Format + ( FormatTime (..) + , formatTime + , ParseTime (..) + , parseTime + ) where + +import Prelude +import Control.Applicative +import Control.Lens +import Control.Monad.State.Strict hiding (get) +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as P +import Data.Basis +import Data.Bits +import qualified Data.ByteString.Char8 as S +import Data.Char +import Data.Int +import Data.Micro +import Data.Thyme.Calendar +import Data.Thyme.Calendar.MonthDay +import Data.Thyme.Calendar.OrdinalDate +import Data.Thyme.Calendar.WeekDate +import Data.Thyme.Clock.POSIX +import Data.Thyme.Clock.Scale +import Data.Thyme.Clock.UTC +import Data.Thyme.Format.Internal +import Data.Thyme.LocalTime +import Data.Thyme.TH +import qualified Data.Time.Format as T +import Data.VectorSpace +import System.Locale + +class FormatTime t where + showsTime :: TimeLocale -> t -> (Char -> ShowS) -> (Char -> ShowS) + +{-# INLINEABLE formatTime #-} +formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String +formatTime l@TimeLocale {..} spec t = go spec "" where + -- leave unrecognised codes as they are + format = showsTime l t (\ c s -> '%' : c : s) + go s = case s of + '%' : c : rest -> case c of + -- aggregate + 'c' -> go (dateTimeFmt ++ rest) + 'r' -> go (time12Fmt ++ rest) + 'X' -> go (timeFmt ++ rest) + 'x' -> go (dateFmt ++ rest) + -- modifier (whatever) + '-' -> go ('%' : rest) + '_' -> go ('%' : rest) + '0' -> go ('%' : rest) + '^' -> go ('%' : rest) + '#' -> go ('%' : rest) + -- escape (why would anyone need %t and %n?) + '%' -> (:) '%' . go rest + -- default + _ -> format c . go rest + c : rest -> (:) c . go rest + [] -> id + +{-# INLINE showsYear #-} +showsYear :: Year -> ShowS +#if BUG_FOR_BUG +showsYear = shows +#else +-- ISO 8601 says 4 digits, even for first millennium. +showsYear = shows04 +#endif + +instance FormatTime TimeOfDay where + {-# INLINEABLE showsTime #-} + showsTime TimeLocale {..} (TimeOfDay h m (DiffTime s)) = \ def c -> case c of + -- aggregate + 'R' -> shows02 h . (:) ':' . shows02 m + 'T' -> shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 si + -- AM/PM + 'P' -> (++) $ toLower <$> if h < 12 then fst amPm else snd amPm + 'p' -> (++) $ if h < 12 then fst amPm else snd amPm + -- Hour + 'H' -> shows02 h + 'I' -> shows02 $ 1 + mod (h - 1) 12 + 'k' -> shows_2 h + 'l' -> shows_2 $ 1 + mod (h - 1) 12 + -- Minute + 'M' -> shows02 m + -- Second + 'S' -> shows02 si + 'q' -> fills06 su . shows su . (++) "000000" + 'Q' -> if su == 0 then id else (:) '.' . fills06 su . drops0 su + -- default + _ -> def c + + where + (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000) + + {-# INLINE fills06 #-} + fills06 :: Int64 -> ShowS + fills06 n + | n < 10 = (++) "00000" + | n < 100 = (++) "0000" + | n < 1000 = (++) "000" + | n < 10000 = (++) "00" + | n < 100000 = (++) "0" + | otherwise = id + + {-# INLINE drops0 #-} + drops0 :: Int64 -> ShowS + drops0 n = case divMod n 10 of + (q, 0) -> drops0 q + _ -> shows n + +instance FormatTime YearMonthDay where + {-# INLINEABLE showsTime #-} + showsTime TimeLocale {..} (YearMonthDay y m d) = \ def c -> case c of + -- aggregate + 'D' -> shows02 m . (:) '/' . shows02 d . (:) '/' . shows02 (mod y 100) + 'F' -> showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d + -- Year + 'Y' -> showsYear y + 'y' -> shows02 (mod y 100) + 'C' -> shows02 (div y 100) + -- Month + 'B' -> (++) . fst $ months !! (m - 1) + 'b' -> (++) . snd $ months !! (m - 1) + 'h' -> (++) . snd $ months !! (m - 1) + 'm' -> shows02 m + -- DayOfMonth + 'd' -> shows02 d + 'e' -> shows_2 d + -- default + _ -> def c + +instance FormatTime MonthDay where + {-# INLINEABLE showsTime #-} + showsTime TimeLocale {..} (MonthDay m d) = \ def c -> case c of + -- Month + 'B' -> (++) . fst $ months !! (m - 1) + 'b' -> (++) . snd $ months !! (m - 1) + 'h' -> (++) . snd $ months !! (m - 1) + 'm' -> shows02 m + -- DayOfMonth + 'd' -> shows02 d + 'e' -> shows_2 d + -- default + _ -> def c + +instance FormatTime OrdinalDate where + {-# INLINEABLE showsTime #-} + showsTime TimeLocale {..} (OrdinalDate y d) = \ def c -> case c of + -- Year + 'Y' -> showsYear y + 'y' -> shows02 (mod y 100) + 'C' -> shows02 (div y 100) + -- DayOfYear + 'j' -> shows03 d + -- default + _ -> def c + +instance FormatTime WeekDate where + {-# INLINEABLE showsTime #-} + showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of + -- Year (WeekDate) + 'G' -> showsYear y + 'g' -> shows02 (mod y 100) + 'f' -> shows02 (div y 100) + -- WeekOfYear + 'V' -> shows02 w + -- DayOfWeek + 'u' -> shows d + 'A' -> (++) . fst $ wDays !! mod d 7 + 'a' -> (++) . snd $ wDays !! mod d 7 + 'w' -> shows (mod d 7) + -- default + _ -> def c + +instance FormatTime LocalTime where + {-# INLINEABLE showsTime #-} + showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod + +instance FormatTime Day where + {-# INLINEABLE showsTime #-} + showsTime l d = showsTime l ordinal + . showsTime l (view yearMonthDay ordinal) + . showsTime l (view weekDate d) . other where + ordinal = view ordinalDate d + other :: (Char -> ShowS) -> (Char -> ShowS) + other def c = case c of + -- Non-standard WeekOfYear + 'U' -> shows02 . wdWeek $ sundayStartWeek d + 'W' -> shows02 . wdWeek $ mondayStartWeek d + -- default + _ -> def c + +instance FormatTime TimeZone where + {-# INLINEABLE showsTime #-} + showsTime _ tz@(TimeZone _ _ name) = \ def c -> case c of + 'z' -> (++) (timeZoneOffsetString tz) + 'Z' -> (++) (if null name then timeZoneOffsetString tz else name) + _ -> def c + +instance FormatTime ZonedTime where + {-# INLINEABLE showsTime #-} + showsTime l (ZonedTime lt tz) = showsTime l lt . showsTime l tz + +instance FormatTime UTCTime where + {-# INLINEABLE showsTime #-} + showsTime l t = \ def c -> case c of + 's' -> shows . fst $ qr s (Micro 1000000) + _ -> showsTime l (view zonedTime (utc, t)) def c + where + NominalDiffTime s = view posixTime t +#if BUG_FOR_BUG + qr = microDivMod -- rounds down +#else + qr = microQuotRem -- rounds to 0 +#endif + +------------------------------------------------------------------------ + +data TimeFlag + = PostMeridiem + | HasCentury + | IsPOSIXTime + | IsGregorian + | IsWeekDate + deriving (Enum, Show) + +data TimeParse = TimeParse + { tpCentury :: {-# UNPACK #-}!Int + , tpCenturyYear :: {-# UNPACK #-}!Int{-YearOfCentury-} + , tpMonth :: {-# UNPACK #-}!Month + , tpWeekOfYear :: {-# UNPACK #-}!WeekOfYear + , tpDayOfMonth :: {-# UNPACK #-}!DayOfMonth + , tpDayOfYear :: {-# UNPACK #-}!DayOfYear + , tpDayOfWeek :: {-# UNPACK #-}!DayOfWeek + , tpFlags :: {-# UNPACK #-}!Int{-BitSet TimeFlag-} + , tpHour :: {-# UNPACK #-}!Hour + , tpMinute :: {-# UNPACK #-}!Minute + , tpSecond :: {-# UNPACK #-}!Int + , tpSecFrac :: {-# UNPACK #-}!DiffTime + , tpPOSIXTime :: {-# UNPACK #-}!POSIXTime + , tpTimeZone :: {-# UNPACK #-}!TimeZone + } deriving (Show) + +thymeLenses ''TimeParse + +{-# INLINE flag #-} +flag :: TimeFlag -> Simple Lens TimeParse Bool +flag (fromEnum -> f@(shiftL 1 -> m@(complement -> m'))) = _tpFlags . lens + (`testBit` f) (\ n b -> if b then n .|. m else n .&. m') + +{-# INLINE unixEpoch #-} +unixEpoch :: TimeParse +unixEpoch = TimeParse {..} where + tpCentury = 19 + tpCenturyYear = 70 + tpMonth = 1 + tpWeekOfYear = 1 + tpDayOfYear = 1 + tpDayOfMonth = 1 + tpDayOfWeek = 4 + tpFlags = 0 + tpHour = 0 + tpMinute = 0 + tpSecond = 0 + tpSecFrac = zeroV + tpPOSIXTime = zeroV + tpTimeZone = utc + +{-# INLINEABLE parseTime #-} +parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t +parseTime l spec = either (const Nothing) Just . P.parseOnly (readsTime l spec) . S.pack + +{-# INLINEABLE readsTime #-} +readsTime :: (ParseTime t) => TimeLocale -> String -> Parser t +readsTime l@TimeLocale {..} specString = buildTime + <$> execStateT (go specString) unixEpoch where + + go :: String -> StateT TimeParse Parser () + go spec = case spec of + '%' : cspec : rspec -> case cspec of + -- aggregate + 'c' -> go (dateTimeFmt ++ rspec) + 'r' -> go (time12Fmt ++ rspec) + 'X' -> go (timeFmt ++ rspec) + 'x' -> go (dateFmt ++ rspec) + 'R' -> go ("%H:%M" ++ rspec) + 'T' -> go ("%H:%M:%S" ++ rspec) + 'D' -> go ("%m/%d/%y" ++ rspec) + 'F' -> go ("%Y-%m-%d" ++ rspec) + -- AM/PM + 'P' -> dayHalf + 'p' -> dayHalf + -- Hour + 'H' -> lift (dec0 2) >>= setHour24 + 'I' -> lift (dec0 2) >>= setHour12 + 'k' -> lift (dec_ 2) >>= setHour24 + 'l' -> lift (dec_ 2) >>= setHour12 + -- Minute + 'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec + -- Second + 'S' -> lift (dec0 2) >>= assign _tpSecond >> go rspec + 'q' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec + 'Q' -> lift ((P.char '.' >> DiffTime <$> micro) <|> return zeroV) + >>= assign _tpSecFrac >> go rspec + + -- Year + -- FIXME: should full years / centuries be fixed width? + 'Y' -> lift (dec0 4) >>= setYear + 'y' -> lift (dec0 2) >>= assign _tpCenturyYear >> go rspec + 'C' -> lift (dec0 2) >>= assign _tpCentury + >> flag HasCentury .= True >> go rspec +{- + -- Month + 'B' -> indexOfCI (fst <$> months) (setMonth . succ) + 'b' -> indexOfCI (snd <$> months) (setMonth . succ) + 'h' -> indexOfCI (snd <$> months) (setMonth . succ) +-} + 'm' -> lift (dec0 2) >>= setMonth + -- DayOfMonth + 'd' -> lift (dec0 2) >>= setDayOfMonth + 'e' -> lift (dec_ 2) >>= setDayOfMonth + -- DayOfYear + 'j' -> lift (dec0 3) >>= assign _tpDayOfYear >> go rspec + + -- Year (WeekDate) + 'G' -> lift (dec0 4) >>= \ y -> flag IsWeekDate .= True >> setYear y + 'g' -> lift (dec0 2) >>= assign _tpCenturyYear + >> flag IsWeekDate .= True >> go rspec + 'f' -> lift (dec0 2) >>= assign _tpCentury + >> flag IsWeekDate .= True >> flag HasCentury .= True >> go rspec + -- WeekOfYear + 'V' -> lift (dec0 2) >>= setWeekOfYear -- ISO 8601 + 'U' -> lift (dec0 2) >>= setWeekOfYear -- Sunday start + 'W' -> lift (dec0 2) >>= setWeekOfYear -- Monday start + -- DayOfWeek + 'u' -> lift (dec0 1) >>= setDayOfWeek -- ISO 8601 + 'w' -> lift (dec0 1) >>= setDayOfWeek -- Sunday start +{- 'A' -> indexOfCI (fst <$> wDays) setDayOfWeek -} +{- 'a' -> indexOfCI (snd <$> wDays) setDayOfWeek -} + + -- TimeZone + 'z' -> timeZone "%z" + 'Z' -> timeZone "%Z" + -- UTCTime + 's' -> lift (negative P.decimal) >>= \ s -> flag IsPOSIXTime .= True + >> _tpPOSIXTime .= fromIntegral (s :: Int64) *^ basisValue () + >> go rspec + + -- modifier (whatever) + '-' -> go ('%' : rspec) + '_' -> go ('%' : rspec) + '0' -> go ('%' : rspec) + -- escape (why would anyone need %t and %n?) + '%' -> lift (P.char '%') >> go rspec + _ -> lift . fail $ "Unknown format character: " ++ show cspec + + where + dayHalf = do + pm <- lift $ False <$ P.stringCI (S.pack $ fst amPm) + <|> True <$ P.stringCI (S.pack $ snd amPm) + flag PostMeridiem .= pm + go rspec + setHour12 h = do _tpHour .= h; go rspec + setHour24 h = do _tpHour .= h; go rspec; flag PostMeridiem .= False + setYear ((`divMod` 100) -> (c, y)) = flag HasCentury .= True + >> _tpCentury .= c >> _tpCenturyYear .= y >> go rspec + setMonth m = _tpMonth .= m >> go rspec + setDayOfMonth d = _tpDayOfMonth .= d + >> flag IsGregorian .= True >> go rspec + setWeekOfYear w = _tpWeekOfYear .= w + >> flag IsWeekDate .= True >> go rspec + setDayOfWeek d = _tpDayOfWeek .= d + >> flag IsWeekDate .= True >> go rspec + -- "time" has a table of zones that we don't care to duplicate + timeZone zspec = {-lift (readS_to_P $ T.readsTime l zspec) + >>= assign _tpTimeZone >> -} go rspec + + c : rspec -> case isSpace c of + True -> lift (P.takeWhile1 isSpace) >> go (dropWhile isSpace rspec) + False -> lift (P.char c) >> go rspec + "" -> lift P.skipSpace + +class ParseTime t where + buildTime :: TimeParse -> t + +instance ParseTime TimeOfDay where + {-# INLINE buildTime #-} + buildTime tp@TimeParse {..} = TimeOfDay h tpMinute + (fromIntegral tpSecond *^ basisValue () ^+^ tpSecFrac) where + h = if tp ^. flag PostMeridiem && tpHour < 12 + then tpHour + 12 else tpHour + +{-# INLINE tpYear #-} +tpYear :: TimeParse -> Year +tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury + then tpCentury else if tpCenturyYear < 70 then 20 else 19 + +instance ParseTime YearMonthDay where + {-# INLINE buildTime #-} + buildTime tp@TimeParse {..} = YearMonthDay (tpYear tp) tpMonth tpDayOfMonth + +instance ParseTime MonthDay where + {-# INLINE buildTime #-} + buildTime TimeParse {..} = MonthDay tpMonth tpDayOfMonth + +instance ParseTime OrdinalDate where + {-# INLINE buildTime #-} + buildTime tp@TimeParse {..} = OrdinalDate (tpYear tp) tpDayOfYear + +instance ParseTime WeekDate where + {-# INLINE buildTime #-} + buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear tpDayOfWeek + +instance ParseTime LocalTime where + {-# INLINE buildTime #-} + buildTime = LocalTime <$> buildTime <*> buildTime + +instance ParseTime Day where + {-# INLINE buildTime #-} + buildTime tp@TimeParse {..} + | tp ^. flag IsGregorian = review gregorian (buildTime tp) + | tp ^. flag IsWeekDate = review weekDate (buildTime tp) + | otherwise = review ordinalDate (buildTime tp) + +instance ParseTime TimeZone where + {-# INLINE buildTime #-} + buildTime = tpTimeZone + +instance ParseTime ZonedTime where + {-# INLINE buildTime #-} + buildTime = ZonedTime <$> buildTime <*> buildTime + +instance ParseTime UTCTime where + {-# INLINE buildTime #-} + buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime + then review posixTime tpPOSIXTime + else view (from zonedTime . _2) (buildTime tp) + diff --git a/src/Data/Thyme/Format/Internal.hs b/src/Data/Thyme/Format/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Format/Internal.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ViewPatterns #-} + +module Data.Thyme.Format.Internal where + +import Prelude +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString.Char8 as S +import Data.Char +import Data.Int +import Data.Micro + +{-# INLINE shows02 #-} +shows02 :: Int -> String -> String +shows02 n = if n < 10 then (:) '0' . shows n else shows n + +{-# INLINE shows_2 #-} +shows_2 :: Int -> String -> String +shows_2 n = if n < 10 then (:) ' ' . shows n else shows n + +{-# INLINE shows03 #-} +shows03 :: Int -> ShowS +shows03 n + | n < 10 = (++) "00" . shows n + | n < 100 = (++) "0" . shows n + | otherwise = shows n + +{-# INLINE shows04 #-} +shows04 :: Int -> String -> String +shows04 n + | n < 10 = (++) "000" . shows n + | n < 100 = (++) "00" . shows n + | n < 1000 = (++) "0" . shows n + | otherwise = shows n + +------------------------------------------------------------------------ + +{- +{-# INLINEABLE indexOfCI #-} +indexOfCI :: (Alternative m, Monad m) => + [String] -> (Int -> String -> m k) -> (String -> m k) +indexOfCI l k input = uncurry k =<< foldr (<|>) no (zipWith match l [0..]) where + match s i = stringCI s (return . (,) i) input + no = fail $ "Expected month at " ++ show input +-} + +-- | Number may be prefixed with '-' +{-# INLINE negative #-} +negative :: Parser Int64 -> Parser Int64 +negative p = ($) <$> (negate <$ P.char '-' <|> pure id) <*> p + +-- | Fixed-length 0-padded decimal +{-# INLINEABLE dec0 #-} +dec0 :: Int -> Parser Int +dec0 n = either fail return . P.parseOnly P.decimal =<< P.take n + +-- | Fixed-length space-padded decimal +{-# INLINEABLE dec_ #-} +dec_ :: Int -> Parser Int +dec_ n = either fail return . P.parseOnly P.decimal + =<< S.dropWhile isSpace <$> P.take n + +{-# INLINEABLE micro #-} +micro :: Parser Micro +micro = do + us10 <- either fail return . P.parseOnly P.decimal . S.take 7 + . (`S.append` S.pack "000000") =<< P.takeWhile1 isDigit + return $ Micro (div (us10 + 5) 10) + diff --git a/src/Data/Thyme/LocalTime.hs b/src/Data/Thyme/LocalTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/LocalTime.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Thyme.LocalTime + ( module Data.Thyme.LocalTime.TimeZone + , module Data.Thyme.LocalTime.Internal + , module Data.Thyme.LocalTime + ) where + +import Prelude +import Control.Lens +import Data.Data +import Data.Thyme.Clock +import Data.Thyme.LocalTime.Internal +import Data.Thyme.LocalTime.TimeZone +import Data.Thyme.TH + +------------------------------------------------------------------------ +-- * Zoned Time + +data ZonedTime = ZonedTime + { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime + , zonedTimeZone :: !TimeZone + } deriving (Eq, Ord, Data, Typeable, Show) + +{-# INLINE zonedTime #-} +zonedTime :: Simple Iso (TimeZone, UTCTime) ZonedTime +zonedTime = iso toZoned fromZoned where + + {-# INLINE toZoned #-} + toZoned :: (TimeZone, UTCTime) -> ZonedTime + toZoned (tz, time) = ZonedTime (view (utcLocalTime tz) time) tz + + {-# INLINE fromZoned #-} + fromZoned :: ZonedTime -> (TimeZone, UTCTime) + fromZoned (ZonedTime lt tz) = (tz, review (utcLocalTime tz) lt) + +{-# INLINE getZonedTime #-} +getZonedTime :: IO ZonedTime +getZonedTime = utcToLocalZonedTime =<< getCurrentTime + +{-# INLINEABLE utcToLocalZonedTime #-} +utcToLocalZonedTime :: UTCTime -> IO ZonedTime +utcToLocalZonedTime time = do + tz <- getTimeZone time + return (view zonedTime (tz, time)) + +------------------------------------------------------------------------ +-- * Lenses + +thymeLenses ''TimeZone +thymeLenses ''TimeOfDay +thymeLenses ''LocalTime +thymeLenses ''ZonedTime + diff --git a/src/Data/Thyme/LocalTime/Internal.hs b/src/Data/Thyme/LocalTime/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/LocalTime/Internal.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- #hide +module Data.Thyme.LocalTime.Internal where + +import Prelude hiding ((.)) +import Control.Applicative +import Control.Category +import Control.Lens +import Control.Monad +import Data.AffineSpace +import Data.Data +import Data.Micro +import Data.Thyme.Calendar +import Data.Thyme.Clock.Scale +import Data.Thyme.Clock.UTC +#if !SHOW_INTERNAL +import Data.Thyme.Format.Internal +#endif +import Data.Thyme.LocalTime.TimeZone +import Data.VectorSpace + +------------------------------------------------------------------------ +-- * Time of day + +type Hour = Int +type Minute = Int +data TimeOfDay = TimeOfDay + { todHour :: {-# UNPACK #-}!Hour + , todMin :: {-# UNPACK #-}!Minute + , todSec :: {-# UNPACK #-}!DiffTime + } deriving (Eq, Ord, Data, Typeable) + +#if SHOW_INTERNAL +deriving instance Show TimeOfDay +#else +instance Show TimeOfDay where + showsPrec _ (TimeOfDay h m (DiffTime s)) + = shows02 h . (:) ':' . shows02 m . (:) ':' + . shows02 (fromIntegral . fst . microQuotRem s $ Micro 1000000) +#endif + +{-# INLINE makeTimeOfDayValid #-} +makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay +makeTimeOfDayValid h m s@(DiffTime u) = TimeOfDay h m s + <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59) + <* guard (Micro 0 <= u && u < Micro 61000000) + +{-# INLINE timeOfDay #-} +timeOfDay :: Simple Iso DiffTime TimeOfDay +timeOfDay = iso fromDiff toDiff where + + {-# INLINEABLE fromDiff #-} + fromDiff :: DiffTime -> TimeOfDay + fromDiff (DiffTime t) = TimeOfDay + (fromIntegral h) (fromIntegral m) (DiffTime s) where + (h, ms) = microQuotRem t (toMicro 3600) + (m, s) = microQuotRem ms (toMicro 60) + + {-# INLINEABLE toDiff #-} + toDiff :: TimeOfDay -> DiffTime + toDiff (TimeOfDay h m s) = s + ^+^ fromIntegral m *^ DiffTime (toMicro 60) + ^+^ fromIntegral h *^ DiffTime (toMicro 3600) + +type Minutes = Int +type Days = Int + +-- | Add some minutes to a 'TimeOfDay'; result comes with a day adjustment. +{-# INLINE addMinutes #-} +addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay) +addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where + (dd, h') = divMod (h + dh) 24 + (dh, m') = divMod (m + dm) 60 + +{-# INLINE timeOfDayFraction #-} +timeOfDayFraction :: Simple Iso Rational TimeOfDay +timeOfDayFraction = iso fromRatio toRatio . timeOfDay where + NominalDiffTime posixDay = posixDayLength + + fromRatio :: Rational -> DiffTime + fromRatio r = DiffTime (r *^ posixDay) where + + toRatio :: DiffTime -> Rational + toRatio (DiffTime t) = t ^/^ posixDay + +------------------------------------------------------------------------ +-- * Local Time + +data LocalTime = LocalTime + { localDay :: {-# UNPACK #-}!Day + , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay + } deriving (Eq, Ord, Data, Typeable) + +#if SHOW_INTERNAL +deriving instance Show LocalTime +#else +instance Show LocalTime where + showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t +#endif + +{-# INLINE utcLocalTime #-} +utcLocalTime :: TimeZone -> Simple Iso UTCTime LocalTime +utcLocalTime TimeZone {..} = utcTime . iso localise globalise where + + {-# INLINEABLE localise #-} + localise :: UTCView -> LocalTime + localise (UTCTime day dt) = LocalTime (day .+^ dd) tod where + (dd, tod) = addMinutes timeZoneMinutes (view timeOfDay dt) + + {-# INLINEABLE globalise #-} + globalise :: LocalTime -> UTCView + globalise (LocalTime day tod) = UTCTime (day .+^ dd) + (review timeOfDay utcToD) where + (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod + +-- TODO: ut1LocalTime + diff --git a/src/Data/Thyme/LocalTime/TimeZone.hs b/src/Data/Thyme/LocalTime/TimeZone.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/LocalTime/TimeZone.hs @@ -0,0 +1,26 @@ +module Data.Thyme.LocalTime.TimeZone ( + -- * Time zones + T.TimeZone (..) + , T.timeZoneOffsetString + , T.timeZoneOffsetString' + , T.minutesToTimeZone + , T.hoursToTimeZone + , T.utc + , T.getCurrentTimeZone + , module Data.Thyme.LocalTime.TimeZone + ) where + +import Prelude +import Control.Lens +import Data.Micro +import Data.Thyme.Calendar +import Data.Thyme.Clock.Scale +import Data.Thyme.Clock.UTC +import qualified Data.Time as T + +getTimeZone :: UTCTime -> IO T.TimeZone +getTimeZone time = T.getTimeZone (T.UTCTime day dayTime) where + day = T.ModifiedJulianDay (fromIntegral mjd) + dayTime = fromRational $ dt ^/^ DiffTime (toMicro 1) + UTCTime (ModifiedJulianDay mjd) dt = view utcTime time + diff --git a/src/Data/Thyme/TH.hs b/src/Data/Thyme/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/TH.hs @@ -0,0 +1,11 @@ +-- #hide +module Data.Thyme.TH (thymeLenses) where + +import Prelude +import Control.Lens +import Language.Haskell.TH + +thymeLenses :: Name -> Q [Dec] +thymeLenses = makeLensesWith $ lensRules + & lensField .~ Just . (:) '_' + diff --git a/tests/sanity.hs b/tests/sanity.hs new file mode 100644 --- /dev/null +++ b/tests/sanity.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Prelude +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.Trans +import Criterion +import Criterion.Analysis +import Criterion.Config +import Criterion.Environment +import Criterion.Monad +import Data.Basis +import Data.List +import Data.Monoid +import Data.Thyme +import qualified Data.Time as T +import Data.VectorSpace +import System.Exit +import System.Locale +import System.Random +import Test.QuickCheck +import qualified Test.QuickCheck.Gen as Gen +import Text.Printf + +instance Arbitrary Day where + arbitrary = fmap (review gregorian) $ YearMonthDay + <$> choose (0, 9999) <*> choose (1, 12) <*> choose (1, 31) + +instance Arbitrary DiffTime where + arbitrary = (^*) (basisValue ()) . toRational <$> (choose (0, 86400.999999) :: Gen Double) + +instance Arbitrary UTCTime where + arbitrary = fmap (review utcTime) $ UTCTime <$> arbitrary <*> arbitrary + +toTime :: UTCTime -> T.UTCTime +toTime (view utcTime -> UTCTime (ModifiedJulianDay d) t) = T.UTCTime + (T.ModifiedJulianDay $ fromIntegral d) (fromRational $ t ^/^ basisValue ()) + +(^/^) :: (HasBasis v, Basis v ~ (), Scalar v ~ s, Fractional s) => v -> v -> s +x ^/^ y = decompose' x () / decompose' y () + +------------------------------------------------------------------------ + +newtype Spec = Spec String deriving (Show) + +instance Arbitrary Spec where + arbitrary = fmap (Spec . intercalate " " . map (\ c -> ['%', c])) + . Gen.listOf1 . Gen.elements . nub $ + {-aggregate/escape-}"crXx%" ++ {-TimeOfDay-}"RTPpHIklMSqQ" ++ + {-YearMonthDay-}"DFYyCBbhmde" ++ {-MonthDay-}"Bbhmde" ++ + {-OrdinalDate-}"YyCj" ++ {-WeekDate-}"GgfVuAaw" ++ + {-Day-}"UW" ++ {-TimeZone-}"zZ" ++ {-UTCTime-}"s" + +------------------------------------------------------------------------ + +prop_formatTime :: Spec -> UTCTime -> Property +prop_formatTime (Spec spec) t@(toTime -> t') + = printTestCase desc (s == s') where + s = formatTime defaultTimeLocale spec t + s' = T.formatTime defaultTimeLocale spec t' + desc = "thyme: " ++ s ++ "\ntime: " ++ s' + +prop_parseTime :: Spec -> UTCTime -> Property +prop_parseTime (Spec spec) (T.formatTime defaultTimeLocale spec . toTime -> s) + = printTestCase desc (fmap toTime t == t') where + t = parseTime defaultTimeLocale spec s + t' = T.parseTime defaultTimeLocale spec s + desc = "input: " ++ s ++ "\nthyme: " ++ show t ++ "\ntime: " ++ show t' + +------------------------------------------------------------------------ + +main :: IO () +main = do + correct <- fmap (all isSuccess) . mapM quickCheckResult $ + prop_formatTime : + prop_parseTime : + [] + + ts <- Gen.unGen (vectorOf 10 arbitrary) <$> newStdGen <*> pure 0 + let ts' = toTime <$> ts + let ss = T.formatTime defaultTimeLocale spec <$> ts' + fast <- fmap and . withConfig config $ do + env <- measureEnvironment + ns <- getConfigItem $ fromLJ cfgResamples + mapM (benchMean env ns) $ + ( "formatTime", 9 + , nf (formatTime defaultTimeLocale spec <$>) ts + , nf (T.formatTime defaultTimeLocale spec <$>) ts' ) : + ("parseTime", 5, nf (parse <$>) ss, nf (parse' <$>) ss ) : + [] + + exitWith $ if correct && fast then ExitSuccess else ExitFailure 1 + where + isSuccess r = case r of Success {} -> True; _ -> False + config = defaultConfig {cfgVerbosity = Last (Just Quiet)} + + spec = "%F %G %V %u %j %T %p %s" + parse = parseTime defaultTimeLocale spec :: String -> Maybe UTCTime + parse' = T.parseTime defaultTimeLocale spec :: String -> Maybe T.UTCTime + + benchMean env n (name, expected, us, them) = do + ours <- flip analyseMean n =<< runBenchmark env us + theirs <- flip analyseMean n =<< runBenchmark env them + let ratio = theirs / ours + liftIO . void $ printf + "%s: %.1f× faster; expected %.1f×.\n" name ratio expected + return (ratio >= expected) + diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -1,14 +1,14 @@ name: thyme -version: 0.1.1.1 +version: 0.1.2.0 synopsis: A faster time library description: A faster time library homepage: https://github.com/liyang/thyme license: BSD3 license-file: LICENSE -author: Liyang HU +author: Liyang HU, Ashley Yakeley maintainer: thyme@liyang.hu -copyright: © 2013 Liyang HU, Ashley Yakeley +copyright: © 2013 Liyang HU category: Data, System build-type: Simple cabal-version: >= 1.8 @@ -22,11 +22,16 @@ description: instance Num (Nominal)DiffTime default: True +flag bug-for-bug + description: bug-for-bug compatibility with time + default: True + flag show-internal description: instance Show of internal representation default: False library + hs-source-dirs: src exposed-modules: Data.Thyme Data.Thyme.Calendar @@ -43,20 +48,45 @@ Data.Thyme.Clock.Scale Data.Thyme.Clock.UTC Data.Thyme.Format.Internal + Data.Thyme.LocalTime.Internal + Data.Thyme.LocalTime.TimeZone Data.Thyme.TH build-depends: base >= 4.5 && < 5, + mtl >= 2.1, deepseq >= 1.2, vector-space >= 0.8, lens >= 3.7, old-locale >= 1.0, template-haskell >= 2.6, + bytestring >= 0.10, + attoparsec >= 0.10, time >= 1.4 ghc-options: -Wall if flag(instance-num) cpp-options: -DINSTANCE_NUM=1 + if flag(bug-for-bug) + cpp-options: -DBUG_FOR_BUG=1 if flag(show-internal) cpp-options: -DSHOW_INTERNAL=1 + +test-suite sanity + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: sanity.hs + build-depends: + base >= 4.5 && < 5, + mtl >= 2.1, + deepseq >= 1.2, + vector-space >= 0.8, + lens >= 3.7, + old-locale >= 1.0, + random >= 1.0, + QuickCheck >= 2.4, + criterion >= 0.6, + thyme, + time >= 1.4 + ghc-options: -Wall -- vim: et sw=4 ts=4 sts=4: