thyme-0.3.5.5/0000755000000000000000000000000012435525530011202 5ustar0000000000000000thyme-0.3.5.5/LICENSE0000644000000000000000000000275412435525530012217 0ustar0000000000000000Copyright (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. thyme-0.3.5.5/Setup.hs0000644000000000000000000000005612435525530012637 0ustar0000000000000000import Distribution.Simple main = defaultMain thyme-0.3.5.5/thyme.cabal0000644000000000000000000001115412435525530013316 0ustar0000000000000000name: thyme version: 0.3.5.5 synopsis: A faster time library description: Thyme is a rewrite of the fine @time@ library, with a particular focus on performance for applications that make heavy use of timestamps. . See for a full description. homepage: https://github.com/liyang/thyme license: BSD3 license-file: LICENSE author: Liyang HU, Ashley Yakeley maintainer: thyme@liyang.hu copyright: © 2013−2014 Liyang HU category: Data, System build-type: Simple cabal-version: >= 1.10 stability: experimental extra-source-files: include/thyme.h source-repository head type: git location: https://github.com/liyang/thyme flag bug-for-bug description: bug-for-bug compatibility with time default: True manual: True flag HLint description: include HLint as a Cabal test-suite default: False manual: True flag lens description: use the full lens package default: False manual: True flag show-internal description: instance Show of internal representation default: False manual: True flag Werror description: -Werror default: False manual: True library default-language: Haskell2010 include-dirs: include hs-source-dirs: src if !flag(lens) hs-source-dirs: lens exposed-modules: Data.Thyme Data.Thyme.Calendar Data.Thyme.Calendar.MonthDay Data.Thyme.Calendar.OrdinalDate Data.Thyme.Calendar.WeekDate Data.Thyme.Calendar.WeekdayOfMonth Data.Thyme.Clock Data.Thyme.Clock.POSIX Data.Thyme.Clock.TAI Data.Thyme.Format Data.Thyme.Format.Human Data.Thyme.Format.Aeson Data.Thyme.Internal.Micro Data.Thyme.LocalTime Data.Thyme.Time Data.Thyme.Time.Core other-modules: Data.Thyme.Calendar.Internal Data.Thyme.Clock.Internal Data.Thyme.Format.Internal if !flag(lens) other-modules: Control.Lens build-depends: QuickCheck >= 2.4, attoparsec >= 0.10, aeson >= 0.6, base >= 4.5 && < 5, bytestring >= 0.9, containers, deepseq >= 1.2, mtl >= 1.1, old-locale >= 1.0, random, text >= 0.11, time >= 1.4, vector >= 0.9, vector-th-unbox >= 0.2.1.0, vector-space >= 0.8 if os(windows) build-depends: Win32 if os(darwin) build-tools: cpphs ghc-options: -pgmP cpphs -optP--cpp if flag(lens) build-depends: lens >= 3.9 else build-depends: profunctors >= 3.1.2 ghc-options: -Wall if flag(bug-for-bug) cpp-options: -DBUG_FOR_BUG=1 if flag(show-internal) cpp-options: -DSHOW_INTERNAL=1 if flag(Werror) ghc-options: -Werror test-suite sanity default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests if !flag(lens) hs-source-dirs: lens main-is: sanity.hs other-modules: Common if !flag(lens) other-modules: Control.Lens build-depends: QuickCheck, attoparsec, base, bytestring, old-locale, text, thyme, time, vector-space if flag(lens) build-depends: lens else build-depends: profunctors, mtl ghc-options: -Wall test-suite rewrite default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: rewrite.hs build-depends: Cabal, base, containers, directory, filepath, random, system-posix-redirect >= 1.1, text, thyme ghc-options: -Wall test-suite hlint default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: hlint.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests if flag(HLint) build-depends: base, hlint >= 1.9 else buildable: False benchmark bench default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests if !flag(lens) hs-source-dirs: lens main-is: bench.hs other-modules: Common if !flag(lens) other-modules: Control.Lens build-depends: QuickCheck, base, criterion, mtl, old-locale, random, thyme, time, vector, vector-space if flag(lens) build-depends: lens else build-depends: profunctors ghc-options: -Wall -- vim: et sw=4 ts=4 sts=4: thyme-0.3.5.5/src/0000755000000000000000000000000012435525530011771 5ustar0000000000000000thyme-0.3.5.5/src/Data/0000755000000000000000000000000012435525530012642 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme.hs0000644000000000000000000000310712435525530014265 0ustar0000000000000000-- | Thyme is a rewrite of the fine @time@ library, with a particular focus -- on performance for applications that make heavy use of timestamps. For -- example, 'UTCTime' is represented with μs precision as an -- 'Data.Int.Int64', which gives a usable range from @-290419-11-07 -- 19:59:05.224192 UTC@ to @294135-11-26 04:00:54.775807 UTC@ in the future. -- -- Conversions are provided as @Iso'@s from the -- package, while -- 'Data.AdditiveGroup.AdditiveGroup', 'Data.VectorSpace.VectorSpace' and -- 'Data.AffineSpace.AffineSpace' from -- allow for -- more principled operations instead of 'Num', 'Fractional' & al. -- -- Thyme uses strict and unpacked tuples throughout, e.g. 'YearMonthDay' or -- 'Data.Thyme.Calendar.WeekDate.WeekDate'. Descriptive 'Int' synonyms such -- as 'Year' and 'DayOfMonth' are also provided. -- -- On platforms where 'Int' is 64-bits wide, types with an 'Enum' instance -- can be used as 'Data.IntMap.Key's for 'Data.IntMap.IntMap', preferably -- via the @EnumMap@ wrapper provided by -- . In any case the 'Ord' -- instances are much faster, if you must use 'Data.Map.Map'. -- -- "Data.Thyme.Time" is a drop-in compatibility module for existing code. 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 thyme-0.3.5.5/src/Data/Thyme/0000755000000000000000000000000012435525530013730 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme/Calendar.hs0000644000000000000000000000750012435525530015777 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "thyme.h" -- | 'UTCTime' is not Y294K-compliant, and 'Bounded' instances for the -- various calendar types reflect this fact. That said, the calendar -- calculations by themselves work perfectly fine for a wider range of -- dates, subject to the size of 'Int' for your platform. module Data.Thyme.Calendar ( Years, Months, Days -- * Days , Day (..), modifiedJulianDay -- * Gregorian calendar , Year, Month, DayOfMonth , YearMonthDay (..) , isLeapYear , yearMonthDay, gregorian, gregorianValid, showGregorian , module Data.Thyme.Calendar ) where import Prelude hiding ((.)) import Control.Applicative import Control.Arrow import Control.Category import Control.Lens import Control.Monad import Data.AdditiveGroup import Data.Thyme.Calendar.Internal import Data.Thyme.Clock.Internal import System.Random import Test.QuickCheck -- "Data.Thyme.Calendar.Internal" cannot import "Data.Thyme.Clock.Internal", -- therefore these orphan 'Bounded' instances must live here. instance Bounded Day where minBound = minBound ^. _utctDay maxBound = maxBound ^. _utctDay instance Bounded YearMonthDay where minBound = minBound ^. gregorian maxBound = maxBound ^. gregorian instance Random Day where randomR r = first (^. _utctDay) . randomR (range r) where -- upper bound is one Micro second before the next day range = toMidnight *** pred . toMidnight . succ toMidnight = (utcTime #) . flip UTCTime zeroV random = randomR (minBound, maxBound) instance Random YearMonthDay where randomR = randomIsoR gregorian random = first (^. gregorian) . random instance Arbitrary Day where arbitrary = ModifiedJulianDay <$> choose (join (***) toModifiedJulianDay (minBound, maxBound)) shrink (ModifiedJulianDay mjd) = ModifiedJulianDay <$> shrink mjd instance Arbitrary YearMonthDay where arbitrary = view gregorian <$> arbitrary shrink ymd = view gregorian <$> shrink (gregorian # ymd) instance CoArbitrary YearMonthDay where coarbitrary (YearMonthDay y m d) = coarbitrary y . coarbitrary m . coarbitrary d ------------------------------------------------------------------------ {-# INLINE gregorianMonthLength #-} gregorianMonthLength :: Year -> Month -> Days gregorianMonthLength = monthLength . isLeapYear {-# INLINEABLE gregorianMonthsClip #-} gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay gregorianMonthsClip n (YearMonthDay y m d) = YearMonthDay y' m' $ min (gregorianMonthLength y' m') d where ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12 {-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-} {-# INLINEABLE gregorianMonthsRollover #-} gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of True -> YearMonthDay y' m' d False -> case m' < 12 of True -> YearMonthDay y' (m' + 1) (d - len) False -> YearMonthDay (y' + 1) 1 (d - len) where ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12 len = gregorianMonthLength y' m' {-# INLINEABLE gregorianYearsClip #-} gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay gregorianYearsClip n (YearMonthDay ((+) n -> y') 2 29) | not (isLeapYear y') = YearMonthDay y' 2 28 gregorianYearsClip n (YearMonthDay y m d) = YearMonthDay (y + n) m d {-# INLINEABLE gregorianYearsRollover #-} gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay gregorianYearsRollover n (YearMonthDay ((+) n -> y') 2 29) | not (isLeapYear y') = YearMonthDay y' 3 1 gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d -- * Lenses LENS(YearMonthDay,ymdYear,Year) LENS(YearMonthDay,ymdMonth,Month) LENS(YearMonthDay,ymdDay,DayOfMonth) thyme-0.3.5.5/src/Data/Thyme/Clock.hs0000644000000000000000000000342412435525530015322 0ustar0000000000000000-- | Types and functions for -- and -- . -- -- If you don't care about leap seconds, keep to 'UTCTime' and -- 'NominalDiffTime' for your clock calculations, and you'll be fine. -- -- 'Num', 'Real', 'Fractional' and 'RealFrac' instances for 'DiffTime' and -- 'NominalDiffTime' are only available by importing "Data.Thyme.Time". In -- their stead are instances of 'Data.AdditiveGroup.AdditiveGroup', -- 'Data.Basis.HasBasis' and 'Data.VectorSpace.VectorSpace', with -- @'Data.VectorSpace.Scalar' 'DiffTime' ≡ 'Data.VectorSpace.Scalar' -- 'NominalDiffTime' ≡ 'Rational'@. -- -- Using 'fromSeconds' and 'toSeconds' to convert between 'TimeDiff's and -- other numeric types. If you really must coerce between 'DiffTime' and -- 'NominalDiffTime', @'view' ('microseconds' . 'from' 'microseconds')@. -- -- 'UTCTime' is an instance of 'Data.AffineSpace.AffineSpace', with -- @'Data.AffineSpace.Diff' 'UTCTime' ≡ 'NominalDiffTime'@. -- -- 'UTCTime' is not Y294K-compliant. Please file a bug report on GitHub when -- this becomes a problem. module Data.Thyme.Clock ( -- * Universal Time UniversalTime , modJulianDate -- * Absolute intervals , DiffTime -- * UTC , UTCTime, UTCView (..) , utcTime , NominalDiffTime , module Data.Thyme.Clock -- * Time interval conversion , TimeDiff (..) , toSeconds, fromSeconds , toSeconds', fromSeconds' -- * Lenses , _utctDay, _utctDayTime ) where import Prelude import Control.Lens import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX -- | Get the current UTC time from the system clock. getCurrentTime :: IO UTCTime getCurrentTime = fmap (review posixTime) getPOSIXTime thyme-0.3.5.5/src/Data/Thyme/Format.hs0000644000000000000000000006757012435525530015533 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "thyme.h" module Data.Thyme.Format ( FormatTime (..) , formatTime , ParseTime (..) , parseTime , readTime , readsTime , TimeParse (..) , timeParser ) where import Prelude import Control.Applicative #if SHOW_INTERNAL import Control.Arrow #endif import Control.Lens import Control.Monad.Trans import Control.Monad.State.Strict import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Bits import qualified Data.ByteString.Char8 as S import Data.Char import Data.Int import Data.Thyme.Internal.Micro import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX import Data.Thyme.Clock.TAI import Data.Thyme.Format.Internal import Data.Thyme.LocalTime 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 showsY #-} showsY :: Year -> ShowS #if BUG_FOR_BUG showsY = shows #else -- ISO 8601 says minimum of 4 digits, even for first millennium. showsY = showsYear #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) 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' -> showsY y . (:) '-' . shows02 m . (:) '-' . shows02 d -- Year 'Y' -> showsY 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' -> showsY 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' -> showsY y 'g' -> shows02 (mod y 100) 'f' -> shows02 (div y 100) -- WeekOfYear 'V' -> shows02 w -- DayOfWeek 'u' -> shows $ if d == 0 then 7 else d 'w' -> shows $ if d == 7 then 0 else d 'A' -> (++) . fst $ wDays !! mod d 7 'a' -> (++) . snd $ wDays !! mod d 7 -- default _ -> def c instance FormatTime SundayWeek where {-# INLINEABLE showsTime #-} showsTime TimeLocale {..} (SundayWeek y w d) = \ def c -> case c of -- Year 'Y' -> showsY y 'y' -> shows02 (mod y 100) 'C' -> shows02 (div y 100) -- WeekOfYear 'U' -> shows02 w -- DayOfWeek 'u' -> shows $ if d == 0 then 7 else d 'w' -> shows $ if d == 7 then 0 else d 'A' -> (++) . fst $ wDays !! mod d 7 'a' -> (++) . snd $ wDays !! mod d 7 -- default _ -> def c instance FormatTime MondayWeek where {-# INLINEABLE showsTime #-} showsTime TimeLocale {..} (MondayWeek y w d) = \ def c -> case c of -- Year 'Y' -> showsY y 'y' -> shows02 (mod y 100) 'C' -> shows02 (div y 100) -- WeekOfYear 'W' -> shows02 w -- DayOfWeek 'u' -> shows $ if d == 0 then 7 else d 'w' -> shows $ if d == 7 then 0 else d 'A' -> (++) . fst $ wDays !! mod d 7 'a' -> (++) . snd $ wDays !! 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@(view ordinalDate -> ordinal) = showsTime l ordinal . showsTime l (ordinal ^. yearMonthDay) . showsTime l (toWeekOrdinal ordinal d) . showsTime l (toSundayOrdinal ordinal d) . showsTime l (toMondayOrdinal ordinal d) 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 ((utc, t) ^. zonedTime) def c where NominalDiffTime s = t ^. posixTime #if BUG_FOR_BUG qr = microDivMod -- rounds down #else qr = microQuotRem -- rounds to 0 #endif instance FormatTime UniversalTime where {-# INLINEABLE showsTime #-} showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "UT1"} where lt = t ^. ut1LocalTime 0 instance FormatTime AbsoluteTime where {-# INLINEABLE showsTime #-} showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "TAI"} where lt = t ^. from (absoluteTime $ const zeroV) . utcLocalTime utc ------------------------------------------------------------------------ data TimeFlag = PostMeridiem | TwelveHour | HasCentury | IsPOSIXTime | IsOrdinalDate | IsGregorian | IsWeekDate | IsSundayWeek | IsMondayWeek 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 :: !TimeZone } deriving (Show) LENS(TimeParse,tpCentury,Int) LENS(TimeParse,tpCenturyYear,Int{-YearOfCentury-}) LENS(TimeParse,tpMonth,Month) LENS(TimeParse,tpWeekOfYear,WeekOfYear) LENS(TimeParse,tpDayOfMonth,DayOfMonth) LENS(TimeParse,tpDayOfWeek,DayOfWeek) LENS(TimeParse,tpDayOfYear,DayOfYear) LENS(TimeParse,tpFlags,Int{-BitSet TimeFlag-}) LENS(TimeParse,tpHour,Hour) LENS(TimeParse,tpMinute,Minute) LENS(TimeParse,tpSecond,Int) LENS(TimeParse,tpSecFrac,DiffTime) LENS(TimeParse,tpPOSIXTime,POSIXTime) LENS(TimeParse,tpTimeZone,TimeZone) {-# INLINE flag #-} flag :: TimeFlag -> Lens' TimeParse Bool flag (fromEnum -> f) = _tpFlags . lens (`testBit` f) (\ n b -> (if b then setBit else clearBit) n f) -- | Time 'Parser' for UTF-8 encoded 'ByteString's. -- -- Attoparsec easily beats any 'String' parser out there, but we do have to -- be careful to convert the input to UTF-8 'ByteString's. {-# INLINEABLE timeParser #-} timeParser :: TimeLocale -> String -> Parser TimeParse timeParser TimeLocale {..} = flip execStateT unixEpoch . go 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) <|> (lift (dec_ 1) >>= setHour24) 'l' -> (lift (dec_ 2) >>= setHour12) <|> (lift (dec_ 1) >>= 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 'Y' -> fullYear 'y' -> lift (dec0 2) >>= setCenturyYear 'C' -> lift (dec0 2) >>= setCentury -- Month 'B' -> lift (indexOfCI $ fst <$> months) >>= setMonth . succ 'b' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ 'h' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ 'm' -> lift (dec0 2) >>= setMonth -- DayOfMonth 'd' -> lift (dec0 2) >>= setDayOfMonth 'e' -> (lift (dec_ 2) >>= setDayOfMonth) <|> (lift (dec_ 1) >>= setDayOfMonth) -- DayOfYear 'j' -> lift (dec0 3) >>= assign _tpDayOfYear >> flag IsOrdinalDate .= True >> go rspec -- Year (WeekDate) -- FIXME: problematic if input contains both %Y and %G 'G' -> flag IsWeekDate .= True >> fullYear 'g' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCenturyYear 'f' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCentury -- WeekOfYear -- FIXME: problematic if more than one of the following 'V' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setWeekOfYear 'U' -> flag IsSundayWeek .= True >> lift (dec0 2) >>= setWeekOfYear 'W' -> flag IsMondayWeek .= True >> lift (dec0 2) >>= setWeekOfYear -- DayOfWeek 'w' -> lift (dec0 1) >>= setDayOfWeek 'u' -> lift (dec0 1) >>= setDayOfWeek 'A' -> lift (indexOfCI $ fst <$> wDays) >>= setDayOfWeek 'a' -> lift (indexOfCI $ snd <$> wDays) >>= setDayOfWeek -- TimeZone 'z' -> do tzOffset; go rspec 'Z' -> do tzOffset <|> tzName; go rspec -- UTCTime 's' -> do s <- lift (negative P.decimal) _tpPOSIXTime .= fromSeconds (s :: Int64) flag IsPOSIXTime .= True 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 <$ stringCI (fst amPm) <|> True <$ stringCI (snd amPm) flag PostMeridiem .= pm flag TwelveHour .= True go rspec -- NOTE: if a greedy parse fails or causes a later failure, -- then backtrack and only accept 4-digit years; see #5. fullYear = year (negative P.decimal) <|> year (dec0 4) where year p = do (c, y) <- (`divMod` 100) <$> lift p flag HasCentury .= True _tpCentury .= c _tpCenturyYear .= y go rspec setHour12 h = do flag TwelveHour .= True _tpHour .= h go rspec setHour24 h = do flag TwelveHour .= False _tpHour .= h go rspec setCenturyYear y = do _tpCenturyYear .= y; go rspec setCentury c = do _tpCentury .= c flag HasCentury .= True go rspec setMonth m = do flag IsGregorian .= True _tpMonth .= m go rspec setDayOfMonth d = do flag IsGregorian .= True _tpDayOfMonth .= d go rspec setWeekOfYear w = do _tpWeekOfYear .= w; go rspec setDayOfWeek d = do _tpDayOfWeek .= d; go rspec tzOffset = do s <- lift (id <$ P.char '+' <|> negate <$ P.char '-') h <- lift (dec0 2) () <$ lift (P.char ':') <|> pure () m <- lift (dec0 2) _tpTimeZone . _timeZoneMinutes .= s (h * 60 + m) tzName = lift timeZoneParser >>= assign _tpTimeZone c : rspec | P.isSpace c -> lift (P.takeWhile P.isSpace) >> go (dropWhile P.isSpace rspec) c : rspec | isAscii c -> lift (P.char c) >> go rspec c : rspec -> lift (charU8 c) >> go rspec "" -> return () {-# INLINE micro #-} micro :: Parser Micro micro = do us10 <- either fail return . P.parseOnly P.decimal . S.take 7 . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit return $ Micro (div (us10 + 5) 10) {-# 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 parser . utf8String where parser = buildTime <$ P.skipSpace <*> timeParser l spec <* P.skipSpace <* P.endOfInput {-# INLINEABLE readTime #-} readTime :: (ParseTime t) => TimeLocale -> String -> String -> t readTime l spec = either error id . P.parseOnly parser . utf8String where parser = buildTime <$ P.skipSpace <*> timeParser l spec <* P.skipSpace <* P.endOfInput {-# INLINEABLE readsTime #-} readsTime :: (ParseTime t) => TimeLocale -> String -> ReadS t readsTime l spec = parserToReadS $ buildTime <$ P.skipSpace <*> timeParser l spec ------------------------------------------------------------------------ deriving instance Read UTCView #if SHOW_INTERNAL deriving instance Read Day deriving instance Read TimeOfDay deriving instance Read LocalTime deriving instance Read ZonedTime deriving instance Read TimeZone instance Read UTCTime where {-# INLINE readsPrec #-} readsPrec n = fmap (first $ review utcTime) . readsPrec n #else instance Read Day where {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d" instance Read TimeOfDay where {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ readsTime defaultTimeLocale "%H:%M:%S%Q" instance Read LocalTime where {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q" instance Read ZonedTime where {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z" instance Read UTCTime where {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z" #endif ------------------------------------------------------------------------ class ParseTime t where buildTime :: TimeParse -> t instance ParseTime TimeOfDay where {-# INLINE buildTime #-} buildTime tp@TimeParse {..} = TimeOfDay h tpMinute (fromSeconds tpSecond ^+^ tpSecFrac) where h = case tp ^. flag TwelveHour of False -> tpHour True -> case tp ^. flag PostMeridiem of False -> mod tpHour 12 True -> if 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 < 69 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 (if tpDayOfWeek == 0 then 7 else tpDayOfWeek) instance ParseTime SundayWeek where {-# INLINE buildTime #-} buildTime tp@TimeParse {..} = SundayWeek (tpYear tp) tpWeekOfYear (if tpDayOfWeek == 7 then 0 else tpDayOfWeek) instance ParseTime MondayWeek where {-# INLINE buildTime #-} buildTime tp@TimeParse {..} = MondayWeek (tpYear tp) tpWeekOfYear (if tpDayOfWeek == 0 then 7 else tpDayOfWeek) instance ParseTime LocalTime where {-# INLINE buildTime #-} buildTime = LocalTime <$> buildTime <*> buildTime instance ParseTime Day where {-# INLINE buildTime #-} buildTime tp@TimeParse {..} | tp ^. flag IsOrdinalDate = ordinalDate # buildTime tp | tp ^. flag IsGregorian = gregorian # buildTime tp | tp ^. flag IsWeekDate = weekDate # buildTime tp | tp ^. flag IsSundayWeek = sundayWeek # buildTime tp | tp ^. flag IsMondayWeek = mondayWeek # buildTime tp | otherwise = ordinalDate # buildTime tp -- TODO: Better conflict handling when multiple flags are set? 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 posixTime # tpPOSIXTime else snd $ buildTime tp ^. from zonedTime instance ParseTime UniversalTime where {-# INLINE buildTime #-} buildTime (buildTime -> UTCRep t) = UniversalRep t instance ParseTime AbsoluteTime where {-# INLINE buildTime #-} buildTime tp = buildTime tp ^. absoluteTime (const zeroV) ------------------------------------------------------------------------ -- Dubiously pilfered from time-1.4.0.2 -- s/^.*-- \(.*\)\n.*\("[A-Z]\+"\).*"\([+-]\)\([0-9]\{2\}\):\([0-9]\{2\}\)", \(True\|False\).*$/ <|> zone \2 (($\3) \4 \5) \6 -- \1/ -- followed by !sort -r , because some names are prefixes of others. timeZoneParser :: Parser TimeZone timeZoneParser = zone "TAI" 0 False <|> zone "UT1" 0 False <|> zone "ZULU" (($+) 00 00) False -- Same as UTC <|> zone "Z" (($+) 00 00) False -- Same as UTC <|> zone "YST" (($-) 09 00) False -- Yukon Standard Time <|> zone "YDT" (($-) 08 00) True -- Yukon Daylight-Saving Time <|> zone "WST" (($+) 08 00) False -- West Australian Standard Time <|> zone "WETDST" (($+) 01 00) True -- Western European Daylight-Saving Time <|> zone "WET" (($+) 00 00) False -- Western European Time <|> zone "WDT" (($+) 09 00) True -- West Australian Daylight-Saving Time <|> zone "WAT" (($-) 01 00) False -- West Africa Time <|> zone "WAST" (($+) 07 00) False -- West Australian Standard Time <|> zone "WADT" (($+) 08 00) True -- West Australian Daylight-Saving Time <|> zone "UTC" (($+) 00 00) False -- Universal Coordinated Time <|> zone "UT" (($+) 00 00) False -- Universal Time <|> zone "TFT" (($+) 05 00) False -- Kerguelen Time <|> zone "SWT" (($+) 01 00) False -- Swedish Winter Time <|> zone "SST" (($+) 02 00) False -- Swedish Summer Time <|> zone "SET" (($+) 01 00) False -- Seychelles Time <|> zone "SCT" (($+) 04 00) False -- Mahe Island Time <|> zone "SAST" (($+) 09 30) False -- South Australia Standard Time <|> zone "SADT" (($+) 10 30) True -- South Australian Daylight-Saving Time <|> zone "RET" (($+) 04 00) False -- Reunion Island Time <|> zone "PST" (($-) 08 00) False -- Pacific Standard Time <|> zone "PDT" (($-) 07 00) True -- Pacific Daylight-Saving Time <|> zone "NZT" (($+) 12 00) False -- New Zealand Time <|> zone "NZST" (($+) 12 00) False -- New Zealand Standard Time <|> zone "NZDT" (($+) 13 00) True -- New Zealand Daylight-Saving Time <|> zone "NT" (($-) 11 00) False -- Nome Time <|> zone "NST" (($-) 03 30) False -- Newfoundland Standard Time <|> zone "NOR" (($+) 01 00) False -- Norway Standard Time <|> zone "NFT" (($-) 03 30) False -- Newfoundland Standard Time <|> zone "NDT" (($-) 02 30) True -- Newfoundland Daylight-Saving Time <|> zone "MVT" (($+) 05 00) False -- Maldives Island Time <|> zone "MUT" (($+) 04 00) False -- Mauritius Island Time <|> zone "MT" (($+) 08 30) False -- Moluccas Time <|> zone "MST" (($-) 07 00) False -- Mountain Standard Time <|> zone "MMT" (($+) 06 30) False -- Myanmar Time <|> zone "MHT" (($+) 09 00) False -- Kwajalein Time <|> zone "MEZ" (($+) 01 00) False -- Mitteleuropaeische Zeit <|> zone "MEWT" (($+) 01 00) False -- Middle European Winter Time <|> zone "METDST" (($+) 02 00) True -- Middle Europe Daylight-Saving Time <|> zone "MET" (($+) 01 00) False -- Middle European Time <|> zone "MEST" (($+) 02 00) False -- Middle European Summer Time <|> zone "MDT" (($-) 06 00) True -- Mountain Daylight-Saving Time <|> zone "MAWT" (($+) 06 00) False -- Mawson (Antarctica) Time <|> zone "MART" (($-) 09 30) False -- Marquesas Time <|> zone "LIGT" (($+) 10 00) False -- Melbourne, Australia <|> zone "KST" (($+) 09 00) False -- Korea Standard Time <|> zone "JT" (($+) 07 30) False -- Java Time <|> zone "JST" (($+) 09 00) False -- Japan Standard Time, Russia zone 8 <|> zone "IT" (($+) 03 30) False -- Iran Time <|> zone "IST" (($+) 02 00) False -- Israel Standard Time <|> zone "IRT" (($+) 03 30) False -- Iran Time <|> zone "IOT" (($+) 05 00) False -- Indian Chagos Time <|> zone "IDLW" (($-) 12 00) False -- International Date Line, West <|> zone "IDLE" (($+) 12 00) False -- International Date Line, East <|> zone "HST" (($-) 10 00) False -- Hawaii Standard Time <|> zone "HMT" (($+) 03 00) False -- Hellas Mediterranean Time (?) <|> zone "HDT" (($-) 09 00) True -- Hawaii/Alaska Daylight-Saving Time <|> zone "GST" (($+) 10 00) False -- Guam Standard Time, Russia zone 9 <|> zone "GMT" (($+) 00 00) False -- Greenwich Mean Time <|> zone "FWT" (($+) 02 00) False -- French Winter Time <|> zone "FST" (($+) 01 00) False -- French Summer Time <|> zone "FNT" (($-) 02 00) False -- Fernando de Noronha Time <|> zone "FNST" (($-) 01 00) False -- Fernando de Noronha Summer Time <|> zone "EST" (($-) 05 00) False -- Eastern Standard Time <|> zone "EETDST" (($+) 03 00) True -- Eastern Europe Daylight-Saving Time <|> zone "EET" (($+) 02 00) False -- Eastern European Time, Russia zone 1 <|> zone "EDT" (($-) 04 00) True -- Eastern Daylight-Saving Time <|> zone "EAT" (($+) 03 00) False -- Antananarivo, Comoro Time <|> zone "EAST" (($+) 10 00) False -- East Australian Standard Time <|> zone "EAST" (($+) 04 00) False -- Antananarivo Summer Time <|> zone "DNT" (($+) 01 00) False -- Dansk Normal Tid <|> zone "CXT" (($+) 07 00) False -- Christmas (Island) Time <|> zone "CST" (($-) 06 00) False -- Central Standard Time <|> zone "CETDST" (($+) 02 00) True -- Central European Daylight-Saving Time <|> zone "CET" (($+) 01 00) False -- Central European Time <|> zone "CEST" (($+) 02 00) False -- Central European Summer Time <|> zone "CDT" (($-) 05 00) True -- Central Daylight-Saving Time <|> zone "CCT" (($+) 08 00) False -- China Coastal Time <|> zone "CAT" (($-) 10 00) False -- Central Alaska Time <|> zone "CAST" (($+) 09 30) False -- Central Australia Standard Time <|> zone "CADT" (($+) 10 30) True -- Central Australia Daylight-Saving Time <|> zone "BT" (($+) 03 00) False -- Baghdad Time <|> zone "BST" (($+) 01 00) False -- British Summer Time <|> zone "BRT" (($-) 03 00) False -- Brasilia Time <|> zone "BRST" (($-) 02 00) False -- Brasilia Summer Time <|> zone "BDST" (($+) 02 00) False -- British Double Summer Time <|> zone "AWT" (($-) 03 00) False -- (unknown) <|> zone "AWST" (($+) 08 00) False -- Australia Western Standard Time <|> zone "AWSST" (($+) 09 00) False -- Australia Western Summer Standard Time <|> zone "AST" (($-) 04 00) False -- Atlantic Standard Time (Canada) <|> zone "ALMT" (($+) 06 00) False -- Almaty Time <|> zone "ALMST" (($+) 07 00) False -- Almaty Summer Time <|> zone "AKST" (($-) 09 00) False -- Alaska Standard Time <|> zone "AKDT" (($-) 08 00) True -- Alaska Daylight-Saving Time <|> zone "AHST" (($-) 10 00) False -- Alaska/Hawaii Standard Time <|> zone "AFT" (($+) 04 30) False -- Afghanistan Time <|> zone "AEST" (($+) 10 00) False -- Australia Eastern Standard Time <|> zone "AESST" (($+) 11 00) False -- Australia Eastern Summer Standard Time <|> zone "ADT" (($-) 03 00) True -- Atlantic Daylight-Saving Time <|> zone "ACT" (($-) 05 00) False -- Atlantic/Porto Acre Standard Time <|> zone "ACST" (($-) 04 00) False -- Atlantic/Porto Acre Summer Time <|> zone "ACSST" (($+) 10 30) False -- Central Australia Summer Standard Time where zone name offset dst = TimeZone offset dst name <$ P.string (S.pack name) ($+) h m = h * 60 + m ($-) h m = negate (h * 60 + m) thyme-0.3.5.5/src/Data/Thyme/LocalTime.hs0000644000000000000000000003053212435525530016140 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "thyme.h" module Data.Thyme.LocalTime where import Prelude hiding ((.)) import Control.Applicative import Control.Arrow import Control.Category hiding (id) import Control.DeepSeq import Control.Lens import Control.Monad import Data.AffineSpace import Data.Bits import Data.Data import Data.Int import Data.Thyme.Internal.Micro import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal import Data.Thyme.Clock import Data.Thyme.Clock.Internal import Data.Thyme.Format.Internal import qualified Data.Time as T #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Random import Test.QuickCheck hiding ((.&.)) type Minutes = Int type Hours = Int ------------------------------------------------------------------------ -- * Time zones data TimeZone = TimeZone { timeZoneMinutes :: {-# UNPACK #-}!Minutes , timeZoneSummerOnly :: !Bool , timeZoneName :: String } deriving (INSTANCES_USUAL) instance NFData TimeZone #if SHOW_INTERNAL deriving instance Show TimeZone #else instance Show TimeZone where show tz@TimeZone {..} = if null timeZoneName then timeZoneOffsetString tz else timeZoneName #endif instance Bounded TimeZone where minBound = TimeZone (-12 * 60) minBound "AAAA" maxBound = TimeZone (13 * 60) maxBound "ZZZZ" instance Random TimeZone where randomR (l, u) g0 = (TimeZone minutes summer name, g3) where (minutes, g1) = randomR (timeZoneMinutes l, timeZoneMinutes u) g0 (summer, g2) = randomR (timeZoneSummerOnly l, timeZoneSummerOnly u) g1 -- slightly dubious interpretation of ‘range’ (name, g3) = foldr randChar ([], g2) . take 4 $ zip (timeZoneName l ++ "AAAA") (timeZoneName u ++ "ZZZZ") randChar nR (ns, g) = (: ns) `first` randomR nR g random = randomR (minBound, maxBound) instance Arbitrary TimeZone where arbitrary = choose (minBound, maxBound) shrink tz@TimeZone {..} = [ tz {timeZoneSummerOnly = s} | s <- shrink timeZoneSummerOnly ] ++ [ tz {timeZoneMinutes = m} | m <- shrink timeZoneMinutes ] ++ [ tz {timeZoneName = n} | n <- shrink timeZoneName ] instance CoArbitrary TimeZone where coarbitrary (TimeZone m s n) = coarbitrary m . coarbitrary s . coarbitrary n -- | Text representing the offset of this timezone, e.g. \"-0800\" or -- \"+0400\" (like %z in 'formatTime') {-# INLINEABLE timeZoneOffsetString #-} timeZoneOffsetString :: TimeZone -> String timeZoneOffsetString TimeZone {..} = sign : (shows02 h . shows02 m) "" where (h, m) = divMod offset 60 (sign, offset) = if timeZoneMinutes < 0 then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes) -- | Create a nameless non-summer timezone for this number of minutes minutesToTimeZone :: Minutes -> TimeZone minutesToTimeZone m = TimeZone m False "" -- | Create a nameless non-summer timezone for this number of hours hoursToTimeZone :: Hours -> TimeZone hoursToTimeZone i = minutesToTimeZone (60 * i) utc :: TimeZone utc = TimeZone 0 False "UTC" {-# INLINEABLE getTimeZone #-} getTimeZone :: UTCTime -> IO TimeZone getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where day = T.ModifiedJulianDay (toInteger mjd) UTCTime (ModifiedJulianDay mjd) dt = t ^. utcTime thyme T.TimeZone {..} = TimeZone {..} {-# INLINE getCurrentTimeZone #-} getCurrentTimeZone :: IO TimeZone getCurrentTimeZone = getCurrentTime >>= getTimeZone ------------------------------------------------------------------------ -- * Time of day type Hour = Int type Minute = Int data TimeOfDay = TimeOfDay { todHour :: {-# UNPACK #-}!Hour , todMin :: {-# UNPACK #-}!Minute , todSec :: {-# UNPACK #-}!DiffTime } deriving (INSTANCES_USUAL) derivingUnbox "TimeOfDay" [t| TimeOfDay -> Int64 |] [| \ TimeOfDay {..} -> fromIntegral (todHour .|. shiftL todMin 8) .|. shiftL (todSec ^. microseconds) 16 |] [| \ n -> TimeOfDay (fromIntegral $ n .&. 0xff) (fromIntegral $ shiftR n 8 .&. 0xff) (microseconds # shiftR n 16) |] instance NFData TimeOfDay #if SHOW_INTERNAL deriving instance Show TimeOfDay #else instance Show TimeOfDay where showsPrec _ (TimeOfDay h m (DiffTime s)) = shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 (fromIntegral si) . frac where (si, Micro su) = microQuotRem s (Micro 1000000) frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su #endif instance Bounded TimeOfDay where minBound = TimeOfDay 0 0 zeroV maxBound = TimeOfDay 23 59 (microseconds # 60999999) instance Random TimeOfDay where randomR = randomIsoR timeOfDay random = first (^. timeOfDay) . random instance Arbitrary TimeOfDay where arbitrary = do h <- choose (0, 23) m <- choose (0, 59) let DiffTime ml = minuteLength h m TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml) shrink tod = view timeOfDay . (^+^) noon <$> shrink (timeOfDay # tod ^-^ noon) where noon = timeOfDay # midday -- shrink towards midday instance CoArbitrary TimeOfDay where coarbitrary (TimeOfDay h m s) = coarbitrary h . coarbitrary m . coarbitrary s {-# INLINE minuteLength #-} minuteLength :: Hour -> Minute -> DiffTime minuteLength h m = fromSeconds' $ if h == 23 && m == 59 then 61 else 60 -- | Hour zero midnight :: TimeOfDay midnight = TimeOfDay 0 0 zeroV -- | Hour twelve midday :: TimeOfDay midday = TimeOfDay 12 0 zeroV {-# 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) <* guard (zeroV <= s && s < minuteLength h m) {-# INLINE timeOfDay #-} timeOfDay :: 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 (Micro 3600000000) (m, s) = microQuotRem ms (Micro 60000000) {-# INLINEABLE toDiff #-} toDiff :: TimeOfDay -> DiffTime toDiff (TimeOfDay h m s) = s ^+^ fromIntegral m *^ DiffTime (Micro 60000000) ^+^ fromIntegral h *^ DiffTime (Micro 3600000000) -- | 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 dayFraction #-} dayFraction :: Iso' TimeOfDay Rational dayFraction = from timeOfDay . iso toRatio fromRatio where {-# INLINEABLE toRatio #-} toRatio :: DiffTime -> Rational toRatio t = toSeconds t / toSeconds posixDayLength {-# INLINEABLE fromRatio #-} fromRatio :: Rational -> DiffTime fromRatio ((*^ posixDayLength) -> NominalDiffTime r) = DiffTime r ------------------------------------------------------------------------ -- * Local Time data LocalTime = LocalTime { localDay :: {-# UNPACK #-}!Day , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay } deriving (INSTANCES_USUAL) derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |] [| \ LocalTime {..} -> (localDay, localTimeOfDay) |] [| \ (localDay, localTimeOfDay) -> LocalTime {..} |] instance NFData LocalTime #if SHOW_INTERNAL deriving instance Show LocalTime #else instance Show LocalTime where showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t #endif instance Bounded LocalTime where minBound = minBound ^. utcLocalTime maxBound maxBound = maxBound ^. utcLocalTime minBound instance Random LocalTime where randomR = randomIsoR (utcLocalTime utc) random = randomR (minBound, maxBound) instance Arbitrary LocalTime where arbitrary = choose (minBound, maxBound) shrink lt@LocalTime {..} = [ lt {localDay = d} | d <- shrink localDay ] ++ [ lt {localTimeOfDay = d} | d <- shrink localTimeOfDay ] instance CoArbitrary LocalTime where coarbitrary (LocalTime d t) = coarbitrary d . coarbitrary t {-# INLINE utcLocalTime #-} utcLocalTime :: TimeZone -> 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 (dt ^. timeOfDay) {-# INLINEABLE globalise #-} globalise :: LocalTime -> UTCView globalise (LocalTime day tod) = UTCTime (day .+^ dd) (timeOfDay # utcToD) where (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod {-# INLINE ut1LocalTime #-} ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime ut1LocalTime long = iso localise globalise where NominalDiffTime posixDay@(Micro usDay) = posixDayLength {-# INLINEABLE localise #-} localise :: UniversalTime -> LocalTime localise (UniversalRep (NominalDiffTime t)) = LocalTime (ModifiedJulianDay $ fromIntegral day) (DiffTime dt ^. timeOfDay) where (day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay {-# INLINEABLE globalise #-} globalise :: LocalTime -> UniversalTime globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $ Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where ModifiedJulianDay (fromIntegral -> mjd) = day DiffTime dt = timeOfDay # tod ------------------------------------------------------------------------ -- * Zoned Time data ZonedTime = ZonedTime { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime , zonedTimeZone :: !TimeZone } deriving (INSTANCES_USUAL) instance NFData ZonedTime where rnf ZonedTime {..} = rnf zonedTimeZone instance Bounded ZonedTime where minBound = ZonedTime minBound maxBound maxBound = ZonedTime maxBound minBound instance Random ZonedTime where randomR (l, u) g0 = (view zonedTime . (,) tz) `first` randomR (l', u') g1 where (tz, g1) = random g0 -- ignore TimeZone from l and u l' = snd $ zonedTime # l u' = snd $ zonedTime # u random = randomR (minBound, maxBound) instance Arbitrary ZonedTime where arbitrary = choose (minBound, maxBound) shrink zt@ZonedTime {..} = [ zt {zonedTimeToLocalTime = lt} | lt <- shrink zonedTimeToLocalTime ] ++ [ zt {zonedTimeZone = tz} | tz <- shrink zonedTimeZone ] instance CoArbitrary ZonedTime where coarbitrary (ZonedTime lt tz) = coarbitrary lt . coarbitrary tz {-# INLINE zonedTime #-} zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime zonedTime = iso toZoned fromZoned where {-# INLINE toZoned #-} toZoned :: (TimeZone, UTCTime) -> ZonedTime toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz {-# INLINE fromZoned #-} fromZoned :: ZonedTime -> (TimeZone, UTCTime) fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt) #if SHOW_INTERNAL deriving instance Show ZonedTime instance Show UTCTime where showsPrec p = showsPrec p . view utcTime #else instance Show ZonedTime where showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz instance Show UTCTime where showsPrec p = showsPrec p . view zonedTime . (,) utc #endif {-# INLINE getZonedTime #-} getZonedTime :: IO ZonedTime getZonedTime = utcToLocalZonedTime =<< getCurrentTime {-# INLINEABLE utcToLocalZonedTime #-} utcToLocalZonedTime :: UTCTime -> IO ZonedTime utcToLocalZonedTime time = do tz <- getTimeZone time return $ (tz, time) ^. zonedTime -- * Lenses LENS(TimeZone,timeZoneMinutes,Minutes) LENS(TimeZone,timeZoneSummerOnly,Bool) LENS(TimeZone,timeZoneName,String) LENS(TimeOfDay,todHour,Hour) LENS(TimeOfDay,todMin,Minute) LENS(TimeOfDay,todSec,DiffTime) LENS(LocalTime,localDay,Day) LENS(LocalTime,localTimeOfDay,TimeOfDay) LENS(ZonedTime,zonedTimeToLocalTime,LocalTime) LENS(ZonedTime,zonedTimeZone,TimeZone) thyme-0.3.5.5/src/Data/Thyme/Time.hs0000644000000000000000000000677312435525530015177 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module provides compatibility instances and wrappers for the -- things that @thyme@ does differently from @time@, and allows it to be -- used as a drop-in replacement for the latter, with the exceptions noted -- below: -- -- * When constructing an 'UTCTime' or 'UniversalTime', use 'mkUTCTime' or -- 'mkModJulianDate' in place of @UTCTime@ or @ModJulianDate@. -- -- * Instead of pattern matching on @UTCTime@, use 'unUTCTime' to get -- a 'UTCView', which has a constructor @UTCTime@ with the same fields. -- For @ModJulianDate@, use 'getModJulianDate'. @ViewPatterns@ may make -- the transition more seamless. -- -- * Where a third party library uses @time@, you can use 'toThyme' and -- 'fromThyme' to convert between the corresponding types. -- -- * 'Year's are 'Int's, not 'Integer's: you may need 'fromIntegral'. -- -- You shouldn't need to use @lens@ or @vector-space@ directly if you don't -- want to. However if you do use @vector-space@ and wish to avoid the -- 'RealFrac' instances for 'DiffTime' and 'NominalDiffTime', import -- "Data.Thyme.Time.Core" instead. -- -- Anything else is probably not intentional, and you should either contact -- me via IRC or file an issue at . module Data.Thyme.Time ( module Data.Thyme.Time.Core {- instance RealFrac {,Nominal}DiffTime -} ) where import Prelude import Data.Thyme.Internal.Micro import Data.Ratio import Data.Thyme import Data.Thyme.Clock.Internal import Data.Thyme.Time.Core 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 `quot` 1000)) recip (Micro a) = Micro (quot 1000000 a) fromRational r = Micro (round $ r * 1000000) instance RealFrac Micro where {-# INLINE properFraction #-} properFraction a = (fromIntegral q, r) where (q, r) = microQuotRem a (Micro 1000000) deriving instance Num DiffTime deriving instance Real DiffTime deriving instance Fractional DiffTime deriving instance RealFrac DiffTime deriving instance Num NominalDiffTime deriving instance Real NominalDiffTime deriving instance Fractional NominalDiffTime deriving instance RealFrac NominalDiffTime {-# RULES "realToFrac/DiffTime-NominalDiffTime" realToFrac = \ (DiffTime d) -> NominalDiffTime d "realToFrac/NominalDiffTime-DiffTime" realToFrac = \ (NominalDiffTime d) -> DiffTime d "realToFrac/DiffTime-Fractional" realToFrac = toSeconds :: (Fractional n) => DiffTime -> n "realToFrac/NominalDiffTime-Fractional" realToFrac = toSeconds :: (Fractional n) => NominalDiffTime -> n "realToFrac/Real-DiffTime" realToFrac = fromSeconds :: (Real n) => n -> DiffTime "realToFrac/Real-NominalDiffTime" realToFrac = fromSeconds :: (Real n) => n -> NominalDiffTime #-} thyme-0.3.5.5/src/Data/Thyme/Calendar/0000755000000000000000000000000012435525530015441 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme/Calendar/MonthDay.hs0000644000000000000000000000064312435525530017523 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} #include "thyme.h" -- | Julian or Gregorian. module Data.Thyme.Calendar.MonthDay ( Month, DayOfMonth, MonthDay (..) , monthDay, monthDayValid, monthLength , module Data.Thyme.Calendar.MonthDay ) where import Prelude import Control.Lens import Data.Thyme.Calendar.Internal -- * Lenses LENS(MonthDay,mdMonth,Month) LENS(MonthDay,mdDay,DayOfMonth) thyme-0.3.5.5/src/Data/Thyme/Calendar/OrdinalDate.hs0000644000000000000000000000240612435525530020165 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "thyme.h" -- | 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.Arrow import Control.Lens import Control.Monad import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal import System.Random import Test.QuickCheck instance Bounded OrdinalDate where minBound = minBound ^. ordinalDate maxBound = maxBound ^. ordinalDate instance Random OrdinalDate where randomR = randomIsoR ordinalDate random = first (^. ordinalDate) . random instance Arbitrary OrdinalDate where arbitrary = view ordinalDate <$> arbitrary shrink od = view ordinalDate <$> shrink (ordinalDate # od) instance CoArbitrary OrdinalDate where coarbitrary (OrdinalDate y d) = coarbitrary y . coarbitrary d {-# INLINE ordinalDateValid #-} ordinalDateValid :: OrdinalDate -> Maybe Day ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365) -- * Lenses LENS(OrdinalDate,odYear,Year) LENS(OrdinalDate,odDay,DayOfYear) thyme-0.3.5.5/src/Data/Thyme/Calendar/WeekDate.hs0000644000000000000000000000506512435525530017474 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ == 706 {-# OPTIONS_GHC -fsimpl-tick-factor=120 #-} -- 7.6.3 only, it seems; fixes #29 #endif #include "thyme.h" -- | Various Week Date formats module Data.Thyme.Calendar.WeekDate ( Year, WeekOfYear, DayOfWeek -- * ISO 8601 Week Date , WeekDate (..), weekDate, weekDateValid, showWeekDate -- * Weeks starting Sunday , SundayWeek (..), sundayWeek, sundayWeekValid -- * Weeks starting Monday , MondayWeek (..), mondayWeek, mondayWeekValid , module Data.Thyme.Calendar.WeekDate ) where import Prelude import Control.Applicative import Control.Arrow import Control.Lens import Data.Thyme.Calendar.OrdinalDate import Data.Thyme.Calendar.Internal import System.Random import Test.QuickCheck instance Bounded WeekDate where minBound = minBound ^. weekDate maxBound = maxBound ^. weekDate instance Bounded SundayWeek where minBound = minBound ^. sundayWeek maxBound = maxBound ^. sundayWeek instance Bounded MondayWeek where minBound = minBound ^. mondayWeek maxBound = maxBound ^. mondayWeek instance Random WeekDate where randomR = randomIsoR weekDate random = first (^. weekDate) . random instance Random SundayWeek where randomR = randomIsoR sundayWeek random = first (^. sundayWeek) . random instance Random MondayWeek where randomR = randomIsoR mondayWeek random = first (^. mondayWeek) . random instance Arbitrary WeekDate where arbitrary = view weekDate <$> arbitrary shrink wd = view weekDate <$> shrink (weekDate # wd) instance Arbitrary SundayWeek where arbitrary = view sundayWeek <$> arbitrary shrink sw = view sundayWeek <$> shrink (sundayWeek # sw) instance Arbitrary MondayWeek where arbitrary = view mondayWeek <$> arbitrary shrink mw = view mondayWeek <$> shrink (mondayWeek # mw) instance CoArbitrary WeekDate where coarbitrary (WeekDate y w d) = coarbitrary y . coarbitrary w . coarbitrary d instance CoArbitrary SundayWeek where coarbitrary (SundayWeek y w d) = coarbitrary y . coarbitrary w . coarbitrary d instance CoArbitrary MondayWeek where coarbitrary (MondayWeek y w d) = coarbitrary y . coarbitrary w . coarbitrary d -- * Lenses LENS(WeekDate,wdYear,Year) LENS(WeekDate,wdWeek,WeekOfYear) LENS(WeekDate,wdDay,DayOfWeek) LENS(SundayWeek,swYear,Year) LENS(SundayWeek,swWeek,WeekOfYear) LENS(SundayWeek,swDay,DayOfWeek) LENS(MondayWeek,mwYear,Year) LENS(MondayWeek,mwWeek,WeekOfYear) LENS(MondayWeek,mwDay,DayOfWeek) thyme-0.3.5.5/src/Data/Thyme/Calendar/WeekdayOfMonth.hs0000644000000000000000000000706112435525530020665 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} #include "thyme.h" module Data.Thyme.Calendar.WeekdayOfMonth ( Year, Month, DayOfWeek , module Data.Thyme.Calendar.WeekdayOfMonth ) where import Prelude import Control.Applicative import Control.Arrow import Control.DeepSeq import Control.Lens import Control.Monad import Data.AffineSpace import Data.Bits import Data.Data import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import System.Random import Test.QuickCheck hiding ((.&.)) data WeekdayOfMonth = WeekdayOfMonth { womYear :: {-# UNPACK #-}!Year , womMonth :: {-# UNPACK #-}!Month , womNth :: {-# UNPACK #-}!Int -- ^ ±1–5, negative means n-th last , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek } deriving (INSTANCES_USUAL, Show) derivingUnbox "WeekdayOfMonth" [t| WeekdayOfMonth -> Int |] [| \ WeekdayOfMonth {..} -> shiftL womYear 11 .|. shiftL womMonth 7 .|. shiftL (womNth + 5) 3 .|. womDayOfWeek |] [| \ n -> WeekdayOfMonth (shiftR n 11) (shiftR n 7 .&. 0xf) (shiftR n 3 - 5) (n .&. 0x7) |] instance NFData WeekdayOfMonth instance Bounded WeekdayOfMonth where minBound = minBound ^. weekdayOfMonth maxBound = maxBound ^. weekdayOfMonth instance Random WeekdayOfMonth where randomR = randomIsoR weekdayOfMonth random = first (^. weekdayOfMonth) . random instance Arbitrary WeekdayOfMonth where arbitrary = view weekdayOfMonth <$> arbitrary shrink wom = view weekdayOfMonth <$> shrink (weekdayOfMonth # wom) instance CoArbitrary WeekdayOfMonth where coarbitrary (WeekdayOfMonth y m n d) = coarbitrary y . coarbitrary m . coarbitrary n . coarbitrary d {-# INLINE weekdayOfMonth #-} weekdayOfMonth :: Iso' Day WeekdayOfMonth weekdayOfMonth = iso toWeekday fromWeekday where {-# INLINEABLE toWeekday #-} toWeekday :: Day -> WeekdayOfMonth toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where YearMonthDay y m d = ord ^. yearMonthDay WeekDate _ _ wd = toWeekOrdinal ord day n = 1 + div (d - 1) 7 {-# INLINEABLE fromWeekday #-} fromWeekday :: WeekdayOfMonth -> Day fromWeekday (WeekdayOfMonth y m n wd) = refDay .+^ s * offset where refOrd = yearMonthDay # YearMonthDay y m (if n < 0 then monthLength (isLeapYear y) m else 1) refDay = ordinalDate # refOrd WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay s = signum n wo = s * (wd - wd1) offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo {-# INLINEABLE weekdayOfMonthValid #-} weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day weekdayOfMonthValid (WeekdayOfMonth y m n wd) = (refDay .+^ s * offset) <$ guard (n /= 0 && 1 <= wd && wd <= 7 && offset < len) where len = monthLength (isLeapYear y) m refOrd = yearMonthDay # YearMonthDay y m (if n < 0 then len else 1) refDay = ordinalDate # refOrd WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay s = signum n wo = s * (wd - wd1) offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo -- * Lenses LENS(WeekdayOfMonth,womYear,Year) LENS(WeekdayOfMonth,womMonth,Month) LENS(WeekdayOfMonth,womNth,Int) LENS(WeekdayOfMonth,womDayOfWeek,DayOfWeek) thyme-0.3.5.5/src/Data/Thyme/Calendar/Internal.hs0000644000000000000000000004231212435525530017553 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} #if SHOW_INTERNAL {-# LANGUAGE StandaloneDeriving #-} #endif {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} #include "thyme.h" module Data.Thyme.Calendar.Internal where import Prelude import Control.Applicative import Control.Arrow import Control.DeepSeq import Control.Lens import Control.Monad import Data.AffineSpace import Data.Bits import Data.Data import Data.Int import Data.Ix import Data.Thyme.Format.Internal #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import qualified Data.Vector.Unboxed as VU import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import System.Random import Test.QuickCheck hiding ((.&.)) type Years = Int type Months = Int type Days = Int -- | The Modified Julian Day is a standard count of days, with zero being -- the day 1858-11-17. newtype Day = ModifiedJulianDay { toModifiedJulianDay :: Int } deriving (INSTANCES_NEWTYPE, CoArbitrary) instance AffineSpace Day where type Diff Day = Days {-# INLINE (.-.) #-} (.-.) = \ (ModifiedJulianDay a) (ModifiedJulianDay b) -> a - b {-# INLINE (.+^) #-} (.+^) = \ (ModifiedJulianDay a) d -> ModifiedJulianDay (a + d) {-# INLINE modifiedJulianDay #-} modifiedJulianDay :: Iso' Day Int modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay {-# INLINE yearMonthDay #-} yearMonthDay :: 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 = yd ^. monthDay (isLeapYear y) {-# INLINEABLE toOrdinal #-} toOrdinal :: YearMonthDay -> OrdinalDate toOrdinal (YearMonthDay y m d) = OrdinalDate y $ monthDay (isLeapYear y) # MonthDay m d {-# INLINE gregorian #-} gregorian :: Iso' Day YearMonthDay gregorian = ordinalDate . yearMonthDay {-# INLINEABLE gregorianValid #-} gregorianValid :: YearMonthDay -> Maybe Day gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y <$> monthDayValid (isLeapYear y) (MonthDay m d) {-# INLINEABLE showGregorian #-} showGregorian :: Day -> String showGregorian (view gregorian -> YearMonthDay y m d) = showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ "" #if SHOW_INTERNAL deriving instance Show Day #else instance Show Day where show = showGregorian #endif ------------------------------------------------------------------------ type Year = Int type Month = Int type DayOfMonth = Int data YearMonthDay = YearMonthDay { ymdYear :: {-# UNPACK #-}!Year , ymdMonth :: {-# UNPACK #-}!Month , ymdDay :: {-# UNPACK #-}!DayOfMonth } deriving (INSTANCES_USUAL, Show) instance NFData YearMonthDay ------------------------------------------------------------------------ -- | Gregorian leap year? isLeapYear :: Year -> Bool isLeapYear y = y .&. 3 == 0 && (r100 /= 0 || q100 .&. 3 == 0) where (q100, r100) = y `quotRem` 100 type DayOfYear = Int data OrdinalDate = OrdinalDate { odYear :: {-# UNPACK #-}!Year , odDay :: {-# UNPACK #-}!DayOfYear } deriving (INSTANCES_USUAL, Show) instance NFData OrdinalDate -- Brief description of the toOrdinal computation. -- -- The length of the years in Gregorian calendar is periodic with -- period of 400 years. There are 100 - 4 + 1 = 97 leap years in a -- period, so the average length of a year is 365 + 97/400 = -- 146097/400 days. -- -- Now, if you consider these -- let's call them nominal -- years, -- then for any point in time, for any linear day number we can -- determine which nominal year does it fall into by a single -- division. Moreover, if we align the start of the calendar year 1 -- with the start of the nominal year 1, then the calendar years and -- nominal years never get too much out of sync. Specifically: -- -- * start of the first day of a calendar year might fall into the -- preceding nominal year, but never more than by 1.5 days (591/400 -- days, to be precise) -- * the start of the last day of a calendar year always falls into -- its nominal year (even for the leap years). -- -- So, to find out the calendar year for a given day, we calculate -- which nominal year does its start fall. And, if we are not too -- close to the end of year, we have the right calendar -- year. Othewise, we just check whether it falls within the next -- calendar year. -- -- Notes: to make the reasoning simpler and more efficient ('quot' is -- faster than 'div') we do the computation directly only for positive -- years (days after 1-1-1). For earlier dates we "transate" by an -- integral number of 400 year periods, do the computation and -- translate back. {-# INLINE ordinalDate #-} ordinalDate :: Iso' Day OrdinalDate ordinalDate = iso toOrd fromOrd where {-# INLINEABLE toOrd #-} toOrd :: Day -> OrdinalDate toOrd (ModifiedJulianDay mjd) | dayB0 <= 0 = case toOrdB0 dayInQC of OrdinalDate y yd -> OrdinalDate (y + quadCent * 400) yd | otherwise = toOrdB0 dayB0 where dayB0 = mjd + 678575 (quadCent, dayInQC) = dayB0 `divMod` 146097 -- Input: days since 1-1-1. Precondition: has to be positive! {-# INLINE toOrdB0 #-} toOrdB0 :: Int -> OrdinalDate toOrdB0 dayB0 = res where (y0, r) = (400 * dayB0) `quotRem` 146097 d0 = dayInYear y0 dayB0 d1 = dayInYear (y0 + 1) dayB0 res = if r > 146097 - 600 && d1 > 0 then OrdinalDate (y0 + 1 + 1) d1 else OrdinalDate (y0 + 1) d0 -- Input: (year - 1) (day as days since 1-1-1) -- Precondition: year is positive! {-# INLINE dayInYear #-} dayInYear :: Int -> Int -> Int dayInYear y0 dayB0 = dayB0 - 365 * y0 - leaps + 1 where leaps = y0 `shiftR` 2 - centuries + centuries `shiftR` 2 centuries = y0 `quot` 100 {-# INLINEABLE fromOrd #-} fromOrd :: OrdinalDate -> Day fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where years = year - 1 centuries = years `div` 100 leaps = years `shiftR` 2 - centuries + centuries `shiftR` 2 mjd = 365 * years + leaps - 678576 + clip 1 (if isLeapYear year then 366 else 365) yd clip a b = max a . min b ------------------------------------------------------------------------ -- Lookup tables for Data.Thyme.Calendar.MonthDay {-# NOINLINE monthLengths #-} {-# NOINLINE monthLengthsLeap #-} monthLengths, monthLengthsLeap :: VU.Vector Days monthLengths = VU.fromList [31,28,31,30,31,30,31,31,30,31,30,31] monthLengthsLeap = VU.fromList [31,29,31,30,31,30,31,31,30,31,30,31] -- J F M A M J J A S O N D {-# ANN monthDays "HLint: ignore Use fromMaybe" #-} {-# NOINLINE monthDays #-} monthDays :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8) monthDays = VU.generate 365 go where dom01 = VU.prescanl' (+) 0 monthLengths go yd = (fromIntegral m, fromIntegral d) where m = maybe 12 id $ VU.findIndex (yd <) dom01 d = succ yd - VU.unsafeIndex dom01 (pred m) {-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-} {-# NOINLINE monthDaysLeap #-} monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8) monthDaysLeap = VU.generate 366 go where dom01 = VU.prescanl' (+) 0 monthLengthsLeap go yd = (fromIntegral m, fromIntegral d) where m = maybe 12 id $ VU.findIndex (yd <) dom01 d = succ yd - VU.unsafeIndex dom01 (pred m) -- | No good home for this within the current hierarchy. This will do. {-# INLINEABLE randomIsoR #-} randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g) randomIsoR l (x, y) = first (^. l) . randomR (l # x, l # y) ------------------------------------------------------------------------ data MonthDay = MonthDay { mdMonth :: {-# UNPACK #-}!Month , mdDay :: {-# UNPACK #-}!DayOfMonth } deriving (INSTANCES_USUAL, Show) instance NFData MonthDay instance Bounded MonthDay where minBound = MonthDay 1 1 maxBound = MonthDay 12 31 instance Random MonthDay where randomR r g = randomIsoR (monthDay leap) r g' where (isLeapYear -> leap, g') = random g random = randomR (minBound, maxBound) instance Arbitrary MonthDay where arbitrary = choose (minBound, maxBound) shrink md = view (monthDay True) <$> shrink (monthDay True # md) instance CoArbitrary MonthDay where coarbitrary (MonthDay m d) = coarbitrary m . coarbitrary d -- | 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 -> Iso' DayOfYear MonthDay monthDay leap = iso fromOrdinal toOrdinal where (lastDay, lengths, table, ok) = if leap then (365, monthLengthsLeap, monthDaysLeap, -1) else (364, monthLengths, monthDays, -2) {-# INLINE fromOrdinal #-} fromOrdinal :: DayOfYear -> MonthDay fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where (fromIntegral -> m, fromIntegral -> d) = VU.unsafeIndex table i {-# INLINE toOrdinal #-} toOrdinal :: MonthDay -> DayOfYear toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where m = max 1 . min 12 $ month l = VU.unsafeIndex lengths (pred m) d = max 1 . min l $ day k = if m <= 2 then 0 else ok {-# INLINEABLE monthDayValid #-} monthDayValid :: Bool -> MonthDay -> Maybe DayOfYear monthDayValid leap md@(MonthDay m d) = monthDay leap # md <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m) {-# INLINEABLE monthLength #-} monthLength :: Bool -> Month -> Days monthLength leap = VU.unsafeIndex ls . max 0 . min 11 . pred where ls = if leap then monthLengthsLeap else monthLengths ------------------------------------------------------------------------ type WeekOfYear = Int type DayOfWeek = Int -- | Weeks numbered 01 to 53, where week 01 is the first week that has at -- least 4 days in the new year. Days before week 01 are considered to -- belong to the previous year. data WeekDate = WeekDate { wdYear :: {-# UNPACK #-}!Year , wdWeek :: {-# UNPACK #-}!WeekOfYear , wdDay :: {-# UNPACK #-}!DayOfWeek } deriving (INSTANCES_USUAL, Show) instance NFData WeekDate {-# INLINE weekDate #-} weekDate :: Iso' Day WeekDate weekDate = iso toWeek fromWeek where {-# INLINEABLE toWeek #-} toWeek :: Day -> WeekDate toWeek = join (toWeekOrdinal . view ordinalDate) {-# INLINEABLE fromWeek #-} fromWeek :: WeekDate -> Day fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd {-# INLINE toWeekOrdinal #-} toWeekOrdinal :: OrdinalDate -> Day -> WeekDate toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) = WeekDate y1 (w1 + 1) (d7mod + 1) where -- pilfered and refactored; no idea what foo and bar mean d = mjd + 2 (d7div, d7mod) = divMod d 7 foo :: Year -> {-WeekOfYear-1-}Int foo y = bar $ ordinalDate # OrdinalDate y 6 bar :: Day -> {-WeekOfYear-1-}Int bar (ModifiedJulianDay k) = d7div - div k 7 w0 = bar $ ModifiedJulianDay (d - yd + 4) (y1, w1) = case w0 of -1 -> (y0 - 1, foo (y0 - 1)) 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0) _ -> (y0, w0) {-# INLINE lastWeekOfYear #-} lastWeekOfYear :: Year -> WeekOfYear lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where wd = OrdinalDate y 365 ^. from ordinalDate . weekDate {-# INLINE fromWeekLast #-} fromWeekLast :: WeekOfYear -> WeekDate -> Day fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where -- pilfered and refactored ModifiedJulianDay k = ordinalDate # OrdinalDate y 6 mjd = k - mod k 7 - 10 + clip 1 7 d + clip 1 wMax w * 7 clip a b = max a . min b {-# INLINEABLE weekDateValid #-} weekDateValid :: WeekDate -> Maybe Day weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) = fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) {-# INLINEABLE showWeekDate #-} showWeekDate :: Day -> String showWeekDate (view weekDate -> WeekDate y w d) = showsYear y . (++) "-W" . shows02 w . (:) '-' . shows d $ "" ------------------------------------------------------------------------ -- | Weeks numbered from 0 to 53, starting with the first Sunday of the year -- as the first day of week 1. The last week of a given year and week 0 of -- the next both refer to the same week, but not all 'DayOfWeek' are valid. -- 'Year' coincides with that of 'gregorian'. data SundayWeek = SundayWeek { swYear :: {-# UNPACK #-}!Year , swWeek :: {-# UNPACK #-}!WeekOfYear , swDay :: {-# UNPACK #-}!DayOfWeek } deriving (INSTANCES_USUAL, Show) instance NFData SundayWeek {-# INLINE sundayWeek #-} sundayWeek :: Iso' Day SundayWeek sundayWeek = iso toSunday fromSunday where {-# INLINEABLE toSunday #-} toSunday :: Day -> SundayWeek toSunday = join (toSundayOrdinal . view ordinalDate) {-# INLINEABLE fromSunday #-} fromSunday :: SundayWeek -> Day fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstSunday = mod (4 - firstDay) 7 yd = firstSunday + 7 * (w - 1) + d {-# INLINE toSundayOrdinal #-} toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = SundayWeek y (d7div - div k 7) d7mod where d = mjd + 3 k = d - yd (d7div, d7mod) = divMod d 7 {-# INLINEABLE sundayWeekValid #-} sundayWeekValid :: SundayWeek -> Maybe Day sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstSunday = mod (4 - firstDay) 7 yd = firstSunday + 7 * (w - 1) + d lastDay = if isLeapYear y then 365 else 364 ------------------------------------------------------------------------ -- | Weeks numbered from 0 to 53, starting with the first Monday of the year -- as the first day of week 1. The last week of a given year and week 0 of -- the next both refer to the same week, but not all 'DayOfWeek' are valid. -- 'Year' coincides with that of 'gregorian'. data MondayWeek = MondayWeek { mwYear :: {-# UNPACK #-}!Year , mwWeek :: {-# UNPACK #-}!WeekOfYear , mwDay :: {-# UNPACK #-}!DayOfWeek } deriving (INSTANCES_USUAL, Show) instance NFData MondayWeek {-# INLINE mondayWeek #-} mondayWeek :: Iso' Day MondayWeek mondayWeek = iso toMonday fromMonday where {-# INLINEABLE toMonday #-} toMonday :: Day -> MondayWeek toMonday = join (toMondayOrdinal . view ordinalDate) {-# INLINEABLE fromMonday #-} fromMonday :: MondayWeek -> Day fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstMonday = mod (5 - firstDay) 7 yd = firstMonday + 7 * (w - 1) + d - 1 {-# INLINE toMondayOrdinal #-} toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = MondayWeek y (d7div - div k 7) (d7mod + 1) where d = mjd + 2 k = d - yd (d7div, d7mod) = divMod d 7 {-# INLINEABLE mondayWeekValid #-} mondayWeekValid :: MondayWeek -> Maybe Day mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstMonday = mod (5 - firstDay) 7 yd = firstMonday + 7 * (w - 1) + d - 1 lastDay = if isLeapYear y then 365 else 364 ------------------------------------------------------------------------ -- Unbox instances at the end avoids TH-related declaration order issues derivingUnbox "Day" [t| Day -> Int |] [| toModifiedJulianDay |] [| ModifiedJulianDay |] derivingUnbox "YearMonthDay" [t| YearMonthDay -> Int |] [| \ YearMonthDay {..} -> shiftL ymdYear 9 .|. shiftL ymdMonth 5 .|. ymdDay |] [| \ n -> YearMonthDay (shiftR n 9) (shiftR n 5 .&. 0xf) (n .&. 0x1f) |] derivingUnbox "OrdinalDate" [t| OrdinalDate -> Int |] [| \ OrdinalDate {..} -> shiftL odYear 9 .|. odDay |] [| \ n -> OrdinalDate (shiftR n 9) (n .&. 0x1ff) |] derivingUnbox "MonthDay" [t| MonthDay -> Int |] [| \ MonthDay {..} -> shiftL mdMonth 5 .|. mdDay |] [| \ n -> MonthDay (shiftR n 5) (n .&. 0x1f) |] derivingUnbox "WeekDate" [t| WeekDate -> Int |] [| \ WeekDate {..} -> shiftL wdYear 9 .|. shiftL wdWeek 3 .|. wdDay |] [| \ n -> WeekDate (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] derivingUnbox "SundayWeek" [t| SundayWeek -> Int |] [| \ SundayWeek {..} -> shiftL swYear 9 .|. shiftL swWeek 3 .|. swDay |] [| \ n -> SundayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] derivingUnbox "MondayWeek" [t| MondayWeek -> Int |] [| \ MondayWeek {..} -> shiftL mwYear 9 .|. shiftL mwWeek 3 .|. mwDay |] [| \ n -> MondayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] thyme-0.3.5.5/src/Data/Thyme/Clock/0000755000000000000000000000000012435525530014763 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme/Clock/POSIX.hsc0000644000000000000000000000362412435525530016371 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} #ifndef mingw32_HOST_OS #include #endif module Data.Thyme.Clock.POSIX ( posixDayLength , POSIXTime , posixTime , getPOSIXTime ) where import Prelude import Control.Lens import Data.AdditiveGroup import Data.Thyme.Internal.Micro import Data.Thyme.Clock.Internal #ifdef mingw32_HOST_OS import System.Win32.Time #else import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.Types import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable #endif type POSIXTime = NominalDiffTime {-# INLINE posixTime #-} posixTime :: Iso' UTCTime POSIXTime posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch) (UTCRep . (^+^) unixEpoch) where unixEpoch = review microseconds $ {-ModifiedJulianDay-}40587 * {-posixDayLength-}86400000000 {-# INLINE getPOSIXTime #-} getPOSIXTime :: IO POSIXTime #ifdef mingw32_HOST_OS -- On Windows, the equlvalent of POSIX time is "file time", defined as -- the number of 100-nanosecond intervals that have elapsed since -- 12:00 AM January 1, 1601 (UTC). We can convert this into a POSIX -- time by adjusting the offset to be relative to the POSIX epoch. getPOSIXTime = do FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime return . NominalDiffTime . Micro . fromIntegral $ quot ft 10 - 11644473600000000{-ftEpoch ^. microseconds-} -- ftEpoch = utcTime # UTCTime (gregorian # YearMonthDay 1601 1 1) zeroV #else getPOSIXTime = allocaBytes #{size struct timeval} $ \ ptv -> do throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptv nullPtr CTime sec <- #{peek struct timeval, tv_sec} ptv CSUSeconds usec <- #{peek struct timeval, tv_usec} ptv return . NominalDiffTime . Micro $ 1000000 * fromIntegral sec + fromIntegral usec foreign import ccall unsafe "time.h gettimeofday" gettimeofday :: Ptr () -> Ptr () -> IO CInt #endif thyme-0.3.5.5/src/Data/Thyme/Clock/TAI.hs0000644000000000000000000001172012435525530015735 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} #include "thyme.h" #if HLINT #include "cabal_macros.h" #endif module Data.Thyme.Clock.TAI ( AbsoluteTime , taiEpoch , LeapSecondTable , utcDayLength , absoluteTime , parseTAIUTCDAT ) where import Prelude import Control.Applicative import Control.DeepSeq import Control.Lens import Control.Monad import Data.AffineSpace import Data.Attoparsec.ByteString.Char8 (()) import qualified Data.Attoparsec.ByteString.Char8 as P import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.Char import Data.Data import Data.Either import Data.Ix #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as Map #else import qualified Data.Map as Map #endif import Data.Thyme.Calendar import Data.Thyme.Clock.Internal import Data.Thyme.Format.Internal import Data.Thyme.LocalTime #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Locale import System.Random (Random) import Test.QuickCheck newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO) derivingUnbox "AbsoluteTime" [t| AbsoluteTime -> DiffTime |] [| \ (AbsoluteTime a) -> a |] [| AbsoluteTime |] instance Show AbsoluteTime where {-# INLINEABLE showsPrec #-} showsPrec p tai = showsPrec p lt . (++) " TAI" where lt = tai ^. from (absoluteTime (const zeroV)) . utcLocalTime utc -- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI. {-# INLINE taiEpoch #-} taiEpoch :: AbsoluteTime taiEpoch = AbsoluteTime zeroV instance AffineSpace AbsoluteTime where type Diff AbsoluteTime = DiffTime {-# INLINE (.-.) #-} (.-.) = \ (AbsoluteTime a) (AbsoluteTime b) -> a ^-^ b {-# INLINE (.+^) #-} (.+^) = \ (AbsoluteTime a) d -> AbsoluteTime (a ^+^ d) type LeapSecondTable = Either UTCTime AbsoluteTime -> DiffTime utcDayLength :: LeapSecondTable -> Day -> DiffTime utcDayLength table day@((.+^ 1) -> next) = DiffTime posixDay ^+^ diff next ^-^ diff day where diff d = table . Left $ utcTime # UTCTime d zeroV NominalDiffTime posixDay = posixDayLength {-# INLINE absoluteTime #-} absoluteTime :: LeapSecondTable -> Iso' UTCTime AbsoluteTime absoluteTime table = iso toTAI fromTAI where {-# INLINE toTAI #-} toTAI :: UTCTime -> AbsoluteTime toTAI ut@(UTCRep (NominalDiffTime u)) = AbsoluteTime (DiffTime u ^+^ table (Left ut)) {-# INLINE fromTAI #-} fromTAI :: AbsoluteTime -> UTCTime fromTAI tai@(AbsoluteTime a) = UTCRep (NominalDiffTime u) where DiffTime u = a ^-^ table (Right tai) -- | @tai-utc.dat@ from {-# INLINEABLE parseTAIUTCDAT #-} parseTAIUTCDAT :: ByteString -> LeapSecondTable parseTAIUTCDAT = parse $ do y <- dec_ 5 <* P.skipSpace "Year" let mons = map toUpper . snd <$> months defaultTimeLocale m <- succ <$> indexOf mons <* P.skipSpace "Month" d <- dec_ 2 "Day" tokens ["=", "JD"] -- TAI-UTC changes always happen at midnight, so just ignore ".5". mjd <- subtract 2400000{-.5-} <$> P.decimal <* P.string ".5" "Julian Date .5" let ymd = YearMonthDay y m d unless (gregorian # ymd == ModifiedJulianDay mjd) . fail $ show ymd ++ " is not Modified Julian Day " ++ show mjd tokens ["TAI", "-", "UTC", "="] b <- P.rational "Base" tokens ["S", "+", "(", "MJD", "-"] o <- P.rational "Offset" tokens [".", ")", "X"] c <- P.rational <* tokens ["S"] "Coefficient" -- FIXME: confirm UTC↔TAI conversion for pre-1972. -- Do we round MJD? This is a guess: -- TAI-UTC = b + c * (MJD(UTC) - o) let atUTC (UTCRep t) = fromSeconds' $ b + c * (toMJD t - o) -- TAI-UTC = (b + c * (MJD(TAI) - o)) / (1 + c) let atTAI (AbsoluteTime t) = fromSeconds' $ b + c * (toMJD t - o) / (1 + c) let NominalDiffTime ((toRational mjd *^) -> begin) = posixDayLength let beginUTC = UTCRep (NominalDiffTime begin) let beginTAI = AbsoluteTime (DiffTime begin ^-^ atUTC beginUTC) return ((beginUTC, atUTC), (beginTAI, atTAI)) where toMJD t = toSeconds t / toSeconds posixDayLength tokens = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) P.skipSpace parse row = pair . unzip . rights . map (P.parseOnly row) . S.lines pair (look -> atUTC, look -> atTAI) = either atUTC atTAI #if MIN_VERSION_containers(0,5,0) look l = \ t -> maybe zeroV (($ t) . snd) $ Map.lookupLE t (Map.fromList l) #else look l = \ t -> case Map.splitLookup t (Map.fromList l) of (lt, eq, _) -> maybe zeroV ($ t) $ eq <|> fst <$> Map.maxView lt #endif thyme-0.3.5.5/src/Data/Thyme/Clock/Internal.hs0000644000000000000000000002525612435525530017105 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -- workaround {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} #include "thyme.h" module Data.Thyme.Clock.Internal where import Prelude import Control.DeepSeq import Control.Lens import Data.AdditiveGroup import Data.AffineSpace import Data.Basis import Data.Data import Data.Int import Data.Ix import Data.Thyme.Internal.Micro import Data.Thyme.Calendar.Internal #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Random import Test.QuickCheck #if !SHOW_INTERNAL import Control.Monad import Text.ParserCombinators.ReadPrec (lift) import Text.ParserCombinators.ReadP (char) import Text.Read (readPrec) #endif -- | Time intervals, encompassing both 'DiffTime' and 'NominalDiffTime'. -- -- [@Issues@] Still affected by -- ? class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where -- | Escape hatch; avoid. microseconds :: Iso' t Int64 -- | Convert a time interval to some 'Fractional' type. {-# INLINE toSeconds #-} toSeconds :: (TimeDiff t, Fractional n) => t -> n toSeconds = (* recip 1000000) . fromIntegral . view microseconds -- | Make a time interval from some 'Real' type. -- -- [@Performance@] Try to make sure @n@ is one of 'Float', 'Double', 'Int', -- 'Int64' or 'Integer', for which rewrite @RULES@ have been provided. {-# INLINE[0] fromSeconds #-} fromSeconds :: (Real n, TimeDiff t) => n -> t fromSeconds = fromSeconds' . toRational -- | Type-restricted 'toSeconds' to avoid constraint-defaulting warnings. {-# INLINE toSeconds' #-} toSeconds' :: (TimeDiff t) => t -> Rational toSeconds' = (`decompose'` ()) -- | Type-restricted 'fromSeconds' to avoid constraint-defaulting warnings. {-# INLINE fromSeconds' #-} fromSeconds' :: (TimeDiff t) => Rational -> t fromSeconds' = (*^ basisValue ()) {-# INLINE picoseconds #-} picoseconds :: (TimeDiff t) => Iso' t Integer picoseconds = microseconds . iso ((*) 1000000 . toInteger) (\ ps -> fromInteger $ quot (ps + signum ps * 500000) 1000000) ------------------------------------------------------------------------ -- not for public consumption {-# INLINE fromSecondsRealFrac #-} fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t fromSecondsRealFrac _ = review microseconds . round . (*) 1000000 {-# INLINE fromSecondsIntegral #-} fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t fromSecondsIntegral _ = review microseconds . (*) 1000000 . fromIntegral {-# RULES "fromSeconds/Float" [~0] fromSeconds = fromSecondsRealFrac (0 :: Float) "fromSeconds/Double" [~0] fromSeconds = fromSecondsRealFrac (0 :: Double) "fromSeconds/Int" [~0] fromSeconds = fromSecondsIntegral (0 :: Int) "fromSeconds/Int64" [~0] fromSeconds = fromSecondsIntegral (0 :: Int64) "fromSeconds/Integer" [~0] fromSeconds = fromSecondsIntegral (0 :: Integer) #-} ------------------------------------------------------------------------ -- | An absolute time interval as measured by a clock. -- -- 'DiffTime' forms an 'AdditiveGroup'―so can be added using '^+^' (or '^-^' -- for subtraction), and also an instance of 'VectorSpace'―so can be scaled -- using '*^', where -- -- @ -- type 'Scalar' 'DiffTime' = 'Rational' -- @ newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) derivingUnbox "DiffTime" [t| DiffTime -> Micro |] [| \ (DiffTime a) -> a |] [| DiffTime |] #if SHOW_INTERNAL deriving instance Show DiffTime deriving instance Read DiffTime #else instance Show DiffTime where {-# INLINEABLE showsPrec #-} showsPrec p (DiffTime a) = showsPrec p a . (:) 's' instance Read DiffTime where {-# INLINEABLE readPrec #-} readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's') #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 instance TimeDiff DiffTime where {-# INLINE microseconds #-} microseconds = iso (\ (DiffTime (Micro u)) -> u) (DiffTime . Micro) ------------------------------------------------------------------------ -- | A time interval as measured by UTC, that does not take leap-seconds -- into account. -- -- For instance, the difference between @23:59:59@ and @00:00:01@ on the -- following day is always 2 seconds of 'NominalDiffTime', regardless of -- whether a leap-second took place. -- -- 'NominalDiffTime' forms an 'AdditiveGroup'―so can be added using '^+^' -- (or '^-^' for subtraction), and also an instance of 'VectorSpace'―so can -- be scaled using '*^', where -- -- @ -- type 'Scalar' 'NominalDiffTime' = 'Rational' -- @ newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) derivingUnbox "NominalDiffTime" [t| NominalDiffTime -> Micro |] [| \ (NominalDiffTime a) -> a |] [| NominalDiffTime |] #if SHOW_INTERNAL deriving instance Show NominalDiffTime deriving instance Read NominalDiffTime #else instance Show NominalDiffTime where {-# INLINEABLE showsPrec #-} showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest) instance Read NominalDiffTime where {-# INLINEABLE readPrec #-} readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's') #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 instance TimeDiff NominalDiffTime where {-# INLINE microseconds #-} microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro) -- | The nominal length of a POSIX day: precisely 86400 SI seconds. {-# INLINE posixDayLength #-} posixDayLength :: NominalDiffTime posixDayLength = microseconds # 86400000000 ------------------------------------------------------------------------ -- | The principal form of universal time, namely -- . -- -- 'UniversalTime' is defined by the rotation of the Earth around its axis -- relative to the Sun. Thus the length of a day by this definition varies -- from one to the next, and is never exactly 86400 SI seconds unlike -- or -- 'AbsoluteTime'. The difference between UT1 and UTC is -- . newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO) derivingUnbox "UniversalTime" [t| UniversalTime -> NominalDiffTime |] [| \ (UniversalRep a) -> a |] [| UniversalRep |] -- | View 'UniversalTime' as a fractional number of days since the -- . {-# INLINE modJulianDate #-} modJulianDate :: Iso' UniversalTime Rational modJulianDate = iso (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength) (UniversalRep . (*^ posixDayLength)) ------------------------------------------------------------------------ -- | : -- the most common form of universal time for civil timekeeping. It is -- synchronised with 'AbsoluteTime' and both tick in increments of SI -- seconds, but UTC includes occasional leap-seconds so that it does not -- drift too far from 'UniversalTime'. -- -- 'UTCTime' is an instance of 'AffineSpace', with -- -- @ -- type 'Diff' 'UTCTime' = 'NominalDiffTime' -- @ -- -- Use '.+^' to add (or '.-^' to subtract) time intervals of type -- 'NominalDiffTime', and '.-.' to get the interval between 'UTCTime's. -- -- [@Performance@] Internally this is a 64-bit count of 'microseconds' since -- the MJD epoch, so '.+^', '.-^' and '.-.' ought to be fairly fast. -- -- [@Issues@] 'UTCTime' currently -- . newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO) derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |] [| \ (UTCRep a) -> a |] [| UTCRep |] -- | Unpacked 'UTCTime', partly for compatibility with @time@. data UTCView = UTCTime { utctDay :: {-# UNPACK #-}!Day , utctDayTime :: {-# UNPACK #-}!DiffTime } deriving (INSTANCES_USUAL, Show) derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |] [| \ UTCTime {..} -> (utctDay, utctDayTime) |] [| \ (utctDay, utctDayTime) -> UTCTime {..} |] instance NFData UTCView -- | 'Lens'' for the 'Day' component of an 'UTCTime'. _utctDay :: Lens' UTCTime Day _utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t) -- | 'Lens'' for the time-of-day component of an 'UTCTime'. _utctDayTime :: Lens' UTCTime DiffTime _utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t) instance AffineSpace UTCTime where type Diff UTCTime = NominalDiffTime {-# INLINE (.-.) #-} (.-.) = \ (UTCRep a) (UTCRep b) -> a ^-^ b {-# INLINE (.+^) #-} (.+^) = \ (UTCRep a) d -> UTCRep (a ^+^ d) -- | View 'UTCTime' as an 'UTCView', comprising a 'Day' along with -- a 'DiffTime' offset since midnight. -- -- This is an improper lens: 'utctDayTime' offsets outside the range of -- @['zeroV', 'posixDayLength')@ will carry over into the day part, with the -- expected behaviour. {-# INLINE utcTime #-} utcTime :: Iso' UTCTime UTCView utcTime = iso toView fromView where NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength {-# INLINE toView #-} toView :: UTCTime -> UTCView toView (UTCRep (NominalDiffTime a)) = UTCTime (ModifiedJulianDay mjd) (DiffTime dt) where (fromIntegral -> mjd, dt) = microDivMod a posixDay {-# INLINE fromView #-} fromView :: UTCView -> UTCTime fromView (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt) thyme-0.3.5.5/src/Data/Thyme/Format/0000755000000000000000000000000012435525530015160 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme/Format/Human.hs0000644000000000000000000000553112435525530016570 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} #include "thyme.h" module Data.Thyme.Format.Human ( humanTimeDiff , humanTimeDiffs , humanRelTime , humanRelTimes ) where import Prelude import Control.Applicative import Control.Arrow import Control.Lens import Control.Monad import Data.AdditiveGroup import Data.AffineSpace import Data.Foldable import Data.Thyme.Internal.Micro import Data.Monoid import Data.Thyme.Clock.Internal import Data.VectorSpace data Unit = Unit { unit :: Micro , single :: ShowS , plural :: ShowS } LENS(Unit,plural,ShowS) -- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form. {-# INLINE humanTimeDiff #-} humanTimeDiff :: (TimeDiff d) => d -> String humanTimeDiff d = humanTimeDiffs d "" -- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form. {-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-} humanTimeDiffs :: (TimeDiff d) => d -> ShowS humanTimeDiffs td = (if signed < 0 then (:) '-' else id) . diff where signed@(Micro . abs -> us) = td ^. microseconds diff = maybe id id . getFirst . fold $ zipWith (approx us . unit) (tail units) units -- | Display one 'UTCTime' relative to another, in a human-readable form. {-# INLINE humanRelTime #-} humanRelTime :: UTCTime -> UTCTime -> String humanRelTime ref time = humanRelTimes ref time "" -- | Display one 'UTCTime' relative to another, in a human-readable form. humanRelTimes :: UTCTime -> UTCTime -> ShowS humanRelTimes ref time = thence $ humanTimeDiffs diff where (diff, thence) = case compare delta zeroV of LT -> (negateV delta, ((++) "in " .)) EQ -> (zeroV, const $ (++) "right now") GT -> (delta, (. (++) " ago")) where delta = time .-. ref approx :: Micro -> Micro -> Unit -> First ShowS approx us next Unit {..} = First $ shows n . inflection <$ guard (us < next) where n = fst $ microQuotRem (us ^+^ half) unit where half = Micro . fst $ microQuotRem unit (Micro 2) inflection = if n == 1 then single else plural units :: [Unit] units = scanl (&) (Unit (Micro 1) (" microsecond" ++) (" microseconds" ++)) [ times "millisecond" 1000 , times "second" 1000 , times "minute" 60 , times "hour" 60 , times "day" 24 , times "week" 7 , times "month" (30.4368 / 7) , times "year" 12 , times "decade" 10 , times "century" 10 >>> set _plural (" centuries" ++) , times "millennium" 10 >>> set _plural (" millennia" ++) , const (Unit maxBound id id) -- upper bound needed for humanTimeDiffs.diff ] where times :: String -> Rational -> Unit -> Unit times ((++) . (:) ' ' -> single) r Unit {unit} = Unit {unit = r *^ unit, plural = single . (:) 's', ..} thyme-0.3.5.5/src/Data/Thyme/Format/Aeson.hs0000644000000000000000000000667412435525530016576 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Instances of 'FromJSON' and 'ToJSON' for 'UTCTime' and 'ZonedTime', -- along with a newtype wrapper 'DotNetTime'. module Data.Thyme.Format.Aeson ( DotNetTime (..) ) where import Prelude import Control.Applicative import Data.Aeson hiding (DotNetTime (..)) import Data.Aeson.Types hiding (DotNetTime (..)) import Data.Data import Data.Monoid import Data.Text (pack, unpack) import qualified Data.Text as T import Data.Thyme import System.Locale -- Copyright: (c) 2011, 2012, 2013 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. ------------------------------------------------------------------------ -- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Internal -- | A newtype wrapper for 'UTCTime' that uses the same non-standard -- serialization format as Microsoft .NET, whose @System.DateTime@ -- type is by default serialized to JSON as in the following example: -- -- > /Date(1302547608878)/ -- -- The number represents milliseconds since the Unix epoch. newtype DotNetTime = DotNetTime { fromDotNetTime :: UTCTime } deriving (Eq, Ord, Read, Show, Typeable, FormatTime) ------------------------------------------------------------------------ -- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Instances instance ToJSON DotNetTime where toJSON (DotNetTime t) = String (pack (secs ++ formatMillis t ++ ")/")) where secs = formatTime defaultTimeLocale "/Date(%s" t {-# INLINE toJSON #-} instance FromJSON DotNetTime where parseJSON = withText "DotNetTime" $ \t -> let (s,m) = T.splitAt (T.length t - 5) t t' = T.concat [s,".",m] in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of Just d -> pure (DotNetTime d) _ -> fail "could not parse .NET time" {-# INLINE parseJSON #-} instance ToJSON ZonedTime where toJSON t = String $ pack $ formatTime defaultTimeLocale format t where format = "%FT%T." ++ formatMillis t ++ tzFormat tzFormat | 0 == timeZoneMinutes (zonedTimeZone t) = "Z" | otherwise = "%z" formatMillis :: (FormatTime t) => t -> String formatMillis t = take 3 . formatTime defaultTimeLocale "%q" $ t instance FromJSON ZonedTime where parseJSON (String t) = tryFormats alternateFormats <|> fail "could not parse ECMA-262 ISO-8601 date" where tryFormat f = case parseTime defaultTimeLocale f (unpack t) of Just d -> pure d Nothing -> empty tryFormats = foldr1 (<|>) . map tryFormat alternateFormats = dateTimeFmt defaultTimeLocale : distributeList ["%Y", "%Y-%m", "%F"] ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"] distributeList xs ys = foldr (\x acc -> acc ++ distribute x ys) [] xs distribute x = map (mappend x) parseJSON v = typeMismatch "ZonedTime" v instance ToJSON UTCTime where toJSON t = String $ pack $ formatTime defaultTimeLocale format t where format = "%FT%T." ++ formatMillis t ++ "Z" {-# INLINE toJSON #-} instance FromJSON UTCTime where parseJSON = withText "UTCTime" $ \t -> case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of Just d -> pure d _ -> fail "could not parse ISO-8601 date" {-# INLINE parseJSON #-} thyme-0.3.5.5/src/Data/Thyme/Format/Internal.hs0000644000000000000000000001031512435525530017270 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} #if HLINT #include "cabal_macros.h" #endif module Data.Thyme.Format.Internal where import Prelude import Control.Applicative import Data.Attoparsec.ByteString.Char8 (Parser, Result, IResult (..)) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Char8 as S import Data.Char import Data.Int import qualified Data.Text as Text import qualified Data.Text.Encoding as Text #if MIN_VERSION_bytestring(0,10,0) # if MIN_VERSION_bytestring(0,10,2) import qualified Data.ByteString.Builder as B # else import qualified Data.ByteString.Lazy.Builder as B # endif import qualified Data.ByteString.Lazy as L #endif {-# INLINE utf8Char #-} {-# INLINE utf8String #-} utf8Char :: Char -> S.ByteString utf8String :: String -> S.ByteString #if MIN_VERSION_bytestring(0,10,0) utf8Char = L.toStrict . B.toLazyByteString . B.charUtf8 utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8 #else utf8Char = Text.encodeUtf8 . Text.singleton utf8String = Text.encodeUtf8 . Text.pack #endif ------------------------------------------------------------------------ {-# INLINE shows02 #-} shows02 :: Int -> ShowS shows02 n = if n < 10 then (:) '0' . shows n else shows n {-# ANN shows_2 "HLint: ignore Use camelCase" #-} {-# INLINE shows_2 #-} shows_2 :: Int -> ShowS 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 showsYear #-} showsYear :: Int -> ShowS showsYear n@(abs -> u) | u < 10 = neg . (++) "000" . shows u | u < 100 = neg . (++) "00" . shows u | u < 1000 = neg . (++) "0" . shows u | otherwise = neg . shows u where neg = if n < 0 then (:) '-' else id {-# 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 ------------------------------------------------------------------------ {-# INLINEABLE parserToReadS #-} parserToReadS :: Parser a -> ReadS a parserToReadS = go . P.parse where {-# INLINEABLE go #-} go :: (S.ByteString -> Result a) -> ReadS a go k (splitAt 32 -> (h, t)) = case k (utf8String h) of -- `date -R | wc -c` is 32 characters Fail rest cxts msg -> fail $ concat [ "parserToReadS: ", msg , "; remaining: ", show (utf8Decode rest), "; stack: ", show cxts ] Partial k' -> go k' t Done rest a -> return (a, utf8Decode rest ++ t) {-# INLINE utf8Decode #-} utf8Decode :: S.ByteString -> String utf8Decode = Text.unpack . Text.decodeUtf8 {-# INLINE indexOf #-} indexOf :: [String] -> Parser Int indexOf = P.choice . zipWith (\ i s -> i <$ P.string (S.pack s)) [0..] {-# INLINE indexOfCI #-} indexOfCI :: [String] -> Parser Int indexOfCI = P.choice . zipWith (\ i s -> i <$ stringCI s) [0..] -- | Case-insensitive UTF-8 ByteString parser -- -- Matches one character at a time. Slow. {-# INLINE stringCI #-} stringCI :: String -> Parser () stringCI = foldl (\ p c -> p *> charCI c) (pure ()) -- | Case-insensitive UTF-8 ByteString parser -- -- We can't easily perform upper/lower case conversion on the input, so -- instead we accept either one of @toUpper c@ and @toLower c@. {-# INLINE charCI #-} charCI :: Char -> Parser () charCI c = if u == l then charU8 c else charU8 l <|> charU8 u where l = toLower c u = toUpper c {-# INLINE charU8 #-} charU8 :: Char -> Parser () charU8 c = () <$ P.string (utf8Char c) -- | Number may be prefixed with '-' {-# INLINE negative #-} negative :: (Integral n) => Parser n -> Parser n negative p = ($) <$> (negate <$ P.char '-' <|> pure id) <*> p -- | Fixed-length 0-padded decimal {-# INLINE dec0 #-} dec0 :: Int -> Parser Int dec0 n = either fail return . P.parseOnly P.decimal =<< P.take n -- | Fixed-length space-padded decimal {-# INLINE dec_ #-} dec_ :: Int -> Parser Int dec_ n = either fail return . P.parseOnly P.decimal =<< S.dropWhile isSpace <$> P.take n thyme-0.3.5.5/src/Data/Thyme/Internal/0000755000000000000000000000000012435525530015504 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme/Internal/Micro.hs0000644000000000000000000000603612435525530017116 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #include "thyme.h" -- | FOR INTERNAL USE ONLY. module Data.Thyme.Internal.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 #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Random import Test.QuickCheck #if !SHOW_INTERNAL import Control.Monad import Data.Char import Data.Thyme.Format.Internal import Numeric import Text.ParserCombinators.ReadPrec import Text.ParserCombinators.ReadP import Text.Read #endif newtype Micro = Micro Int64 deriving (INSTANCES_MICRO) derivingUnbox "Micro" [t| Micro -> Int64 |] [| \ (Micro a) -> a |] [| Micro |] #if SHOW_INTERNAL deriving instance Show Micro deriving instance Read Micro #else instance Show Micro where {-# INLINEABLE showsPrec #-} showsPrec _ (Micro a) = sign . shows si . frac where sign = if a < 0 then (:) '-' else id (si, su) = abs a `divMod` 1000000 frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su instance Read Micro where {-# INLINEABLE readPrec #-} readPrec = lift $ do sign <- (char '-' >> return negate) `mplus` return id s <- readS_to_P readDec us <- (`mplus` return 0) $ do _ <- char '.' [(us10, "")] <- (readDec . take 7 . (++ "000000")) `fmap` munch1 isDigit return (div (us10 + 5) 10) return . Micro . sign $ s * 1000000 + us #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 {-# INLINEABLE (*^) #-} s *^ Micro a = Micro . fromInteger $ case compare (2 * abs r) (denominator s) of LT -> n EQ -> if even n then n else m GT -> m where (n, r) = quotRem (toInteger a * numerator s) (denominator s) m = if r < 0 then n - 1 else n + 1 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) _ -> fromIntegral a % 1000000 thyme-0.3.5.5/src/Data/Thyme/Time/0000755000000000000000000000000012435525530014626 5ustar0000000000000000thyme-0.3.5.5/src/Data/Thyme/Time/Core.hs0000644000000000000000000002603212435525530016055 0ustar0000000000000000{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -- | This module provides just the compatibility wrappers for the things -- that @thyme@ does differently from @time@. No 'RealFrac' instances for -- 'DiffTime' nor 'NominalDiffTime', nor other riffraff. module Data.Thyme.Time.Core ( module Data.Thyme , module Data.Thyme.Time.Core ) where import Prelude import Control.Lens import Data.AffineSpace import Data.Int import Data.Thyme.Internal.Micro import Data.Ratio import Data.Thyme import Data.Thyme.Calendar.OrdinalDate import Data.Thyme.Calendar.MonthDay import Data.Thyme.Calendar.WeekDate import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX import Data.Thyme.Clock.TAI import qualified Data.Time.Calendar as T import qualified Data.Time.Clock as T import qualified Data.Time.Clock.TAI as T import qualified Data.Time.LocalTime as T import Unsafe.Coerce ------------------------------------------------------------------------ -- * Type conversion class Thyme a b | b -> a where thyme :: Iso' a b instance Thyme T.Day Day where {-# INLINE thyme #-} thyme = iso (ModifiedJulianDay . fromInteger . T.toModifiedJulianDay) (T.ModifiedJulianDay . toInteger . toModifiedJulianDay) instance Thyme T.UniversalTime UniversalTime where {-# INLINE thyme #-} thyme = iso T.getModJulianDate T.ModJulianDate . from modJulianDate instance Thyme T.DiffTime DiffTime where {-# INLINE thyme #-} thyme = iso unsafeCoerce unsafeCoerce . from picoseconds instance Thyme T.NominalDiffTime NominalDiffTime where {-# INLINE thyme #-} thyme = iso unsafeCoerce unsafeCoerce . from picoseconds instance Thyme T.UTCTime UTCView where {-# INLINE thyme #-} thyme = iso (\ (T.UTCTime d t) -> UTCTime (d ^. thyme) (t ^. thyme)) (\ (UTCTime d t) -> T.UTCTime (thyme # d) (thyme # t)) instance Thyme T.UTCTime UTCTime where {-# INLINE thyme #-} thyme = thyme . from utcTime instance Thyme T.AbsoluteTime AbsoluteTime where {-# INLINE thyme #-} thyme = iso (`T.diffAbsoluteTime` T.taiEpoch) (`T.addAbsoluteTime` T.taiEpoch) . thyme . iso (taiEpoch .+^) (.-. taiEpoch) instance Thyme T.TimeZone TimeZone where {-# INLINE thyme #-} thyme = iso (\ T.TimeZone {..} -> TimeZone {..}) (\ TimeZone {..} -> T.TimeZone {..}) instance Thyme T.TimeOfDay TimeOfDay where {-# INLINE thyme #-} thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m $ microseconds # round (s * 1000000) ) ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational $ toInteger (s ^. microseconds) % 1000000 ) instance Thyme T.LocalTime LocalTime where {-# INLINE thyme #-} thyme = iso (\ (T.LocalTime d t) -> LocalTime (d ^. thyme) (t ^. thyme)) (\ (LocalTime d t) -> T.LocalTime (thyme # d) (thyme # t)) instance Thyme T.ZonedTime ZonedTime where {-# INLINE thyme #-} thyme = iso (\ (T.ZonedTime t z) -> ZonedTime (t ^. thyme) (z ^. thyme)) (\ (ZonedTime t z) -> T.ZonedTime (thyme # t) (thyme # z)) {-# INLINE toThyme #-} toThyme :: (Thyme a b) => a -> b toThyme = view thyme {-# INLINE fromThyme #-} fromThyme :: (Thyme a b) => b -> a fromThyme = review thyme ------------------------------------------------------------------------ -- * @Data.Time.Calendar@ {-# INLINE addDays #-} addDays :: Days -> Day -> Day addDays = flip (.+^) {-# INLINE diffDays #-} diffDays :: Day -> Day -> Days diffDays = (.-.) {-# INLINE toGregorian #-} toGregorian :: Day -> (Year, Month, DayOfMonth) toGregorian (view gregorian -> YearMonthDay y m d) = (y, m, d) {-# INLINE fromGregorian #-} fromGregorian :: Year -> Month -> DayOfMonth -> Day fromGregorian y m d = gregorian # YearMonthDay y m d {-# INLINE fromGregorianValid #-} fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day fromGregorianValid y m d = gregorianValid (YearMonthDay y m d) {-# INLINE addGregorianMonthsClip #-} addGregorianMonthsClip :: Months -> Day -> Day addGregorianMonthsClip n = review gregorian . gregorianMonthsClip n . view gregorian {-# INLINE addGregorianMonthsRollover #-} addGregorianMonthsRollover :: Months -> Day -> Day addGregorianMonthsRollover n = review gregorian . gregorianMonthsRollover n . view gregorian {-# INLINE addGregorianYearsClip #-} addGregorianYearsClip :: Years -> Day -> Day addGregorianYearsClip n = review gregorian . gregorianYearsClip n . view gregorian {-# INLINE addGregorianYearsRollover #-} addGregorianYearsRollover :: Years -> Day -> Day addGregorianYearsRollover n = review gregorian . gregorianYearsRollover n . view gregorian ------------------------------------------------------------------------ -- * @Data.Time.Calendar.MonthDay@ {-# INLINE dayOfYearToMonthAndDay #-} dayOfYearToMonthAndDay :: Bool -> DayOfYear -> (Month, DayOfMonth) dayOfYearToMonthAndDay leap (view (monthDay leap) -> MonthDay m d) = (m, d) {-# INLINE monthAndDayToDayOfYear #-} monthAndDayToDayOfYear :: Bool -> Month -> DayOfMonth -> DayOfYear monthAndDayToDayOfYear leap m d = monthDay leap # MonthDay m d {-# INLINE monthAndDayToDayOfYearValid #-} monthAndDayToDayOfYearValid :: Bool -> Month -> DayOfMonth -> Maybe DayOfYear monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d) ------------------------------------------------------------------------ -- * @Data.Time.Calendar.OrdinalDate@ {-# INLINE toOrdinalDate #-} toOrdinalDate :: Day -> (Year, DayOfYear) toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d) {-# INLINE fromOrdinalDate #-} fromOrdinalDate :: Year -> DayOfYear -> Day fromOrdinalDate y d = ordinalDate # OrdinalDate y d {-# INLINE fromOrdinalDateValid #-} fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d) {-# INLINE sundayStartWeek #-} sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek) sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d) {-# INLINE fromSundayStartWeek #-} fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d {-# INLINE fromSundayStartWeekValid #-} fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d) {-# INLINE mondayStartWeek #-} mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek) mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d) {-# INLINE fromMondayStartWeek #-} fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d {-# INLINE fromMondayStartWeekValid #-} fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d) ------------------------------------------------------------------------ -- * @Data.Time.Calendar.WeekDate@ {-# INLINE toWeekDate #-} toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek) toWeekDate (view weekDate -> WeekDate y w d) = (y, w, d) {-# INLINE fromWeekDate #-} fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day fromWeekDate y w d = weekDate # WeekDate y w d {-# INLINE fromWeekDateValid #-} fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day fromWeekDateValid y w d = weekDateValid (WeekDate y w d) ------------------------------------------------------------------------ -- * @Data.Time.Clock@ {-# INLINE getModJulianDate #-} getModJulianDate :: UniversalTime -> Rational getModJulianDate = view modJulianDate -- | Replacement for 'T.ModJulianDate'. {-# INLINE mkModJulianDate #-} mkModJulianDate :: Rational -> UniversalTime mkModJulianDate = review modJulianDate {-# INLINE secondsToDiffTime #-} secondsToDiffTime :: Int64 -> DiffTime secondsToDiffTime a = DiffTime (Micro $ a * 1000000) {-# INLINE picosecondsToDiffTime #-} picosecondsToDiffTime :: Int64 -> DiffTime picosecondsToDiffTime a = DiffTime . Micro $ quot (a + signum a * 500000) 1000000 {-# INLINE mkUTCTime #-} mkUTCTime :: Day -> DiffTime -> UTCTime mkUTCTime d t = utcTime # UTCTime d t {-# INLINE unUTCTime #-} unUTCTime :: UTCTime -> UTCView unUTCTime = view utcTime {-# INLINE addUTCTime #-} addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime addUTCTime = flip (.+^) {-# INLINE diffUTCTime #-} diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime diffUTCTime = (.-.) {-# INLINE toMicroseconds #-} toMicroseconds :: (TimeDiff t) => t -> Int64 toMicroseconds = view microseconds {-# INLINE fromMicroseconds #-} fromMicroseconds :: (TimeDiff t) => Int64 -> t fromMicroseconds = review microseconds ------------------------------------------------------------------------ -- * @Data.Time.Clock.POSIX@ {-# INLINE posixSecondsToUTCTime #-} posixSecondsToUTCTime :: POSIXTime -> UTCTime posixSecondsToUTCTime = review posixTime {-# INLINE utcTimeToPOSIXSeconds #-} utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime utcTimeToPOSIXSeconds = view posixTime ------------------------------------------------------------------------ -- * @Data.Time.Clock.TAI@ {-# INLINE addAbsoluteTime #-} addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime addAbsoluteTime = flip (.+^) {-# INLINE diffAbsoluteTime #-} diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime diffAbsoluteTime = (.-.) {-# INLINE utcToTAITime #-} utcToTAITime :: LeapSecondTable -> UTCTime -> AbsoluteTime utcToTAITime = view . absoluteTime {-# INLINE taiToUTCTime #-} taiToUTCTime :: LeapSecondTable -> AbsoluteTime -> UTCTime taiToUTCTime = review . absoluteTime ------------------------------------------------------------------------ -- * @Data.Time.LocalTime@ {-# INLINE utcToLocalTimeOfDay #-} utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) utcToLocalTimeOfDay = addMinutes . timeZoneMinutes {-# INLINE localToUTCTimeOfDay #-} localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) localToUTCTimeOfDay = addMinutes . negate . timeZoneMinutes {-# INLINE timeToTimeOfDay #-} timeToTimeOfDay :: DiffTime -> TimeOfDay timeToTimeOfDay = view timeOfDay {-# INLINE timeOfDayToTime #-} timeOfDayToTime :: TimeOfDay -> DiffTime timeOfDayToTime = review timeOfDay {-# INLINE dayFractionToTimeOfDay #-} dayFractionToTimeOfDay :: Rational -> TimeOfDay dayFractionToTimeOfDay = review dayFraction {-# INLINE timeOfDayToDayFraction #-} timeOfDayToDayFraction :: TimeOfDay -> Rational timeOfDayToDayFraction = view dayFraction {-# INLINE utcToLocalTime #-} utcToLocalTime :: TimeZone -> UTCTime -> LocalTime utcToLocalTime = view . utcLocalTime {-# INLINE localTimeToUTC #-} localTimeToUTC :: TimeZone -> LocalTime -> UTCTime localTimeToUTC = review . utcLocalTime {-# INLINE ut1ToLocalTime #-} ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime ut1ToLocalTime = view . ut1LocalTime {-# INLINE localTimeToUT1 #-} localTimeToUT1 :: Rational -> LocalTime -> UniversalTime localTimeToUT1 = review . ut1LocalTime {-# INLINE utcToZonedTime #-} utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime utcToZonedTime z t = view zonedTime (z, t) {-# INLINE zonedTimeToUTC #-} zonedTimeToUTC :: ZonedTime -> UTCTime zonedTimeToUTC = snd . review zonedTime thyme-0.3.5.5/lens/0000755000000000000000000000000012435525530012143 5ustar0000000000000000thyme-0.3.5.5/lens/Control/0000755000000000000000000000000012435525530013563 5ustar0000000000000000thyme-0.3.5.5/lens/Control/Lens.hs0000644000000000000000000000640012435525530015020 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} -- | Small replacement for . module Control.Lens ( (&) , Iso, Iso', iso , from , review, ( # ) , Lens, Lens', lens , view, (^.) , set, assign, (.=) ) where import Control.Applicative import Control.Monad.Identity import Control.Monad.State.Class as State import Data.Profunctor import Data.Profunctor.Unsafe import Unsafe.Coerce (&) :: a -> (a -> b) -> b a & f = f a {-# INLINE (&) #-} type Overloaded p f s t a b = p a (f b) -> p s (f t) ------------------------------------------------------------------------ type Iso s t a b = forall p f. (Profunctor p, Functor f) => Overloaded p f s t a b type Iso' s a = Iso s s a a iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) {-# INLINE iso #-} ------------------------------------------------------------------------ data Exchange a b s t = Exchange (s -> a) (b -> t) instance Profunctor (Exchange a b) where dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) {-# INLINE dimap #-} lmap f (Exchange sa bt) = Exchange (sa . f) bt {-# INLINE lmap #-} rmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE rmap #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} ( .# ) p _ = unsafeCoerce p {-# INLINE ( .# ) #-} type AnIso s t a b = Overloaded (Exchange a b) Identity s t a b from :: AnIso s t a b -> Iso b a t s from l = case l (Exchange id Identity) of Exchange sa bt -> iso (runIdentity #. bt) sa {-# INLINE from #-} ------------------------------------------------------------------------ newtype Reviewed a b = Reviewed { runReviewed :: b } deriving (Functor) instance Profunctor Reviewed where dimap _ f (Reviewed c) = Reviewed (f c) {-# INLINE dimap #-} lmap _ (Reviewed c) = Reviewed c {-# INLINE lmap #-} rmap = fmap {-# INLINE rmap #-} Reviewed b .# _ = Reviewed b {-# INLINE ( .# ) #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} type AReview s t a b = Overloaded Reviewed Identity s t a b review :: AReview s t a b -> b -> t review p = runIdentity #. runReviewed #. p .# Reviewed .# Identity {-# INLINE review #-} infixr 8 # ( # ) :: AReview s t a b -> b -> t ( # ) = review {-# INLINE ( # ) #-} ------------------------------------------------------------------------ type Lens s t a b = forall f. Functor f => Overloaded (->) f s t a b type Lens' s a = Lens s s a a lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} ------------------------------------------------------------------------ type Getting r s a = Overloaded (->) (Const r) s s a a view :: Getting a s a -> s -> a view l s = getConst (l Const s) {-# INLINE view #-} infixl 8 ^. (^.) :: s -> Getting a s a -> a (^.) = flip view {-# INLINE (^.) #-} ------------------------------------------------------------------------ type Setter s t a b = Overloaded (->) Identity s t a b set :: Setter s t a b -> b -> s -> t set l b = runIdentity #. l (\ _ -> Identity b) {-# INLINE set #-} assign :: (MonadState s m) => Setter s s a b -> b -> m () assign l b = State.modify (set l b) {-# INLINE assign #-} infix 4 .= (.=) :: (MonadState s m) => Setter s s a b -> b -> m () (.=) = assign {-# INLINE (.=) #-} thyme-0.3.5.5/tests/0000755000000000000000000000000012435525530012344 5ustar0000000000000000thyme-0.3.5.5/tests/hlint.hs0000644000000000000000000000067212435525530014023 0ustar0000000000000000module Main where import Control.Monad import Language.Haskell.HLint import System.Exit main :: IO () main = (`unless` exitFailure) . null =<< hlint [ "src", "tests" , "--cpp-define=HLINT=1" , "--cpp-include=include" , "--cpp-include=dist/build/autogen" , "--cpp-define=SHOW_INTERNAL=1" , "-i", "Reduce duplication" , "-i", "Redundant lambda" , "-i", "Use if" , "-i", "Use import/export shortcut" ] thyme-0.3.5.5/tests/rewrite.hs0000644000000000000000000000615712435525530014372 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #if HLINT #include "cabal_macros.h" #endif import Prelude #if !MIN_VERSION_base(4,6,0) hiding (catch) #endif import Control.Exception import Data.Int import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Thyme.Time import Distribution.PackageDescription import Distribution.Simple import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Setup import System.Directory import System.Exit import System.FilePath import System.Posix.Redirect import System.Random main :: IO () main = do defaultMainWithHooksArgs simpleUserHooks { buildHook = hook } [ "build", "--ghc-option=-ddump-rule-firings" ] useless {-# ANN hook ("HLint: ignore Evaluate" :: String) #-} {-# ANN hook ("HLint: ignore Use if" :: String) #-} hook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () hook pd lbi uh bf = do -- more reliable way to force a rebuild? removeDirectoryRecursive (buildDir lbi "rewrite" "rewrite-tmp") `catch` \ e -> return () `const` (e :: IOException) (err, (out, _)) <- redirectStderr . redirectStdout $ buildHook simpleUserHooks pd lbi uh bf let std = T.decodeUtf8 err `T.append` T.decodeUtf8 out let fired = foldr ( maybe id (flip (Map.insertWith (+)) (1 :: Int)) . T.stripPrefix "Rule fired: " ) Map.empty (T.lines std) let unmatched = wanted `Map.difference` fired case Map.null unmatched of True -> mapM_ print (Map.toList $ fired `Map.intersection` wanted) False -> do putStrLn "Unmatched rules:" mapM_ (T.putStrLn . T.append " ") (Map.keys unmatched) exitWith (ExitFailure 1) useless :: IO () useless = do print =<< (fmap fromSeconds (randomIO :: IO Float) :: IO DiffTime) print =<< (fmap fromSeconds (randomIO :: IO Double) :: IO NominalDiffTime) print =<< (fmap fromSeconds (randomIO :: IO Int) :: IO NominalDiffTime) print =<< (fmap fromSeconds (randomIO :: IO Int64) :: IO DiffTime) print =<< (fmap fromSeconds (randomIO :: IO Integer) :: IO DiffTime) print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO NominalDiffTime) print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO DiffTime) print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO Double) print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO Double) print =<< (fmap realToFrac (randomIO :: IO Float) :: IO NominalDiffTime) print =<< (fmap realToFrac (randomIO :: IO Integer) :: IO DiffTime) wanted :: Map Text () wanted = Map.fromList $ flip (,) () `fmap` [ "fromSeconds/Float" , "fromSeconds/Double" , "fromSeconds/Int" , "fromSeconds/Int64" , "fromSeconds/Integer" , "realToFrac/DiffTime-NominalDiffTime" , "realToFrac/NominalDiffTime-DiffTime" , "realToFrac/DiffTime-Fractional" , "realToFrac/NominalDiffTime-Fractional" , "realToFrac/Real-DiffTime" , "realToFrac/Real-NominalDiffTime" ] thyme-0.3.5.5/tests/sanity.hs0000644000000000000000000000562112435525530014213 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} #if HLINT #include "cabal_macros.h" #endif import Prelude import Control.Arrow import Control.Lens import qualified Data.Attoparsec.ByteString.Char8 as P import Data.ByteString (ByteString) import Data.Thyme import Data.Thyme.Time import qualified Data.Time as T import qualified Data.Time.Calendar.OrdinalDate as T import System.Locale import Test.QuickCheck import Common #if MIN_VERSION_bytestring(0,10,0) # if MIN_VERSION_bytestring(0,10,2) import qualified Data.ByteString.Builder as B # else import qualified Data.ByteString.Lazy.Builder as B # endif import qualified Data.ByteString.Lazy as L #else import qualified Data.Text as Text import qualified Data.Text.Encoding as Text #endif {-# INLINE utf8String #-} utf8String :: String -> ByteString #if MIN_VERSION_bytestring(0,10,0) utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8 #else utf8String = Text.encodeUtf8 . Text.pack #endif ------------------------------------------------------------------------ prop_ShowRead :: (Eq a, Show a, Read a) => a -> Bool prop_ShowRead a = (a, "") `elem` reads (show a) prop_toOrdinalDate :: Day -> Bool prop_toOrdinalDate day = fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day) prop_formatTime :: Spec -> RecentTime -> Property prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t')) #if MIN_VERSION_QuickCheck(2,7,0) = counterexample desc (s == s') where #else = printTestCase desc (s == s') where #endif s = formatTime defaultTimeLocale spec t s' = T.formatTime defaultTimeLocale spec t' desc = "thyme: " ++ s ++ "\ntime: " ++ s' prop_parseTime :: Spec -> RecentTime -> Property prop_parseTime (Spec spec) (RecentTime orig) #if MIN_VERSION_QuickCheck(2,7,0) = counterexample desc (fmap (review thyme) t == t') where #else = printTestCase desc (fmap (review thyme) t == t') where #endif s = T.formatTime defaultTimeLocale spec (thyme # orig) t = parseTime defaultTimeLocale spec s :: Maybe UTCTime t' = T.parseTime defaultTimeLocale spec s tp = P.parse (timeParser defaultTimeLocale spec) . utf8String desc = "input: " ++ show s ++ "\nthyme: " ++ show t ++ "\ntime: " ++ show t' ++ "\nstate: " ++ show (tp s) ------------------------------------------------------------------------ {-# ANN main "HLint: ignore Use list literal" #-} main :: IO () main = exit . all isSuccess =<< sequence [ qc 10000 (prop_ShowRead :: Day -> Bool) , qc 10000 (prop_ShowRead :: DiffTime -> Bool) , qc 10000 (prop_ShowRead :: NominalDiffTime -> Bool) , qc 10000 (prop_ShowRead :: UTCTime -> Bool) , qc 10000 prop_toOrdinalDate , qc 1000 prop_formatTime , qc 1000 prop_parseTime ] where isSuccess r = case r of Success {} -> True; _ -> False qc :: Testable prop => Int -> prop -> IO Result qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n} thyme-0.3.5.5/tests/bench.hs0000644000000000000000000001305412435525530013762 0ustar0000000000000000{-# LANGUAGE CPP #-} #if HLINT #include "cabal_macros.h" #endif import Prelude import Control.Arrow 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.Monoid import Data.Thyme import Data.Thyme.Calendar.OrdinalDate import Data.Thyme.Calendar.MonthDay import Data.Thyme.Time import qualified Data.Time as T import qualified Data.Time.Calendar.OrdinalDate as T import qualified Data.Time.Calendar.WeekDate as T import qualified Data.Time.Calendar.MonthDay as T import qualified Data.Time.Clock.POSIX as T import qualified Data.Vector as V import Test.QuickCheck as QC import Test.QuickCheck.Gen as QC #if MIN_VERSION_QuickCheck(2,7,0) import Test.QuickCheck.Random as QC #endif import System.Locale #if !MIN_VERSION_QuickCheck(2,7,0) import System.Random #endif import Text.Printf import Common {-# ANN main "HLint: ignore Use list literal" #-} main :: IO () main = do -- unboxed vectors made things a little too unfair for time utcs <- fmap V.fromList $ unGen (vectorOf samples arbitrary) #if MIN_VERSION_QuickCheck(2,7,0) <$> QC.newQCGen <*> pure 0 #else <$> newStdGen <*> pure 0 #endif let utcs' = review thyme <$> utcs now <- getCurrentTime let now' = thyme # now let strs = T.formatTime defaultTimeLocale spec <$> utcs' let dt = fromSeconds' 86405 let dt' = thyme # dt let days = utctDay . unUTCTime <$> utcs let days' = T.utctDay <$> utcs' let years = view (gregorian . _ymdYear) <$> days let years' = (\ (y, _m, _d) -> y) . T.toGregorian <$> days' let mons = ((isLeapYear . ymdYear) &&& ymdMonth) . view gregorian <$> days let yyds = (odYear &&& odDay) . view ordinalDate <$> days let yyds' = ((fromIntegral . odYear) &&& odDay) . view ordinalDate <$> days let ords = ((isLeapYear . odYear) &&& odDay) . view ordinalDate <$> days let pxs = utcTimeToPOSIXSeconds <$> utcs let pxs' = T.utcTimeToPOSIXSeconds <$> utcs' let config = defaultConfig {cfgVerbosity = Last (Just Quiet)} (exit . and <=< withConfig config) $ do env <- measureEnvironment ns <- getConfigItem $ fromLJ cfgResamples mapM (benchMean env ns) $ -- Calendar ( "addDays", 1.0 , nf (addDays 28 <$>) days , nf (T.addDays 28 <$>) days' ) : ( "toOrdinalDate", 2.7 , nf (toOrdinalDate <$>) days , nf (T.toOrdinalDate <$>) days' ) : ( "fromOrdinalDate", 2.0 , nf (uncurry fromOrdinalDate <$>) yyds , nf (uncurry T.fromOrdinalDate <$>) yyds' ) : ( "toGregorian", 4.3 , nf (toGregorian <$>) days , nf (T.toGregorian <$>) days' ) : ( "showGregorian", 3.8 , nf (showGregorian <$>) days , nf (T.showGregorian <$>) days' ) : ( "toWeekDate", 2.5 , nf (toWeekDate <$>) days , nf (T.toWeekDate <$>) days' ) : ( "monthLength", 1.8 , nf (uncurry monthLength <$>) mons , nf (uncurry T.monthLength <$>) mons ) : ( "dayOfYearToMonthAndDay", 4.3 , nf (uncurry dayOfYearToMonthAndDay <$>) ords , nf (uncurry T.dayOfYearToMonthAndDay <$>) ords ) : ( "isLeapYear", 1.5 , nf (isLeapYear <$>) years , nf (T.isLeapYear <$>) years' ) : -- Clock ( "addUTCTime", 85 , nf (addUTCTime dt <$>) utcs , nf (T.addUTCTime dt' <$>) utcs' ) : ( "diffUTCTime", 22 , nf (diffUTCTime now <$>) utcs , nf (T.diffUTCTime now' <$>) utcs' ) : ( "utcTimeToPOSIXSeconds", 10 , nf (utcTimeToPOSIXSeconds <$>) utcs , nf (T.utcTimeToPOSIXSeconds <$>) utcs' ) : -- toSeconds ( "toSeconds", 45 , nf ((toSeconds :: NominalDiffTime -> Double) <$>) pxs , nf ((realToFrac :: T.NominalDiffTime -> Double) <$>) pxs' ) : -- LocalTime ( "timeToTimeOfDay", 40 , nf (timeToTimeOfDay <$>) (utctDayTime . unUTCTime <$> utcs) , nf (T.timeToTimeOfDay <$>) (T.utctDayTime <$> utcs') ) : ( "utcToLocalTime", 22 , nf (utcToLocalTime utc <$>) utcs , nf (T.utcToLocalTime T.utc <$>) utcs' ) : -- Format ( "formatTime", 7.5 , nf (formatTime defaultTimeLocale spec <$>) utcs , nf (T.formatTime defaultTimeLocale spec <$>) utcs' ) : ( "parseTime", 5.2 , nf (parse <$>) strs , nf (parse' <$>) strs ) : [] where samples = 32 spec = "%F %G %V %u %j %T %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 "%-23s: %6.1fns, %5.1f×; expected %4.1f× : %+3.0f%% %s\n" name (ours * 1000000000 / fromIntegral samples) ratio expected ((ratio / expected - 1) * 100) (if ratio >= expected then "OK." else "oh noes. D:") return (ratio >= expected) thyme-0.3.5.5/tests/Common.hs0000644000000000000000000000515112435525530014132 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Common where import Prelude import Control.Applicative import Control.Lens import Data.AdditiveGroup import Data.Char import Data.Thyme import Data.Thyme.Clock.POSIX import System.Exit import Test.QuickCheck import qualified Test.QuickCheck.Gen as Gen exit :: Bool -> IO () exit b = exitWith $ if b then ExitSuccess else ExitFailure 1 ------------------------------------------------------------------------ -- FIXME: We disagree with time on how many digits to use for year. newtype RecentTime = RecentTime UTCTime deriving (Show) instance Arbitrary RecentTime where arbitrary = fmap (RecentTime . review utcTime) $ UTCTime <$> choose (minDay, maxDay) <*> choose (zeroV, pred dayLength) where minDay = gregorian # YearMonthDay 1000 1 1 maxDay = gregorian # YearMonthDay 9999 12 13 dayLength = posixDayLength ^. microseconds . from microseconds ------------------------------------------------------------------------ newtype Spec = Spec String deriving (Show) instance Arbitrary Spec where arbitrary = do -- Pick a non-overlapping day spec generator. day <- Gen.elements [ spec {-YearMonthDay-}"DFYyCBbhmde" , spec {-OrdinalDate-}"YyCj" -- TODO: time only consider the presence of %V as -- indication that it should parse as WeekDate , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa" , spec {-SundayWeek-}"YyCUuwAa" , spec {-MondayWeek-}"YyCWuwAa" ] :: Gen (Gen String) -- Pick a non-overlapping day & tod spec generator. time <- Gen.frequency [ (16, pure $ Gen.frequency [ (8, day) , (4, rod) , (2, h12) , (1, sec) , (1, spec {-TimeZone-}"zZ") ] ) -- TODO: these are broken due to issues above and below -- , (2, pure $ spec {-aggregate-}"crXx") , (1, pure $ spec {-UTCTime-}"s") ] :: Gen (Gen String) fmap (Spec . dropWhile isSpace . unwords) . listOf1 $ frequency [(16, time), (4, string), (1, pure "%%")] where spec = Gen.elements . fmap (\ c -> ['%', c]) string = filter ('%' /=) <$> arbitrary -- TODO: time discards %q %Q or %p %P after setting %S or hours -- respectively. Fudge it by always including %q and %p at end. -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ" rod = spec {-RestOfDay-}"RHkMqQ" sec = (++ " %q") <$> spec {-seconds-}"ST" h12 = (++ " %p") <$> spec {-12-hour-}"Il" thyme-0.3.5.5/include/0000755000000000000000000000000012435525530012625 5ustar0000000000000000thyme-0.3.5.5/include/thyme.h0000644000000000000000000000053612435525530014130 0ustar0000000000000000#define INSTANCES_USUAL Eq, Ord, Data, Typeable, Generic #define INSTANCES_NEWTYPE INSTANCES_USUAL, Enum, Ix, NFData #define INSTANCES_MICRO INSTANCES_NEWTYPE, Bounded, Random, Arbitrary, CoArbitrary #define LensP Lens' #define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \ S {..} F/**/_ -> S {F = F/**/_, ..}