packages feed

thyme (empty) → 0.1.0.0

raw patch · 16 files changed

+883/−0 lines, 16 filesdep +basedep +deepseqdep +lenssetup-changed

Dependencies added: base, deepseq, lens, template-haskell, time, vector-space

Files

+ Data/Micro.hs view
@@ -0,0 +1,97 @@+{-# 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) = printf "%d.%06u" q r where+        (q, r) = divMod 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 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++-- TODO: instance Real Micro+-- TODO: instance RealFrac Micro+#endif++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 () = 1+    {-# 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 view
@@ -0,0 +1,11 @@+module Data.Thyme+    ( module Data.Thyme.Calendar+    , module Data.Thyme.Clock+    , module Data.Thyme.LocalTime+    ) where++import Data.Thyme.Calendar+import Data.Thyme.Clock+-- TODO: Data.Thyme.Format+import Data.Thyme.LocalTime+
+ Data/Thyme/Calendar.hs view
@@ -0,0 +1,49 @@+module Data.Thyme.Calendar (+    -- * Days+      Day (..)+    -- * Gregorian calendar+    , Year, Month, DayOfMonth+    , YearMonthDay (..)+    , module Data.Thyme.Calendar+    , isLeapYear+    -- * Lenses+    , _toModifiedJulianDay+    , _ymdYear, _ymdMonth, _ymdDay+    ) where++import Prelude hiding ((.))+import Control.Applicative+import Control.Category+import Control.Lens+import Data.Thyme.Calendar.Day+import Data.Thyme.Calendar.OrdinalDate+import Data.Thyme.Calendar.MonthDay++{-# INLINE gregorian #-}+gregorian :: Simple Iso Day YearMonthDay+gregorian = ordinalDate . iso fromOrdinal toOrdinal where++    {-# INLINE fromOrdinal #-}+    fromOrdinal :: OrdinalDate -> YearMonthDay+    fromOrdinal (OrdinalDate y yd) = (YearMonthDay y m d) where+        MonthDay m d = view (monthDay (isLeapYear y)) yd++    {-# INLINE toOrdinal #-}+    toOrdinal :: YearMonthDay -> OrdinalDate+    toOrdinal (YearMonthDay y m d) = OrdinalDate y $+        review (monthDay (isLeapYear y)) (MonthDay m d)++{-# INLINE fromGregorianValid #-}+fromGregorianValid :: YearMonthDay -> Maybe Day+fromGregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y+    <$> monthDayToDayOfYearValid (isLeapYear y) (MonthDay m d)++-- TODO: showGregorian++{-# INLINE gregorianMonthLength #-}+gregorianMonthLength :: Year -> Month -> Int+gregorianMonthLength = monthLength . isLeapYear++-- TODO: addGregorianMonthsClip addGregorianMonthsRollover+-- TODO: addGregorianYearsClip addGregorianYearsRollover+
+ Data/Thyme/Calendar/Day.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- #hide+module Data.Thyme.Calendar.Day where++import Prelude+import Control.DeepSeq+import Data.AffineSpace+import Data.Data+import Data.Int+import Data.Ix+import Data.Thyme.TH++-- | 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)++thymeLenses ''Day++#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 DayOfYear = 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)++thymeLenses ''YearMonthDay++instance NFData YearMonthDay+
+ Data/Thyme/Calendar/MonthDay.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++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.Day+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 view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-}++-- | ISO 8601 Ordinal Date format++module Data.Thyme.Calendar.OrdinalDate+    ( Year, DayOfYear+    , module Data.Thyme.Calendar.OrdinalDate+    ) where++import Prelude+import Control.Applicative+import Control.Lens+import Control.Monad+import Data.Thyme.Calendar.Day+import Data.Thyme.TH++data OrdinalDate = OrdinalDate+    { odYear :: {-# UNPACK #-}!Year+    , odDay :: {-# UNPACK #-}!DayOfYear }++{-# 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++{-# 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)++{-# INLINE isLeapYear #-}+isLeapYear :: Year -> Bool+isLeapYear y = mod y 4 == 0 && (mod y 400 == 0 || mod y 100 /= 0)++-- TODO: mondayStartWeek fromMondayStartWeek fromMondayStartWeekValid+-- TODO: sundayStartWeek fromSundayStartWeek fromSundayStartWeekValid++-- * Lenses+thymeLenses ''OrdinalDate+
+ Data/Thyme/Calendar/WeekDate.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}++-- | ISO 8601 Week Date format+module Data.Thyme.Calendar.WeekDate where++import Prelude+import Control.Applicative+import Control.Lens+import Control.Monad+import Data.Data+import Data.Int+import Data.Thyme.Calendar.Day+import Data.Thyme.Calendar.OrdinalDate+import Data.Thyme.TH+import Text.Printf++type Week = Int+type DayOfWeek = Int+data WeekDate = WeekDate+    { wdYear :: {-# UNPACK #-}!Year+    , wdWeek :: {-# UNPACK #-}!Week+    , wdDay :: {-# UNPACK #-}!DayOfWeek+    } deriving (Eq, Ord, Data, Typeable, Show)++{-# 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 -> Int64+        foo y = bar $ review ordinalDate (OrdinalDate y 6)+        bar :: Day -> 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 (WeekDate y w wd) = ModifiedJulianDay mjd where+        -- pilfered and refactored+        ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6)+        WeekDate _ wMax _ = toWeek $ review ordinalDate (OrdinalDate y 365)+        mjd = k - mod k 7 - 10 + clip 1 7 (fromIntegral wd)+            + fromIntegral (clip 1 wMax w) * 7+        clip a b = max a . min b++fromWeekDateValid :: WeekDate -> Maybe Day+fromWeekDateValid wd@(WeekDate y w d) = review weekDate wd+        <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) where+    -- TODO: inline fromWeek so we can share wMax?+    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 view
@@ -0,0 +1,26 @@+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 view
@@ -0,0 +1,35 @@+module Data.Thyme.Clock.POSIX+    ( posixDayLength+    , module Data.Thyme.Clock.POSIX+    ) where++import Prelude+import Control.Lens+import Data.AdditiveGroup+import Data.AffineSpace+import qualified Data.Time.Clock.POSIX as T+import Data.Thyme.Calendar.Day+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 'realToFrac'?+{-# INLINE getPOSIXTime #-}+getPOSIXTime :: IO POSIXTime+getPOSIXTime = fmap realToFrac T.getPOSIXTime+
+ Data/Thyme/Clock/Scale.hs view
@@ -0,0 +1,53 @@+{-# 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 () = 1+    {-# INLINE decompose #-}+    decompose (DiffTime a) = decompose a+    {-# INLINE decompose' #-}+    decompose' (DiffTime a) = decompose' a++#if INSTANCE_NUM+deriving instance Num DiffTime+deriving instance Fractional DiffTime+#endif++{-# INLINE microsecondsToDiffTime #-}+microsecondsToDiffTime :: Int64 -> DiffTime+microsecondsToDiffTime = DiffTime . Micro
+ Data/Thyme/Clock/UTC.hs view
@@ -0,0 +1,112 @@+{-# 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.Day+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 () = 1+    {-# INLINE decompose #-}+    decompose (NominalDiffTime a) = decompose a+    {-# INLINE decompose' #-}+    decompose' (NominalDiffTime a) = decompose' a++#if INSTANCE_NUM+deriving instance Num NominalDiffTime+deriving instance Fractional 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/LocalTime.hs view
@@ -0,0 +1,156 @@+{-# 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.Day+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 = TimeOfDay h m s+    <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59 && 0 <= s && s < 61)++{-# 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 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 . (:) '_'+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Liyang HU++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Liyang HU nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ thyme.cabal view
@@ -0,0 +1,59 @@+name:           thyme+version:        0.1.0.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+maintainer:     thyme@liyang.hu+copyright:      © 2013 Liyang HU+category:       Data, System+build-type:     Simple+cabal-version:  >=1.8+stability:      experimental++source-repository head+    type:       git+    location:   http://github.com/liyang/thyme++flag instance-num+    description: instance Num (Nominal)DiffTime+    default: True++flag show-internal+    description: instance Show of internal representation+    default: False++library+    exposed-modules:+        Data.Thyme+        Data.Thyme.Calendar+        Data.Thyme.Calendar.MonthDay+        Data.Thyme.Calendar.OrdinalDate+        Data.Thyme.Calendar.WeekDate+        Data.Thyme.Clock+        Data.Thyme.Clock.POSIX+        Data.Thyme.LocalTime+    other-modules:+        Data.Micro+        Data.Thyme.Calendar.Day+        Data.Thyme.Clock.Scale+        Data.Thyme.Clock.UTC+        Data.Thyme.TH+    build-depends:+        base >= 4.6 && < 5,+        deepseq >= 1.2,+        vector-space >= 0.8,+        lens >= 3.7,+        template-haskell >= 2.6,+        time >= 1.4+    ghc-options: -Wall+    if flag(instance-num)+        cpp-options: -DINSTANCE_NUM=1+    if flag(show-internal)+        cpp-options: -DSHOW_INTERNAL=1++-- vim: et sw=4 ts=4 sts=4:+