thyme 0.1.1.1 → 0.1.2.0
raw patch · 34 files changed
+1597/−1094 lines, 34 filesdep +QuickCheckdep +attoparsecdep +bytestring
Dependencies added: QuickCheck, attoparsec, bytestring, criterion, mtl, random, thyme
Files
- Data/Micro.hs +0/−106
- Data/Thyme.hs +0/−12
- Data/Thyme/Calendar.hs +0/−62
- Data/Thyme/Calendar/Internal.hs +0/−142
- Data/Thyme/Calendar/MonthDay.hs +0/−55
- Data/Thyme/Calendar/OrdinalDate.hs +0/−57
- Data/Thyme/Calendar/WeekDate.hs +0/−34
- Data/Thyme/Clock.hs +0/−26
- Data/Thyme/Clock/POSIX.hs +0/−36
- Data/Thyme/Clock/Scale.hs +0/−55
- Data/Thyme/Clock/UTC.hs +0/−114
- Data/Thyme/Format.hs +0/−197
- Data/Thyme/Format/Internal.hs +0/−27
- Data/Thyme/LocalTime.hs +0/−157
- Data/Thyme/TH.hs +0/−11
- src/Data/Micro.hs +107/−0
- src/Data/Thyme.hs +12/−0
- src/Data/Thyme/Calendar.hs +70/−0
- src/Data/Thyme/Calendar/Internal.hs +137/−0
- src/Data/Thyme/Calendar/MonthDay.hs +55/−0
- src/Data/Thyme/Calendar/OrdinalDate.hs +57/−0
- src/Data/Thyme/Calendar/WeekDate.hs +34/−0
- src/Data/Thyme/Clock.hs +42/−0
- src/Data/Thyme/Clock/POSIX.hs +36/−0
- src/Data/Thyme/Clock/Scale.hs +55/−0
- src/Data/Thyme/Clock/UTC.hs +114/−0
- src/Data/Thyme/Format.hs +447/−0
- src/Data/Thyme/Format/Internal.hs +70/−0
- src/Data/Thyme/LocalTime.hs +57/−0
- src/Data/Thyme/LocalTime/Internal.hs +122/−0
- src/Data/Thyme/LocalTime/TimeZone.hs +26/−0
- src/Data/Thyme/TH.hs +11/−0
- tests/sanity.hs +112/−0
- thyme.cabal +33/−3
− Data/Micro.hs
@@ -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 ()-
− Data/Thyme.hs
@@ -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-
− Data/Thyme/Calendar.hs
@@ -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-
− Data/Thyme/Calendar/Internal.hs
@@ -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-
− Data/Thyme/Calendar/MonthDay.hs
@@ -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-
− Data/Thyme/Calendar/OrdinalDate.hs
@@ -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-
− Data/Thyme/Calendar/WeekDate.hs
@@ -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-
− Data/Thyme/Clock.hs
@@ -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-
− Data/Thyme/Clock/POSIX.hs
@@ -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-
− Data/Thyme/Clock/Scale.hs
@@ -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
− Data/Thyme/Clock/UTC.hs
@@ -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-
− Data/Thyme/Format.hs
@@ -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-
− Data/Thyme/Format/Internal.hs
@@ -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-
− Data/Thyme/LocalTime.hs
@@ -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-
− Data/Thyme/TH.hs
@@ -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 . (:) '_'-
+ src/Data/Micro.hs view
@@ -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 ()+
+ src/Data/Thyme.hs view
@@ -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+
+ src/Data/Thyme/Calendar.hs view
@@ -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+
+ src/Data/Thyme/Calendar/Internal.hs view
@@ -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+
+ src/Data/Thyme/Calendar/MonthDay.hs view
@@ -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+
+ src/Data/Thyme/Calendar/OrdinalDate.hs view
@@ -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+
+ src/Data/Thyme/Calendar/WeekDate.hs view
@@ -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+
+ src/Data/Thyme/Clock.hs view
@@ -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+
+ src/Data/Thyme/Clock/POSIX.hs view
@@ -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+
+ src/Data/Thyme/Clock/Scale.hs view
@@ -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
+ src/Data/Thyme/Clock/UTC.hs view
@@ -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+
+ src/Data/Thyme/Format.hs view
@@ -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)+
+ src/Data/Thyme/Format/Internal.hs view
@@ -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)+
+ src/Data/Thyme/LocalTime.hs view
@@ -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+
+ src/Data/Thyme/LocalTime/Internal.hs view
@@ -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+
+ src/Data/Thyme/LocalTime/TimeZone.hs view
@@ -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+
+ src/Data/Thyme/TH.hs view
@@ -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 . (:) '_'+
+ tests/sanity.hs view
@@ -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)+
thyme.cabal view
@@ -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: