thyme 0.3.5.5 → 0.3.6
raw patch · 33 files changed
+6451/−4262 lines, 33 filesdep +ghc-primdep +hashabledep +integer-gmpdep −Cabaldep −directorydep −filepathdep ~containersdep ~textsetup-changednew-uploader
Dependencies added: ghc-prim, hashable, integer-gmp, template-haskell
Dependencies removed: Cabal, directory, filepath, system-posix-redirect
Dependency ranges changed: containers, text
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−30
- README.md +32/−0
- Setup.hs +2/−2
- include/thyme.h +7/−5
- lens/Control/Lens.hs +156/−127
- src/Data/Thyme.hs +12/−37
- src/Data/Thyme/Calendar.hs +267/−109
- src/Data/Thyme/Calendar/Internal.hs +750/−486
- src/Data/Thyme/Calendar/MonthDay.hs +63/−19
- src/Data/Thyme/Calendar/OrdinalDate.hs +170/−46
- src/Data/Thyme/Calendar/WeekDate.hs +123/−91
- src/Data/Thyme/Calendar/WeekdayOfMonth.hs +148/−109
- src/Data/Thyme/Clock.hs +203/−56
- src/Data/Thyme/Clock/Internal.hs +434/−304
- src/Data/Thyme/Clock/POSIX.hsc +108/−66
- src/Data/Thyme/Clock/TAI.hs +357/−150
- src/Data/Thyme/Docs.hs +357/−0
- src/Data/Thyme/Format.hs +989/−726
- src/Data/Thyme/Format/Aeson.hs +108/−102
- src/Data/Thyme/Format/Human.hs +94/−87
- src/Data/Thyme/Format/Internal.hs +147/−147
- src/Data/Thyme/Internal/Micro.hs +107/−106
- src/Data/Thyme/LocalTime.hs +671/−381
- src/Data/Thyme/Time.hs +78/−102
- src/Data/Thyme/Time/Core.hs +155/−343
- src/Data/Thyme/TrueName.hs +423/−0
- tests/Common.hs +78/−71
- tests/bench.hs +2/−166
- tests/hlint.hs +19/−19
- tests/rewrite.hs +58/−87
- tests/sanity.hs +98/−93
- thyme.cabal +202/−195
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+### 0.3.6 + +* Supported GHC 9 and older
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2013, Liyang HU--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Liyang HU nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2013, Liyang HU + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Liyang HU nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,32 @@+# thyme + +[][travis] [Hackage][] + +A faster date and time library based on [time][]. + +* Trades speed for slightly less precision: micro- (μs; 10<sup>-6</sup>) + versus pico-seconds (ps; 10<sup>-12</sup>). +* Better type-safety for date and time arithmetic. +* Ships with a selection of [Iso'][]s and [Lens'][]s for [lens][]. + +## Building + +### Library + +``` +stack build --flag thyme:lens +``` + +### Haddock + +``` +stack haddock --flag thyme:lens +``` + +[Hackage]: http://hackage.haskell.org/package/thyme +[Iso']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Iso.html#t:Iso-39- +[Lens']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens-39- +[lens]: http://hackage.haskell.org/package/lens +[time]: http://hackage.haskell.org/package/time +[travis]: https://travis-ci.org/liyang/thyme +
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
include/thyme.h view
@@ -1,5 +1,7 @@-#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/**/_, ..}+#define INSTANCES_USUAL Eq, Ord, Data, Typeable, Generic +#define INSTANCES_NEWTYPE INSTANCES_USUAL, Enum, Ix, Hashable, 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/**/_, ..} + +#define W_GREGORIAN <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian>
lens/Control/Lens.hs view
@@ -1,127 +1,156 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RankNTypes #-}---- | Small replacement for <http://hackage.haskell.org/package/lens lens>.-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 (.=) #-}-+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if HLINT +#include "cabal_macros.h" +#endif + +-- | Small replacement for <http://hackage.haskell.org/package/lens lens>. +module Control.Lens + ( (&) + , Iso, Iso', iso + , from + , review, ( # ) + , Lens, Lens', lens + , view, (^.) + , set, over, (%~), assign, (.=) + ) where + +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.State.Class as State +import Data.Profunctor +import Data.Profunctor.Unsafe +#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0) +import Data.Coerce +#else +import Unsafe.Coerce +#endif + +infixl 1 & +(&) :: 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 #-} +#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0) + ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t + ( .# ) p _ = coerce p +#else + ( #. ) _ = unsafeCoerce + ( .# ) p _ = unsafeCoerce p +#endif + {-# INLINE ( #. ) #-} + {-# 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 ( .# ) #-} +#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0) + ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t +#else + ( #. ) _ = unsafeCoerce +#endif + {-# 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 #-} + +over :: Setter s t a b -> (a -> b) -> s -> t +over l f = runIdentity #. l (Identity #. f) +{-# INLINE over #-} + +infixr 4 %~ +(%~) :: Setter s t a b -> (a -> b) -> s -> t +(%~) = over +{-# INLINE (%~) #-} + +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 (.=) #-} +
src/Data/Thyme.hs view
@@ -1,37 +1,12 @@--- | 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--- <http://hackage.haskell.org/package/lens lens> package, while--- 'Data.AdditiveGroup.AdditiveGroup', 'Data.VectorSpace.VectorSpace' and--- 'Data.AffineSpace.AffineSpace' from--- <http://hackage.haskell.org/package/vector-space vector-space> 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--- <http://hackage.haskell.org/package/enummapset-th>. 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-+-- | This simply re-exports some commonly-used modules. +module Data.Thyme + ( module Data.Thyme.Calendar + , module Data.Thyme.Clock + , module Data.Thyme.Format + , module Data.Thyme.LocalTime + ) where + +import Data.Thyme.Calendar +import Data.Thyme.Clock +import Data.Thyme.Format +import Data.Thyme.LocalTime
src/Data/Thyme/Calendar.hs view
@@ -1,109 +1,267 @@-{-# 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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "thyme.h" +#if HLINT +#include "cabal_macros.h" +#endif + +-- | Calendar calculations. +-- +-- Note that '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 + ( + -- * Day + Day (..), modifiedJulianDay + + -- * Calendar + , Year, Month, DayOfMonth + , YearMonthDay (..), _ymdYear, _ymdMonth, _ymdDay + , Years, Months, Days + + -- * Gregorian calendar + -- $proleptic + , isLeapYear + , yearMonthDay, gregorian, gregorianValid, showGregorian + , module Data.Thyme.Calendar + ) where + +import Prelude hiding ((.)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Arrow +import Control.Category +import Control.Lens +import Control.Monad +import Data.AdditiveGroup +import Data.AffineSpace +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 day = utcTime # UTCView day 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 + +------------------------------------------------------------------------ + +-- $proleptic +-- +-- Note that using the +-- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar for +-- dates before its adoption (from 1582 onwards, but varies from one country +-- to the next) produces +-- <https://en.wikipedia.org/wiki/Gregorian_calendar#Proleptic_Gregorian_calendar a proleptic calendar>, +-- which may cause some confusion. + +-- | The number of days in a given month in the +-- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar. +-- +-- @ +-- > 'gregorianMonthLength' 2005 2 +-- 28 +-- @ +{-# INLINE gregorianMonthLength #-} +gregorianMonthLength :: Year -> Month -> Days +gregorianMonthLength = monthLength . isLeapYear + +-- | Add months, with days past the last day of the month clipped to the +-- last day. +-- +-- See also 'addGregorianMonthsClip'. +-- +-- @ +-- > 'gregorianMonthsClip' 1 '$' 'YearMonthDay' 2005 1 30 +-- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 2, 'ymdDay' = 28} +-- @ +{-# 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 + +-- | Add months, with days past the last day of the month rolling over to +-- the next month. +-- +-- See also 'addGregorianMonthsRollover'. +-- +-- @ +-- > 'gregorianMonthsRollover' 1 $ 'YearMonthDay' 2005 1 30 +-- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 3, 'ymdDay' = 2} +-- @ +{-# 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' + +-- | Add years, matching month and day, with /February 29th/ clipped to the +-- /28th/ if necessary. +-- +-- See also 'addGregorianYearsClip'. +-- +-- @ +-- > 'gregorianYearsClip' 2 $ 'YearMonthDay' 2004 2 29 +-- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 2, 'ymdDay' = 28} +-- @ +{-# 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 + +-- | Add years, matching month and day, with /February 29th/ rolled over to +-- /March 1st/ if necessary. +-- +-- See also 'addGregorianYearsRollover'. +-- +-- @ +-- > 'gregorianYearsRollover' 2 $ 'YearMonthDay' 2004 2 29 +-- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 3, 'ymdDay' = 1} +-- @ +{-# 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 + +-- * Compatibility + +-- | Add some 'Days' to a calendar 'Day' to get a new 'Day'. +-- +-- @ +-- 'addDays' = 'flip' ('.+^') +-- 'addDays' n d ≡ d '.+^' n +-- @ +-- +-- See also the 'AffineSpace' instance for 'Day'. +{-# INLINE addDays #-} +addDays :: Days -> Day -> Day +addDays = flip (.+^) + +-- | Subtract two calendar 'Day's for the difference in 'Days'. +-- +-- @ +-- 'diffDays' = ('.-.') +-- 'diffDays' a b = a '.-.' b +-- @ +-- +-- See also the 'AffineSpace' instance for 'Day'. +{-# INLINE diffDays #-} +diffDays :: Day -> Day -> Days +diffDays = (.-.) + +-- | Convert a 'Day' to its Gregorian 'Year', 'Month', and 'DayOfMonth'. +-- +-- @ +-- 'toGregorian' ('view' 'gregorian' -> 'YearMonthDay' y m d) = (y, m, d) +-- @ +{-# INLINE toGregorian #-} +toGregorian :: Day -> (Year, Month, DayOfMonth) +toGregorian (view gregorian -> YearMonthDay y m d) = (y, m, d) + +-- | Construct a 'Day' from a Gregorian calendar date. +-- Does not validate the input. +-- +-- @ +-- 'fromGregorian' y m d = 'gregorian' 'Control.Lens.#' 'YearMonthDay' y m d +-- @ +{-# INLINE fromGregorian #-} +fromGregorian :: Year -> Month -> DayOfMonth -> Day +fromGregorian y m d = gregorian # YearMonthDay y m d + +-- | Construct a 'Day' from a Gregorian calendar date. +-- Returns 'Nothing' for invalid input. +-- +-- @ +-- 'fromGregorianValid' y m d = 'gregorianValid' ('YearMonthDay' y m d) +-- @ +{-# INLINE fromGregorianValid #-} +fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day +fromGregorianValid y m d = gregorianValid (YearMonthDay y m d) + +-- | Add some number of 'Months' to the given 'Day'; if the original +-- 'DayOfMonth' exceeds that of the new 'Month', it will be clipped to the +-- last day of the new 'Month'. +-- +-- @ +-- 'addGregorianMonthsClip' n = 'gregorian' '%~' 'gregorianMonthsClip' n +-- @ +{-# INLINE addGregorianMonthsClip #-} +addGregorianMonthsClip :: Months -> Day -> Day +addGregorianMonthsClip n = gregorian %~ gregorianMonthsClip n + +-- | Add some number of 'Months' to the given 'Day'; if the original +-- 'DayOfMonth' exceeds that of the new 'Month', it will be rolled over into +-- the following 'Month'. +-- +-- @ +-- 'addGregorianMonthsRollover' n = 'gregorian' '%~' 'gregorianMonthsRollover' n +-- @ +{-# INLINE addGregorianMonthsRollover #-} +addGregorianMonthsRollover :: Months -> Day -> Day +addGregorianMonthsRollover n = gregorian %~ gregorianMonthsRollover n + +-- | Add some number of 'Years' to the given 'Day', with /February 29th/ +-- clipped to /February 28th/ if necessary. +-- +-- @ +-- 'addGregorianYearsClip' n = 'gregorian' '%~' 'gregorianYearsClip' n +-- @ +{-# INLINE addGregorianYearsClip #-} +addGregorianYearsClip :: Years -> Day -> Day +addGregorianYearsClip n = gregorian %~ gregorianYearsClip n + +-- | Add some number of 'Years' to the given 'Day', with /February 29th/ +-- rolled over to /March 1st/ if necessary. +-- +-- @ +-- 'addGregorianYearsRollover' n = 'gregorian' '%~' 'gregorianYearsRollover' n +-- @ +{-# INLINE addGregorianYearsRollover #-} +addGregorianYearsRollover :: Years -> Day -> Day +addGregorianYearsRollover n = gregorian %~ gregorianYearsRollover n +
src/Data/Thyme/Calendar/Internal.hs view
@@ -1,486 +1,750 @@-{-# 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) |]-+{-# 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" +#if HLINT +#include "cabal_macros.h" +#endif + +module Data.Thyme.Calendar.Internal where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Arrow +import Control.DeepSeq +import Control.Lens +import Control.Monad +import Data.AffineSpace +import Data.Bits +import Data.Data +import Data.Hashable +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 ((.&.)) + +-- | A duration/count of years. +type Years = Int + +-- | A duration/count of months. +type Months = Int + +-- | A duration/count of days. +type Days = Int + +-- | A calendar-agnostic day, internally represented as a count of days +-- since /1858-11-17/, the +-- <https://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day> +-- (MJD) epoch. +-- +-- To convert a 'Day' to the corresponding 'YearMonthDay' in the W_GREGORIAN +-- calendar, see 'gregorian'. +-- +-- @ +-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 +-- 2016-03-01 +-- @ +-- +-- 'Day' is an instance of 'AffineSpace' where @'Diff' 'Day' = 'Days'@, so +-- arithmetic on 'Day' and 'Days' can be performed with the '.-.', '.+^', +-- and '.-^' operators. +-- +-- @ +-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-.' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 2 1 +-- 29 +-- @ +-- +-- @ +-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-^' 1 +-- 2016-02-29 +-- @ +-- +-- Other ways of viewing a 'Day' include 'ordinalDate', and 'weekDate'. +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) + +-- | Convert between a 'Day' and the corresponding count of days from +-- 1858-11-17, the MJD epoch. +-- +-- @ +-- 'modifiedJulianDay' = 'iso' 'toModifiedJulianDay' 'ModifiedJulianDay' +-- @ +-- +-- @ +-- > 'modifiedJulianDay' 'Control.Lens.#' 0 +-- 1858-11-17 +-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '&' 'modifiedJulianDay' '%~' 'subtract' 1 +-- 2016-02-29 +-- @ +{-# INLINE modifiedJulianDay #-} +modifiedJulianDay :: Iso' Day Int +modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay + +-- | Conversion between a W_GREGORIAN 'OrdinalDate' and the corresponding +-- 'YearMonthDay'. +-- +-- @ +-- > 'OrdinalDate' 2016 32 '^.' 'yearMonthDay' +-- 'YearMonthDay' {ymdYear = 2016, ymdMonth = 2, ymdDay = 1} +-- @ +-- +-- @ +-- > 'yearMonthDay' 'Control.Lens.#' 'YearMonthDay' 2016 2 1 +-- 'OrdinalDate' {odYear = 2016, odDay = 32} +-- @ +{-# 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 + +-- | Conversion between a 'Day' and its 'YearMonthDay'. +-- +-- @ +-- 'gregorian' = 'ordinalDate' . 'yearMonthDay' +-- @ +-- +-- @ +-- > 'ModifiedJulianDay' 0 '^.' 'gregorian' +-- 'YearMonthDay' {ymdYear = 1858, ymdMonth = 11, ymdDay = 17} +-- @ +-- +-- @ +-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 1858 11 17 +-- 1858-11-17 +-- @ +{-# INLINE gregorian #-} +gregorian :: Iso' Day YearMonthDay +gregorian = ordinalDate . yearMonthDay + +-- | Conversion between a 'YearMonthDay' and the corresponding 'Day'. +-- Returns 'Nothing' for invalid input. +-- +-- @ +-- > 'gregorianValid' ('YearMonthDay' 2015 2 28) +-- 'Just' 2015-02-28 +-- @ +-- +-- @ +-- > 'gregorianValid' ('YearMonthDay' 2015 2 29) +-- 'Nothing' +-- @ +{-# INLINEABLE gregorianValid #-} +gregorianValid :: YearMonthDay -> Maybe Day +gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y + <$> monthDayValid (isLeapYear y) (MonthDay m d) + +-- | Shows a 'Day' in +-- <https://en.wikipedia.org/wiki/ISO_8601#Calendar_dates ISO 8601> +-- /YYYY-MM-DD/ format. +-- +-- See "Data.Thyme.Format" for other possibilities. +{-# 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 + +------------------------------------------------------------------------ + +-- | Calendar year. +type Year = Int + +-- | Calendar month. /January = 1/ +type Month = Int + +-- | Calendar day-of-month, starting from /1/. +type DayOfMonth = Int + +-- | A strict triple of a 'Year', a 'Day', and a 'Month'. +data YearMonthDay = YearMonthDay + { ymdYear :: {-# UNPACK #-}!Year + , ymdMonth :: {-# UNPACK #-}!Month + , ymdDay :: {-# UNPACK #-}!DayOfMonth + } deriving (INSTANCES_USUAL, Show) + +LENS(YearMonthDay,ymdYear,Year) +LENS(YearMonthDay,ymdMonth,Month) +LENS(YearMonthDay,ymdDay,DayOfMonth) + +instance Hashable YearMonthDay +instance NFData YearMonthDay + +------------------------------------------------------------------------ + +-- | Is it a leap year according to the W_GREGORIAN calendar? +isLeapYear :: Year -> Bool +isLeapYear y = y .&. 3 == 0 && (r100 /= 0 || q100 .&. 3 == 0) where + (q100, r100) = y `quotRem` 100 + +-- | The day of the year, with /1 = January 1st/. +type DayOfYear = Int + +-- | An +-- <https://en.wikipedia.org/wiki/ISO_8601#Ordinal_dates ISO 8601 ordinal date>. +data OrdinalDate = OrdinalDate + { odYear :: {-# UNPACK #-}!Year + , odDay :: {-# UNPACK #-}!DayOfYear + } deriving (INSTANCES_USUAL, Show) + +LENS(OrdinalDate,odYear,Year) +LENS(OrdinalDate,odDay,DayOfYear) + +instance Hashable OrdinalDate +instance NFData OrdinalDate + +-- | Conversion between the MJD 'Day' and 'OrdinalDate'. +-- +-- @ +-- > 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32 +-- 2016-02-01 +-- @ +-- +-- @ +-- > 'toModifiedJulianDay' $ 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32 +-- 57419 +-- @ +-- +-- @ +-- > 'ModifiedJulianDay' 57419 '^.' 'ordinalDate' +-- 'OrdinalDate' {odYear = 2016, odDay = 32} +-- @ +{-# INLINE ordinalDate #-} +ordinalDate :: Iso' Day OrdinalDate +ordinalDate = iso toOrd fromOrd where + +-- Brief description of the toOrd computation +-- +-- The length of the years in the 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: +-- +-- * The 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 +-- on 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 /0001-01-01/). For earlier dates we translate by an +-- integral number of /400/ year periods, do the computation and +-- translate back. + + {-# 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 0001-01-01. 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 0001-01-01) + -- 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) + +------------------------------------------------------------------------ + +-- | A strict pair of a 'Month' and a 'DayOfMonth'. +data MonthDay = MonthDay + { mdMonth :: {-# UNPACK #-}!Month + , mdDay :: {-# UNPACK #-}!DayOfMonth + } deriving (INSTANCES_USUAL, Show) + +LENS(MonthDay,mdMonth,Month) +LENS(MonthDay,mdDay,DayOfMonth) + +instance Hashable MonthDay +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 + +-- | Predicated on whether or not it's a leap year, convert between an +-- ordinal 'DayOfYear' and the corresponding 'Month' and 'DayOfMonth'. +-- +-- @ +-- > 60 '^.' 'monthDay' ('isLeapYear' 2015) +-- 'MonthDay' {'mdMonth' = 3, 'mdDay' = 1} +-- @ +-- +-- @ +-- > 60 '^.' 'monthDay' ('isLeapYear' 2016) +-- 'MonthDay' {'mdMonth' = 2, 'mdDay' = 29} +-- @ +-- +-- @ +-- > 'monthDay' ('isLeapYear' 2016) 'Control.Lens.#' 'MonthDay' 2 29 +-- 60 +-- @ +-- +-- @ +-- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 28 +-- 59 +-- @ +-- +-- Note that 'monthDay' is an improper 'Iso', as the following example +-- shows. To handle this case correctly, use 'monthDayValid'. +-- +-- @ +-- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 29 +-- 59 +-- @ +{-# INLINE monthDay #-} +monthDay + :: Bool -- ^ 'isLeapYear'? + -> 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 + +-- | Predicated on whether or not it's a leap year, convert a 'MonthDay' to +-- an ordinal 'DayOfYear'. +-- +-- @ +-- > 'monthDayValid' ('isLeapYear' 2016) ('MonthDay' 2 29) +-- 'Just' 60 +-- @ +-- +-- @ +-- > 'monthDayValid' ('isLeapYear' 2015) ('MonthDay' 2 29) +-- 'Nothing' +-- @ +{-# INLINEABLE monthDayValid #-} +monthDayValid + :: Bool -- ^ 'isLeapYear'? + -> MonthDay + -> Maybe DayOfYear +monthDayValid leap md@(MonthDay m d) = monthDay leap # md + <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m) + +-- | Predicated on whether or not the year is a leap year, return the number +-- of 'Days' in the given 'Month'. +-- +-- @ +-- > monthLength ('isLeapYear' 2015) 2 +-- 28 +-- @ +-- +-- @ +-- > monthLength ('isLeapYear' 2016) 2 +-- 29 +-- @ +{-# INLINEABLE monthLength #-} +monthLength + :: Bool -- ^ 'isLeapYear'? + -> Month + -> Days +monthLength leap = VU.unsafeIndex ls . max 0 . min 11 . pred where + ls = if leap then monthLengthsLeap else monthLengths + +------------------------------------------------------------------------ + +-- | Week of the year. +-- +-- Meaning of values depends on context; see 'wdWeek', 'swWeek', 'mwWeek'. +type WeekOfYear = Int + +-- | Day of the week. +-- +-- [/0/] /Sunday/ for 'SundayWeek' +-- +-- [/1/…/6/] /Monday/…/Saturday/ +-- +-- [/7/] /Sunday/ for 'WeekDate', 'MondayWeek', and 'Data.Thyme.Calendar.WeekdayOfMonth.WeekdayOfMonth' +type DayOfWeek = Int + +-- | <https://en.wikipedia.org/wiki/ISO_week_date ISO 8601 Week Date>. +-- +-- Note that week /01/ is defined as the week with the first Thursday, thus +-- 'wdYear' may differ from the Gregorian year between /December 29th/ and +-- /January 3rd/. +data WeekDate = WeekDate + { wdYear :: {-# UNPACK #-}!Year + , wdWeek :: {-# UNPACK #-}!WeekOfYear + -- ^ Numbered /01/ to /53/. Days before week /01/ are considered to + -- belong to the previous year. + , wdDay :: {-# UNPACK #-}!DayOfWeek + -- ^ /1 = Monday/ … /7 = Sunday/. + } deriving (INSTANCES_USUAL, Show) + +LENS(WeekDate,wdYear,Year) +LENS(WeekDate,wdWeek,WeekOfYear) +LENS(WeekDate,wdDay,DayOfWeek) + +instance Hashable WeekDate +instance NFData WeekDate + +-- | Convert between a 'Day' and an ISO 8601 'WeekDate'. +-- +-- @ +-- > 'YearMonthDay' 2016 1 1 '^.' 'from' 'gregorian' '.' 'weekDate' +-- 'WeekDate' {'wdYear' = 2015, 'wdWeek' = 53, 'wdDay' = 5} +-- @ +{-# 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 + +-- | Convert a 'WeekDate' to a 'Day', or 'Nothing' for invalid 'WeekDate'. +{-# 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) + +-- | Shows a 'Day' using the @yyyy-Www-d@ ISO 8601 Week Date format. +-- +-- @ +-- > 'showWeekDate' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2006 11 15) +-- "2006-W46-3" +-- @ +{-# INLINEABLE showWeekDate #-} +showWeekDate :: Day -> String +showWeekDate (view weekDate -> WeekDate y w d) = + showsYear y . (++) "-W" . shows02 w . (:) '-' $ show d + +------------------------------------------------------------------------ + +-- | Week-based calendar date with the first /Sunday/ of the year as the first +-- day of week /01/. This corresponds to @%U@ and @%w@ of +-- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@. +-- +-- The final week of a given year and week /00/ of the next both refer to +-- the same week. +data SundayWeek = SundayWeek + { swYear :: {-# UNPACK #-}!Year + -- ^ Coincides with that of 'gregorian'. + , swWeek :: {-# UNPACK #-}!WeekOfYear + -- ^ Weeks numbered from /00/ to /53/, starting with the first + -- /Sunday/ of the year as the first day of week /01/. + , swDay :: {-# UNPACK #-}!DayOfWeek + -- ^ /0 = Sunday/. + } deriving (INSTANCES_USUAL, Show) + +LENS(SundayWeek,swYear,Year) +LENS(SundayWeek,swWeek,WeekOfYear) +LENS(SundayWeek,swDay,DayOfWeek) + +instance Hashable SundayWeek +instance NFData SundayWeek + +-- | Conversion between 'Day' and 'SundayWeek'. +-- +-- @ +-- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'sundayWeek' +-- 'SundayWeek' {'swYear' = 2016, 'swWeek' = 1, 'swDay' = 0} +-- @ +{-# 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 + +-- | Convert a 'SundayWeek' to a 'Day', or 'Nothing' for invalid 'SundayWeek'. +{-# 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 + +------------------------------------------------------------------------ + +-- | Week-based calendar date with the first /Monday/ of the year as the first +-- day of week /01/. This corresponds to @%W@ and @%u@ of +-- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@. +-- +-- The final week of a given year and week /00/ of the next both refer to +-- the same week. +data MondayWeek = MondayWeek + { mwYear :: {-# UNPACK #-}!Year + -- ^ Coincides with that of 'gregorian'. + , mwWeek :: {-# UNPACK #-}!WeekOfYear + -- ^ Weeks numbered from /00/ to /53/, starting with the first + -- /Monday/ of the year as the first day of week /01/. + , mwDay :: {-# UNPACK #-}!DayOfWeek + -- ^ /7 = Sunday/. + } deriving (INSTANCES_USUAL, Show) + +LENS(MondayWeek,mwYear,Year) +LENS(MondayWeek,mwWeek,WeekOfYear) +LENS(MondayWeek,mwDay,DayOfWeek) + +instance Hashable MondayWeek +instance NFData MondayWeek + +-- | Conversion between 'Day' and 'MondayWeek'. +-- +-- @ +-- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'mondayWeek' +-- 'MondayWeek' {'mwYear' = 2016, 'mwWeek' = 0, 'mwDay' = 7} +-- @ +{-# 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 + +-- | Convert a 'MondayWeek' to a 'Day', or 'Nothing' for invalid 'MondayWeek'. +{-# 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) |] +
src/Data/Thyme/Calendar/MonthDay.hs view
@@ -1,19 +1,63 @@-{-# 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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +#include "thyme.h" + +-- | Calendar months and day-of-months. +module Data.Thyme.Calendar.MonthDay + ( Month, DayOfMonth + , MonthDay (..), _mdMonth, _mdDay + , monthDay, monthDayValid, monthLength + , module Data.Thyme.Calendar.MonthDay + ) where + +import Prelude +import Control.Lens +import Data.Thyme.Calendar.Internal + +-- * Compatibility + +-- | Predicated on whether or not it is a leap year, convert an ordinal +-- 'DayOfYear' to its corresponding 'Month' and 'DayOfMonth'. +-- +-- @ +-- 'dayOfYearToMonthAndDay' leap ('view' ('monthDay' leap) -> 'MonthDay' m d) = (m, d) +-- @ +{-# INLINE dayOfYearToMonthAndDay #-} +dayOfYearToMonthAndDay + :: Bool -- ^ 'isLeapYear'? + -> DayOfYear + -> (Month, DayOfMonth) +dayOfYearToMonthAndDay leap (view (monthDay leap) -> MonthDay m d) = (m, d) + +-- | Predicated on whether or not it is a leap year, convert a 'Month' and +-- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'. +-- Does not validate the input. +-- +-- @ +-- 'monthAndDayToDayOfYear' leap m d = 'monthDay' leap 'Control.Lens.#' 'MonthDay' m d +-- @ +{-# INLINE monthAndDayToDayOfYear #-} +monthAndDayToDayOfYear + :: Bool -- ^ 'isLeapYear'? + -> Month + -> DayOfMonth + -> DayOfYear +monthAndDayToDayOfYear leap m d = monthDay leap # MonthDay m d + +-- | Predicated on whether or not it is a leap year, convert a 'Month' and +-- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'. +-- Returns 'Nothing' for invalid input. +-- +-- @ +-- 'monthAndDayToDayOfYearValid' leap m d = 'monthDayValid' leap ('MonthDay' m d) +-- @ +{-# INLINE monthAndDayToDayOfYearValid #-} +monthAndDayToDayOfYearValid + :: Bool -- ^ 'isLeapYear'? + -> Month + -> DayOfMonth + -> Maybe DayOfYear +monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d) +
src/Data/Thyme/Calendar/OrdinalDate.hs view
@@ -1,46 +1,170 @@-{-# 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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "thyme.h" +#if HLINT +#include "cabal_macros.h" +#endif + +-- | ISO 8601 Ordinal Date format +module Data.Thyme.Calendar.OrdinalDate + ( Year, isLeapYear + , DayOfYear + , OrdinalDate (..), _odYear, _odDay + , ordinalDate + , module Data.Thyme.Calendar.OrdinalDate + ) where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +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 + +-- | Convert an 'OrdinalDate' to a 'Day', or 'Nothing' for invalid input. +-- +-- @ +-- > 'ordinalDateValid' ('OrdinalDate' 2015 365) +-- 'Just' 2015-12-31 +-- +-- > 'ordinalDateValid' ('OrdinalDate' 2015 366) +-- 'Nothing' +-- +-- > 'ordinalDateValid' ('OrdinalDate' 2016 366) +-- 'Just' 2016-12-31 +-- @ +{-# INLINE ordinalDateValid #-} +ordinalDateValid :: OrdinalDate -> Maybe Day +ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od + <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365) + +-- * Compatibility + +{-# INLINE toOrdinalDate #-} +-- | Convert a 'Day' to its Gregorian 'Year' and 'DayOfYear'. +-- +-- @ +-- 'toOrdinalDate' ('view' 'ordinalDate' -> 'OrdinalDate' y d) = (y, d) +-- @ +toOrdinalDate :: Day -> (Year, DayOfYear) +toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d) + +-- | Convert a Gregorian 'Year' and 'DayOfYear' to a 'Day'. +-- Does not validate the input. +-- +-- @ +-- 'fromOrdinalDate' y d = 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' y d +-- @ +{-# INLINE fromOrdinalDate #-} +fromOrdinalDate :: Year -> DayOfYear -> Day +fromOrdinalDate y d = ordinalDate # OrdinalDate y d + +-- | Converts a Gregorian 'Year' and 'DayOfYear' to a 'Day'. +-- Returns 'Nothing' on invalid input. +-- +-- @ +-- 'fromOrdinalDateValid' y d = 'ordinalDateValid' ('OrdinalDate' y d) +-- @ +{-# INLINE fromOrdinalDateValid #-} +fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day +fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d) + +-- | Converts a 'Day' to its /Sunday/-starting week date. +-- +-- The first /Sunday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier +-- days in the same year are week @0@. This corresponds to @\"%U\"@ for +-- 'formatTime'. +-- +-- /Sunday/ is @0 ∷ 'DayOfWeek'@, /Saturday/ is @6@. This corresponds to +-- @\"%w\"@ for 'formatTime'. +-- +-- @ +-- 'sundayStartWeek' ('view' 'sundayWeek' -> 'SundayWeek' y w d) = (y, w, d) +-- @ +{-# INLINE sundayStartWeek #-} +sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek) +sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d) + +-- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the +-- inverse of 'sundayStartWeek'. +-- Does not validate the input. +-- +-- @ +-- 'fromSundayStartWeek' y w d = 'sundayWeek' 'Control.Lens.#' 'SundayWeek' y w d +-- @ +{-# INLINE fromSundayStartWeek #-} +fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day +fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d + +-- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the +-- inverse of 'sundayStartWeek'. +-- Returns 'Nothing' for invalid input. +-- +-- @ +-- 'fromSundayStartWeekValid' y w d = 'sundayWeekValid' ('SundayWeek' y w d) +-- @ +{-# INLINE fromSundayStartWeekValid #-} +fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day +fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d) + +-- | Converts a 'Day' to its /Monday/-starting week date. +-- +-- The first /Monday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier +-- days in the same year are week @0@. This corresponds to @\"%W\"@ for +-- 'formatTime'. +-- +-- /Monday/ is @1 ∷ 'DayOfWeek'@, /Sunday/ is @7@. This corresponds to +-- @\"%u\"@ for 'formatTime'. +-- +-- @ +-- 'mondayStartWeek' ('view' 'mondayWeek' -> 'MondayWeek' y w d) = (y, w, d) +-- @ +{-# INLINE mondayStartWeek #-} +mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek) +mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d) + +-- | Converts a /Monday/-starting week date to the corresponding 'Day'; the +-- inverse of 'mondayStartWeek'. +-- Does not validate the input. +-- +-- @ +-- 'fromMondayStartWeek' y w d = 'mondayWeek' 'Control.Lens.#' 'MondayWeek' y w d +-- @ +{-# INLINE fromMondayStartWeek #-} +fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day +fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d + +-- | Converts a /Monday/-starting week date to the corresponding 'Day'; the +-- inverse of 'mondayStartWeek'. +-- Returns 'Nothing' for invalid input. +-- +-- @ +-- 'fromMondayStartWeekValid' y w d = 'mondayWeekValid' ('MondayWeek' y w d) +-- @ +{-# INLINE fromMondayStartWeekValid #-} +fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day +fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d) +
src/Data/Thyme/Calendar/WeekDate.hs view
@@ -1,91 +1,123 @@-{-# 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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# 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" +#if HLINT +#include "cabal_macros.h" +#endif + +-- | Various Week Date formats +module Data.Thyme.Calendar.WeekDate + ( Year, WeekOfYear, DayOfWeek + -- * ISO 8601 Week Date + , WeekDate (..), _wdYear, _wdWeek, _wdDay + , weekDate, weekDateValid, showWeekDate + + -- * Weeks starting Sunday + , SundayWeek (..), _swYear, _swWeek, _swDay + , sundayWeek, sundayWeekValid + + -- * Weeks starting Monday + , MondayWeek (..), _mwYear, _mwWeek, _mwDay + , mondayWeek, mondayWeekValid + + , module Data.Thyme.Calendar.WeekDate + ) where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +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 + +-- * Compatibility + +-- | Converts a 'Day' to an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>. +-- +-- @ +-- 'toWeekDate' ('view' 'weekDate' -> 'WeekDate' y w d) = (y, w, d) +-- @ +{-# INLINE toWeekDate #-} +toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek) +toWeekDate (view weekDate -> WeekDate y w d) = (y, w, d) + +-- | Converts an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date> +-- to a 'Day'. +-- Does not validate the input. +-- +-- @ +-- 'fromWeekDate' y w d = 'weekDate' 'Control.Lens.#' 'WeekDate' y w d +-- @ +{-# INLINE fromWeekDate #-} +fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day +fromWeekDate y w d = weekDate # WeekDate y w d + +-- | Converts an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date> +-- to a 'Day'. +-- Returns 'Nothing' for invalid input. +-- +-- @ +-- 'fromWeekDateValid' y w d = 'weekDateValid' ('WeekDate' y w d) +-- @ +{-# INLINE fromWeekDateValid #-} +fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day +fromWeekDateValid y w d = weekDateValid (WeekDate y w d) +
src/Data/Thyme/Calendar/WeekdayOfMonth.hs view
@@ -1,109 +1,148 @@-{-# 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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +#include "thyme.h" +#if HLINT +#include "cabal_macros.h" +#endif + +-- | Calendar date reckoned by year, month-of-year, and n-th day-of-week. +module Data.Thyme.Calendar.WeekdayOfMonth + ( Year, Month, DayOfWeek + , module Data.Thyme.Calendar.WeekdayOfMonth + ) where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Arrow +import Control.DeepSeq +import Control.Lens +import Control.Monad +import Data.AffineSpace +import Data.Bits +import Data.Data +import Data.Hashable +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 ((.&.)) + +-- | Calendar date with year, month-of-year, and n-th day-of-week. +data WeekdayOfMonth = WeekdayOfMonth + { womYear :: {-# UNPACK #-}!Year + -- ^ Calendar year. + , womMonth :: {-# UNPACK #-}!Month + -- ^ Month of year. + , womNth :: {-# UNPACK #-}!Int + -- ^ /N/-th 'DayOfWeek'. Range /±1–5/; negative means the /N/-th + -- last 'DayOfWeek' of the month. + , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek + -- ^ Day of week. /1 = Monday, 7 = Sunday/, like ISO 8601 'WeekDate'. + } deriving (INSTANCES_USUAL, Show) + +LENS(WeekdayOfMonth,womYear,Year) +LENS(WeekdayOfMonth,womMonth,Month) +LENS(WeekdayOfMonth,womNth,Int) +LENS(WeekdayOfMonth,womDayOfWeek,DayOfWeek) + +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 Hashable WeekdayOfMonth +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 + +-- | Conversion between a 'Day' and and 'WeekdayOfMonth'. +-- +-- This is a proper 'Iso' if and only if all of the 'WeekdayOfMonth' fields +-- are valid and positive. +-- +-- For example, the last /Monday/ in /January 2016/ is also the fourth +-- /Monday/: +-- +-- @ +-- > 'weekdayOfMonth' 'Control.Lens.#' 'WeekdayOfMonth' 2016 1 (-1) 1 +-- 2016-01-25 +-- > 'YearMonthDay' 2016 01 25 '^.' 'from' 'gregorian' '.' 'weekdayOfMonth' +-- 'WeekdayOfMonth' {'womYear' = 2016, 'womMonth' = 1, 'womNth' = 4, 'womDayOfWeek' = 1} +-- @ +{-# 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 + +-- | Convert a 'WeekdayOfMonth' to a 'Day'. +-- Returns 'Nothing' for invalid input. +-- +-- For example, the third /Sunday/ of /January 2016/ is /2016-01-27/, but +-- there is no fifth /Monday/ in /January 2016/. +-- +-- @ +-- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 3 7) +-- 'Just' 2016-01-17 +-- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 5 1) +-- 'Nothing' +-- @ +{-# 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 +
src/Data/Thyme/Clock.hs view
@@ -1,56 +1,203 @@--- | Types and functions for--- <http://en.wikipedia.org/wiki/Coordinated_Universal_Time UTC> and--- <http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>.------ 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-+{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE PatternSynonyms #-} +#endif + +{-| Types and functions for +<http://en.wikipedia.org/wiki/Coordinated_Universal_Time UTC> and +<http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>. + +If you don't care about leap seconds, keep to 'UTCTime' and +'NominalDiffTime' for your clock calculations, and you'll be fine. + +"Data.Thyme.Time" provides 'Num', 'Real', 'Fractional' and 'RealFrac' +instances for 'DiffTime' and 'NominalDiffTime', but their use is +discouraged. See "Data.Thyme.Docs#spaces" for details. + +Use 'fromSeconds' and 'toSeconds' to convert between 'DiffTime' +/ 'NominalDiffTime' and other numeric types; use 'fromSeconds'' for +literals to avoid type defaulting warnings. + +-} + +module Data.Thyme.Clock ( + -- * UTC + UTCTime + , utctDay, utctDayTime + , _utctDay, _utctDayTime +#if __GLASGOW_HASKELL__ >= 708 + , pattern UTCTime +#endif + , mkUTCTime + , utcTime + + , UTCView (..), _utcvDay, _utcvDayTime + , NominalDiffTime + + , getCurrentTime + + -- * Absolute intervals + , DiffTime + + -- * Time interval conversion + , TimeDiff (..) + , toSeconds, fromSeconds + , toSeconds', fromSeconds' + , picoseconds + + -- * Universal Time + , UniversalTime +#if __GLASGOW_HASKELL__ >= 708 + , pattern UniversalTime +#endif + , modJulianDate + + -- * Compatibility + , getModJulianDate + , mkModJulianDate + , secondsToDiffTime + , picosecondsToDiffTime + , unUTCTime + , addUTCTime + , diffUTCTime + , toMicroseconds + , fromMicroseconds + ) where + +import Prelude +import Control.Lens +import Data.AffineSpace +import Data.Int +import Data.Ratio ((%)) +import Data.Thyme.Clock.Internal +import Data.Thyme.Clock.POSIX + +-- | Get the current UTC date and time from the local system clock. +-- +-- @ +-- > 'Data.Thyme.Clock.getCurrentTime' +-- 2016-01-15 13:42:02.287688 UTC +-- @ +-- +-- See also: 'Data.Thyme.LocalTime.getZonedTime', 'getPOSIXTime'. +getCurrentTime :: IO UTCTime +getCurrentTime = fmap (review posixTime) getPOSIXTime + +-- | Conversion between 'TimeDiff' and picoseconds. In the reverse +-- direction, picoseconds are 'round'ed to the nearest microsecond. +{-# INLINE picoseconds #-} +picoseconds :: (TimeDiff t) => Iso' t Integer +picoseconds = microseconds . iso + ((*) 1000000 . toInteger) (\ ps -> round (ps % 1000000)) + +------------------------------------------------------------------------ + +-- | Convert a 'UniversalTime' to the fractional number of days since the +-- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>. +-- +-- @ +-- 'getModJulianDate' = 'view' 'modJulianDate' +-- @ +{-# INLINE getModJulianDate #-} +getModJulianDate :: UniversalTime -> Rational +getModJulianDate = view modJulianDate + +-- | Construct a 'UniversalTime' from the fractional number of days since the +-- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>. +-- +-- @ +-- 'mkModJulianDate' = 'review' 'modJulianDate' +-- @ +{-# INLINE mkModJulianDate #-} +mkModJulianDate :: Rational -> UniversalTime +mkModJulianDate = review modJulianDate + +-- | Construct a 'DiffTime' from some number of seconds. +-- +-- This is just 'fromSeconds' with a more constrained type. +-- +-- @ +-- 'secondsToDiffTime' = 'fromSeconds' +-- @ +{-# INLINE secondsToDiffTime #-} +secondsToDiffTime :: Int64 -> DiffTime +secondsToDiffTime = fromSeconds + +-- | Construct a 'DiffTime' from some number of picoseconds. +-- The input will be rounded to the nearest microsecond. +-- +-- @ +-- 'picosecondsToDiffTime' a = 'microseconds' 'Control.Lens.#' 'quot' (a '+' 'signum' a '*' 500000) 1000000 +-- @ +{-# INLINE picosecondsToDiffTime #-} +picosecondsToDiffTime :: Integer -> DiffTime +picosecondsToDiffTime = review picoseconds + +-- | Decompose a 'UTCTime' into a 'UTCView'. +-- +-- @ +-- 'unUTCTime' = 'view' 'utcTime' +-- @ +-- +-- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g. +-- +-- @ +-- f :: 'UTCTime' -> ('Day', 'DiffTime') +-- f ('unUTCTime' -> 'UTCView' day dt) = (day, dt) +-- @ +-- +-- For GHC 7.8 or later, there is also the pattern synonym +-- @<Data-Thyme-Clock.html#v:UTCTime UTCTime>@. +{-# INLINE unUTCTime #-} +unUTCTime :: UTCTime -> UTCView +unUTCTime = view utcTime + +-- | Add a duration to a point in time. +-- +-- @ +-- 'addUTCTime' = 'flip' ('.+^') +-- 'addUTCTime' d t ≡ t '.+^' d +-- @ +-- +-- See also the 'AffineSpace' instance for 'UTCTime'. +{-# INLINE addUTCTime #-} +addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime +addUTCTime = flip (.+^) + +-- | The duration difference between two time points. +-- +-- @ +-- 'diffUTCTime' = ('.-.') +-- 'diffUTCTime' a b = a '.-.' b +-- @ +-- +-- See also the 'AffineSpace' instance for 'UTCTime'. +{-# INLINE diffUTCTime #-} +diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime +diffUTCTime = (.-.) + +-- | The number of microseconds in a 'DiffTime' or 'NominalDiffTime'. +-- +-- @ +-- 'toMicroseconds' :: 'DiffTime' -> 'Int64' +-- 'toMicroseconds' :: 'NominalDiffTime' -> 'Int64' +-- 'toMicroseconds' = 'view' 'microseconds' +-- 'toMicroseconds' d ≡ d '^.' 'microseconds' +-- @ +{-# INLINE toMicroseconds #-} +toMicroseconds :: (TimeDiff t) => t -> Int64 +toMicroseconds = view microseconds + +-- | Construct a 'DiffTime' or 'NominalDiffTime' from a number of +-- microseconds. +-- +-- @ +-- 'fromMicroseconds' :: 'Int64' -> 'DiffTime' +-- 'fromMicroseconds' :: 'Int64' -> 'NominalDiffTime' +-- 'fromMicroseconds' = 'review' 'microseconds' +-- 'fromMicroseconds' n ≡ 'microseconds' 'Control.Lens.#' n +-- @ +{-# INLINE fromMicroseconds #-} +fromMicroseconds :: (TimeDiff t) => Int64 -> t +fromMicroseconds = review microseconds +
src/Data/Thyme/Clock/Internal.hs view
@@ -1,304 +1,434 @@-{-# 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--- <http://hackage.haskell.org/trac/ghc/ticket/7611>?-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--- <http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>.------ '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--- <http://en.wikipedia.org/wiki/International_Atomic_Time TAI> or--- 'AbsoluteTime'. The difference between UT1 and UTC is--- <http://en.wikipedia.org/wiki/DUT1 DUT1>.-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--- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.-{-# INLINE modJulianDate #-}-modJulianDate :: Iso' UniversalTime Rational-modJulianDate = iso- (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength)- (UniversalRep . (*^ posixDayLength))------------------------------------------------------------------------------ | <http://en.wikipedia.org/wiki/Coordinated_Universal_Time Coördinated universal time>:--- 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--- <https://github.com/liyang/thyme/issues/3 cannot represent leap seconds>.-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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} -- workaround +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE PatternSynonyms #-} +#endif +{-# 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.Hashable +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 + +-- | Hour time-of-day. +type Hour = Int +-- | Minute time-of-day. +type Minute = Int + +-- | Time intervals, encompassing both 'DiffTime' and 'NominalDiffTime'. +-- +-- ==== Notes +-- +-- Still affected by <http://hackage.haskell.org/trac/ghc/ticket/7611>? +class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where + -- | Conversion between 'TimeDiff' and 'Int64' microseconds. + -- + -- @ + -- > ('fromSeconds'' 3 :: 'DiffTime') '^.' 'microseconds' + -- 3000000 + -- + -- > 'microseconds' 'Control.Lens.#' 4000000 :: 'DiffTime' + -- 4s + -- @ + 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. +-- +-- 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 ()) + +------------------------------------------------------------------------ +-- 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 interval or duration of time, as would be measured by a stopwatch. +-- +-- 'DiffTime' is an instance of 'AdditiveGroup' as well as 'VectorSpace', +-- with 'Rational' as its 'Scalar'. +-- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances +-- here. See "Data.Thyme.Docs#spaces" for details. +-- +-- @ +-- > 'fromSeconds'' 100 :: 'DiffTime' +-- 100s +-- > 'fromSeconds'' 100 '^+^' 'fromSeconds'' 100 '^*' 4 +-- 500s +-- > 'fromSeconds'' 100 '^-^' 'fromSeconds'' 100 '^/' 4 +-- 75s +-- @ +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) + +------------------------------------------------------------------------ + +-- | The nominal interval between two 'UTCTime's, which does not take leap +-- seconds into account. +-- +-- For example, 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' is an instance of 'AdditiveGroup' as well as +-- 'VectorSpace', with 'Rational' as its 'Scalar'. +-- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances +-- here. See "Data.Thyme.Docs#spaces" for details. +-- +-- @ +-- > let d = 'fromSeconds'' 2 :: 'NominalDiffTime' +-- > d +-- 2s +-- > d '^/' 3 +-- 0.666667s +-- @ +-- +-- See also: 'UTCTime'. +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: /86400 SI seconds/. +{-# INLINE posixDayLength #-} +posixDayLength :: NominalDiffTime +posixDayLength = microseconds # 86400000000 + +------------------------------------------------------------------------ + +-- | The principal form of universal time, namely +-- <http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>. +-- +-- UT1 is defined by the rotation of the Earth around its axis relative to +-- the Sun. The length of each UT1 day varies and is never exactly 86400 SI +-- seconds, unlike UTC or TAI. +-- +-- The difference between UT1 and UTC is +-- <http://en.wikipedia.org/wiki/DUT1 DUT1>. +newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO) + +derivingUnbox "UniversalTime" [t| UniversalTime -> NominalDiffTime |] + [| \ (UniversalRep a) -> a |] [| UniversalRep |] + +-- | Convert between 'UniversalTime' and the fractional number of days since the +-- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>. +{-# INLINE modJulianDate #-} +modJulianDate :: Iso' UniversalTime Rational +modJulianDate = iso + (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength) + (UniversalRep . (*^ posixDayLength)) + +#if __GLASGOW_HASKELL__ >= 710 +pattern UniversalTime :: Rational -> UniversalTime +pattern UniversalTime mjd <- (view modJulianDate -> mjd) where + UniversalTime mjd = modJulianDate # mjd +#elif __GLASGOW_HASKELL__ >= 708 +pattern UniversalTime mjd <- (view modJulianDate -> mjd) +#endif + +------------------------------------------------------------------------ + +-- | <https://en.wikipedia.org/wiki/Coordinated_Universal_Time Coördinated universal time> +-- ('UTCTime') is the most commonly used standard for civil timekeeping. It +-- is synchronised with +-- <https://en.wikipedia.org/wiki/International_Atomic_Time TAI> +-- ('Data.Thyme.Clock.AbsoluteTime') and both tick in increments of SI +-- seconds, but UTC includes occasional leap-seconds to keep it close to +-- <https://en.wikipedia.org/wiki/Universal_Time#Versions UT1> +-- ('UniversalTime'). +-- +-- @ +-- > 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78) +-- 2016-01-15 12:34:56.78 UTC +-- +-- > 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78) +-- 2016-01-15 12:34:56.78 UTC +-- +-- > 'mkUTCTime' 2016 1 15 12 34 56.78 +-- 2016-01-15 12:34:56.78 UTC +-- @ +-- +-- 'UTCTime' is an 'AffineSpace' with 'NominalDiffTime' as its 'Diff'. See +-- "Data.Thyme.Docs#spaces" for details. +-- +-- @ +-- > let t0 = 'mkUTCTime' 2016 1 15 23 59 0 +-- > let t1 = 'mkUTCTime' 2016 1 16 00 1 1 +-- > let dt = t1 '.-.' t0 +-- > dt +-- 121s :: 'NominalDiffTime' +-- +-- > t1 '.+^' dt +-- 2016-01-16 00:03:02 UTC +-- +-- > t1 '.+^' 3 '*^' dt +-- 2016-01-16 00:07:04 UTC +-- @ +-- +-- To decompose a 'UTCTime' into a separate 'Day' and time-of-day, use +-- 'utcTime'. To convert to a local time zone, see +-- 'Data.Thyme.LocalTime.zonedTime' or 'Data.Thyme.LocalTime.utcLocalTime'. +-- +-- ==== Notes +-- +-- Internally 'UTCTime' is just a 64-bit count of 'microseconds' since the +-- Modified Julian Day epoch, so @('.+^')@, @('.-.')@ et cetera ought to be +-- fast. +-- +-- 'UTCTime' <https://github.com/liyang/thyme/issues/3 cannot represent leap seconds>. +-- If leap seconds matter, use 'Data.Thyme.Clock.TAI.AbsoluteTime' from +-- "Data.Thyme.Clock.TAI" instead, along with +-- 'Data.Thyme.Clock.TAI.absoluteTime'' and 'UTCView' for presentation. +newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO) + +derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |] + [| \ (UTCRep a) -> a |] [| UTCRep |] + +-- | Unpacked 'UTCTime', partly for compatibility with @time@. +-- +-- As of GHC 7.10, you can also use the 'UTCTime' pattern synonym. +data UTCView = UTCView + { utcvDay :: {-# UNPACK #-}!Day + -- ^ Calendar date. + , utcvDayTime :: {-# UNPACK #-}!DiffTime + -- ^ Time elapsed since midnight; /0/ ≤ 'utcvDayTime' < /86401s/. + } deriving (INSTANCES_USUAL, Show) + +-- | 'Lens'' for the calendar 'Day' component of a 'UTCView'. +LENS(UTCView,utcvDay,Day) + +-- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCView'. +LENS(UTCView,utcvDayTime,DiffTime) + +derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |] + [| \ UTCView {..} -> (utcvDay, utcvDayTime) |] + [| \ (utcvDay, utcvDayTime) -> UTCView {..} |] + +instance Hashable UTCView +instance NFData UTCView + +-- | 'Lens'' for the calendar 'Day' component of a 'UTCTime'. +_utctDay :: Lens' UTCTime Day +_utctDay = utcTime . lens utcvDay + (\ UTCView {..} d -> UTCView d utcvDayTime) + +-- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCTime'. +_utctDayTime :: Lens' UTCTime DiffTime +_utctDayTime = utcTime . lens utcvDayTime + (\ UTCView {..} t -> UTCView utcvDay t) + +-- | Accessor for the calendar 'Day' component of an 'UTCTime'. +-- +-- @ +-- 'utctDay' = 'view' '_utctDay' +-- @ +utctDay :: UTCTime -> Day +utctDay = view _utctDay + +-- | Accessor for the time-of-day 'DiffTime' component of an 'UTCTime'. +-- +-- @ +-- 'utctDayTime' = 'view' '_utctDayTime' +-- @ +utctDayTime :: UTCTime -> DiffTime +utctDayTime = view _utctDayTime + +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: 'utcvDayTime' outside the range of +-- @['zeroV', 'posixDayLength')@ will carry over into 'utcvDay', with the +-- expected behaviour. +-- +-- @ +-- > 'view' 'utcTime' '<$>' 'Data.Thyme.Clock.getCurrentTime' +-- 'UTCView' {'utcvDay' = 2016-01-15, 'utcvDayTime' = 49322.287688s} +-- +-- > 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78) +-- 2016-01-15 12:34:56.78 UTC +-- @ +-- +-- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g. +-- +-- @ +-- f :: 'UTCTime' -> ('Day', 'DiffTime') +-- f ('view' 'utcTime' -> 'UTCView' day dt) = (day, dt) +-- @ +{-# 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)) = UTCView + (ModifiedJulianDay mjd) (DiffTime dt) where + (fromIntegral -> mjd, dt) = microDivMod a posixDay + + {-# INLINE fromView #-} + fromView :: UTCView -> UTCTime + fromView (UTCView (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where + a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt) + +#if __GLASGOW_HASKELL__ >= 710 +pattern UTCTime :: Day -> DiffTime -> UTCTime +pattern UTCTime d t <- (view utcTime -> UTCView d t) where + UTCTime d t = utcTime # UTCView d t +#elif __GLASGOW_HASKELL__ >= 708 +pattern UTCTime d t <- (view utcTime -> UTCView d t) +#endif + +-- | Construct a 'UTCTime' from a 'gregorian' date and time-of-day. +-- +-- @ +-- 'mkUTCTime' yy mm dd h m s ≡ 'utcTime' 'Control.Lens.#' 'UTCView' +-- ('gregorian' 'Control.Lens.#' 'YearMonthDay' yy mm dd) +-- ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' h m ('fromSeconds' s)) +-- @ +{-# INLINE mkUTCTime #-} +mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime +mkUTCTime yy mm dd h m s = utcTime # UTCView + (gregorian # YearMonthDay yy mm dd) + (fromSeconds (3600 * h + 60 * m) ^+^ fromSeconds s) +
src/Data/Thyme/Clock/POSIX.hsc view
@@ -1,66 +1,108 @@-{-# LANGUAGE ForeignFunctionInterface #-}--#ifndef mingw32_HOST_OS-#include <sys/time.h>-#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-+{-# LANGUAGE ForeignFunctionInterface #-} + +#ifndef mingw32_HOST_OS +#include <sys/time.h> +#endif + +-- | <https://en.wikipedia.org/wiki/Unix_time POSIX time> +module Data.Thyme.Clock.POSIX + ( posixDayLength + , POSIXTime + , posixTime + , getPOSIXTime + + -- * Compatibility + , posixSecondsToUTCTime + , utcTimeToPOSIXSeconds + ) 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 + +-- | The nominal (ignoring leap seconds) time difference since midnight +-- 1970-01-01, the Unix epoch. Equvialent to a normalised +-- @<http://www.gnu.org/software/libc/manual/html_node/Elapsed-Time.html struct timeval>@. +type POSIXTime = NominalDiffTime + +-- | "Control.Lens.Iso" between 'UTCTime' and 'POSIXTime'. +-- +-- @ +-- > 'getPOSIXTime' +-- 1459515013.527711s +-- > 'review' 'posixTime' '<$>' 'getPOSIXTime' +-- 2016-01-01 12:50:45.588729 UTC +-- @ +{-# INLINE posixTime #-} +posixTime :: Iso' UTCTime POSIXTime +posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch) + (UTCRep . (^+^) unixEpoch) where + unixEpoch = review microseconds $ + {-ModifiedJulianDay-}40587 * {-posixDayLength-}86400000000 + +-- | Return the current system POSIX time via +-- @<http://www.gnu.org/software/libc/manual/html_node/High_002dResolution-Calendar.html gettimeofday>@, +-- or @getSystemTimeAsFileTime@ on Windows. +-- +-- See also 'Data.Thyme.Clock.getCurrentTime', 'Data.Thyme.LocalTime.getZonedTime'. +{-# 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 + +------------------------------------------------------------------------ + +-- | Construct a 'UTCTime' from a 'POSIXTime'. +-- +-- @ +-- 'posixSecondsToUTCTime' = 'review' 'posixTime' +-- 'posixSecondsToUTCTime' t ≡ 'posixTime' 'Control.Lens.#' t +-- @ +{-# INLINE posixSecondsToUTCTime #-} +posixSecondsToUTCTime :: POSIXTime -> UTCTime +posixSecondsToUTCTime = review posixTime + +-- | Convert a 'UTCTime' to a 'POSIXTime'. +-- +-- @ +-- 'utcTimeToPOSIXSeconds' = 'view' 'posixTime' +-- @ +{-# INLINE utcTimeToPOSIXSeconds #-} +utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime +utcTimeToPOSIXSeconds = view posixTime +
src/Data/Thyme/Clock/TAI.hs view
@@ -1,150 +1,357 @@-{-# 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 <http://maia.usno.navy.mil/ser7/tai-utc.dat>-{-# 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-+{-# 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 + +#define TAIUTCDAT @<http://maia.usno.navy.mil/ser7/tai-utc.dat tai-utc.dat>@ + +-- | <https://en.wikipedia.org/wiki/International_Atomic_Time International Atomic Time> +-- (TAI) and conversion to/from UTC, accounting for leap seconds. +module Data.Thyme.Clock.TAI + ( AbsoluteTime + , taiEpoch + , TAIUTCMap (..) + , TAIUTCRow (..) + , absoluteTime + , absoluteTime' + , utcDayLength + , parseTAIUTCRow + , makeTAIUTCMap + , parseTAIUTCDAT + + -- * Compatibility + , addAbsoluteTime + , diffAbsoluteTime + , utcToTAITime + , taiToUTCTime + ) where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +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 qualified Data.ByteString as S +import Data.Data +import Data.Hashable +import Data.Ix +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Thyme.Calendar +import Data.Thyme.Clock.Internal +import Data.Thyme.Format.Internal (indexOf) +import Data.Thyme.Internal.Micro +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.Random (Random) +import Test.QuickCheck + +-- | <https://en.wikipedia.org/wiki/International_Atomic_Time Temps Atomique International> +-- (TAI). Note that for most applications 'UTCTime' is perfectly sufficient, +-- and much more convenient to use. +-- +-- Internally this is the number of seconds since 'taiEpoch'. TAI days are +-- exactly 86400 SI seconds long. +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 $ TAIUTCMap mempty mempty) . utcLocalTime utc + +-- | The <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day> +-- epoch, 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) + +-- | A table of 'TAIUTCRow's for converting between TAI and UTC. +-- +-- The two 'Map's are keyed on the corresponding instants in UTC and TAI +-- from which the 'TAIUTCRow' becomes applicable. The 'UTCTime' key of the +-- first 'Map' is always at midnight. +-- +-- No table is provided here because leap seconds are unpredictable, and any +-- program shipped with such a table could become out-of-date in as little +-- as 6 months. See 'parseTAIUTCDAT' for details. +data TAIUTCMap = TAIUTCMap (Map UTCTime TAIUTCRow) (Map AbsoluteTime TAIUTCRow) + deriving (INSTANCES_USUAL, Show) + +-- | Each line of TAIUTCDAT (see 'parseTAIUTCDAT') specifies the difference +-- between TAI and UTC for a particular period. For example: +-- +-- @ +-- 1968 FEB 1 =JD 2439887.5 TAI-UTC= 4.2131700 S + (MJD - 39126.) X 0.002592 S +-- @ +-- +-- says that from 1968-02-01 00:00:00 (Julian Date 2439887.5; or Modified +-- Julian Date 39887.0), the difference between TAI and UTC is @4.2131700s@ +-- (the /additive/ part) plus a scaled component that increases for each day +-- beyond MJD 39126 (the /base/) by 0.002592s (the /coefficient/). In +-- general, the latter half of each line is of the form: +-- +-- @ +-- TAI-UTC= /additive/ S + (MJD - /base/) X /coefficient/ S +-- @ +-- +-- @'TAIUTCRow' a b c@ is a normalised version of the above, with the /base/ +-- multiplied by 86400s, and the /coefficient/ divided by the same. This +-- allows us to use the internal representation of 'UTCTime'—seconds since +-- the MJD epoch—as the @MJD@ term without further rescaling. +-- +-- Note that between 1961-01-01 and 1972-01-01, each UTC second was actually +-- slightly longer than one TAI (or SI) second. For the first year this was +-- at the rate of exactly 1.000000015 TAI (or SI) seconds per UTC second, +-- but was subject to irregular updates. Since leap seconds came into effect +-- on 1972-01-01, the /additive/ part has always been an intergral number of +-- seconds, and the /coefficient/ has always been zero. +-- +-- To convert between TAI and UTC, we refer to the definition: +-- +-- @ +-- TAI - UTC = a + (MJD - b) * c +-- @ +-- +-- Using UTC for MJD (with 'b' and 'c' scaled as described above): +-- +-- @ +-- TAI = UTC + a + (UTC - b) * c +-- TAI - a + b * c = UTC + UTC * c +-- (TAI - a + b * c) / (1 + c) = UTC +-- @ +-- +-- This is implemented by 'absoluteTime' and 'absoluteTime''. +-- +-- Further reading: +-- +-- * https://en.wikipedia.org/wiki/Coordinated_Universal_Time +-- * https://en.wikipedia.org/wiki/International_Atomic_Time +data TAIUTCRow = TAIUTCRow !DiffTime !UTCTime !Rational + -- ^ Each row comprises of an /additive/ component, the /base/ of the + -- scaled component, and the /coefficient/ of the scaled component. + deriving (INSTANCES_USUAL, Show) + +{-# INLINE lookupLE #-} +lookupLE :: (Ord k) => k -> Map k TAIUTCRow -> TAIUTCRow +lookupLE k = maybe (TAIUTCRow zeroV (UTCRep zeroV) 0) snd . Map.lookupLE k + +{-# INLINE unwrap #-} +unwrap :: TAIUTCRow -> (Micro, Micro, Rational) +unwrap (TAIUTCRow (DiffTime a) (UTCRep (NominalDiffTime b)) c) = (a, b, c) + +-- | Convert between 'UTCTime' and 'AbsoluteTime' using a 'TAIUTCMap'. +-- +-- Since 'UTCTime' cannot represent a time-of-day of 86400s or more, any +-- conversion from 'AbsoluteTime' that happens to be during a leap second +-- will overflow into the next day. +-- +-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below. +-- +-- @ +-- > let jul1 = 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV' +-- > jul1 '&' 'absoluteTime' tum '%~' ('.-^' 'fromSeconds' 1.1) +-- 2015-06-30 23:59:59.9 UTC +-- @ +{-# INLINE absoluteTime #-} +absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime +absoluteTime (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where + {-# INLINEABLE toTAI #-} + toTAI :: UTCTime -> AbsoluteTime + toTAI utime@(UTCRep (NominalDiffTime uts)) = AbsoluteTime . DiffTime $ + uts ^+^ a ^+^ (uts ^-^ b) ^* c where + (a, b, c) = unwrap $ lookupLE utime utcMap + + {-# INLINEABLE toUTC #-} + toUTC :: AbsoluteTime -> UTCTime + toUTC atime@(AbsoluteTime (DiffTime ats)) = UTCRep . NominalDiffTime $ + (ats ^-^ a ^+^ b ^* c) ^/ (1 + c) where + (a, b, c) = unwrap $ lookupLE atime taiMap + +-- | Convert between 'UTCView' and TAI 'AbsoluteTime' using a 'TAIUTCMap'. +-- +-- Unlike 'absoluteTime', 'UTCView' /can/ represent a time-of-day greater +-- than 86400s, and this gives the correct results during a leap second. +-- +-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below. +-- +-- @ +-- > let jul1 = 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV' +-- > jul1 '&' 'absoluteTime'' tum '%~' ('.-^' 'fromSeconds' 0.1) +-- 'UTCView' {'utcvDay' = 2015-06-30, 'utcvDayTime' = 86400.9s} +-- @ +-- +-- However keep in mind that currently there is no standard way to get the +-- TAI on most platforms. Simply converting the result of +-- 'Data.Thyme.Clock.getCurrentTime' (which calls @gettimeofday(2)@) to +-- 'AbsoluteTime' during a leap second will still give non-monotonic times. +{-# INLINE absoluteTime' #-} +absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime +absoluteTime' (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where + {-# INLINEABLE toTAI #-} + toTAI :: UTCView -> AbsoluteTime + toTAI uview@(UTCView day _) = AbsoluteTime . DiffTime $ + uts ^+^ a ^+^ (uts ^-^ b) ^* c where + (a, b, c) = unwrap $ lookupLE (utcTime # UTCView day zeroV) utcMap + UTCRep (NominalDiffTime uts) = utcTime # uview + + {-# INLINEABLE toUTC #-} + toUTC :: AbsoluteTime -> UTCView + toUTC atime@(AbsoluteTime (DiffTime ats)) = fixup (utime ^. utcTime) where + row@(unwrap -> (a, b, c)) = lookupLE atime taiMap + utime = UTCRep . NominalDiffTime $ (ats ^-^ a ^+^ b ^* c) ^/ (1 + c) + -- 'lookupLE' of the same instant in 'utcMap' and 'taiMap' should + -- give the same 'TAIUTCRow'. If it doesn't, then @utime@ must have + -- overflown into the next 'Day'. + fixup uview@(UTCView day dt) = if lookupLE utime utcMap == row + then uview else UTCView (day .-^ 1) (fromSeconds' 86400 ^+^ dt) + +-- TODO: Linux >= 3.10 has @CLOCK_TAI@ for @clock_gettime(2)@. + +-- | Using a 'TAIUTCMap', lookup the 'DiffTime' length of the UTC 'Day'. +-- +-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below. +-- +-- @ +-- > 'utcDayLength' tum '.' 'view' '_utctDay' '<$>' 'getCurrentTime' +-- 86400s +-- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30 +-- 86401s +-- @ +utcDayLength :: TAIUTCMap -> Day -> DiffTime +utcDayLength tum day = diff (day .+^ 1) .-. diff day where + diff d = UTCView d zeroV ^. from utcTime . absoluteTime tum + +-- | @attoparsec@ 'P.Parser' for a single line of TAIUTCDAT. +-- +-- Returns the starting 'UTCTime' and the normalised 'TAIUTCRow'. +parseTAIUTCRow :: P.Parser (UTCTime, TAIUTCRow) +parseTAIUTCRow = do + y <- P.skipSpace *> P.decimal <?> "Year" + let months = [ "JAN", "FEB", "MAR", "APR", "MAY", "JUN" + , "JUL", "AUG", "SEP", "OCT", "NOV", "DEC" ] + m <- (+) 1 <$ P.skipSpace <*> indexOf months <?> "Month" + d <- P.skipSpace *> P.decimal <?> "DayOfMonth" + + tokens ["=", "JD"] + -- TAI-UTC changes always happen at midnight UTC, so just ignore ".5". + since <- subtract 2400000{-.5-} <$> P.decimal + <* P.string ".5" <?> "Julian Date .5" + let ymd = YearMonthDay y m d + unless (gregorian # ymd == ModifiedJulianDay since) $ do + fail $ show ymd ++ " ≠ MJD " ++ show since + ++ " ≡ " ++ show (ModifiedJulianDay since) + + tokens ["TAI", "-", "UTC", "="] + a <- P.rational <?> "Additive" + tokens ["S", "+", "(", "MJD", "-"] + b <- P.decimal <* P.char '.' <?> "Base" -- also always midnight UTC + tokens [")", "X"] + c <- (/ toSeconds' posixDayLength) <$> P.rational + <* P.skipSpace <* P.string "S" <?> "Coefficient" + + return (mjdToUTC since, TAIUTCRow (fromSeconds' a) (mjdToUTC b) c) + where + tokens ts = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) + P.skipSpace ts <?> ("tokens " ++ show ts) + mjdToUTC mjd = utcTime # UTCView (ModifiedJulianDay mjd) zeroV + +-- | Build a 'TAIUTCMap' from the result of 'parseTAIUTCRow'. +makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap +makeTAIUTCMap rows = TAIUTCMap (Map.fromList rows) + (Map.fromList $ invert <$> rows) where + invert (since, entry) = (since ^. absoluteTime single, entry) where + single = TAIUTCMap (Map.singleton since entry) mempty + +-- | Parse the contents of TAIUTCDAT into a 'TAIUTCMap' for conversion +-- between TAI and UTC. +-- +-- @ +-- $ curl -O \"http:\/\/maia.usno.navy.mil\/ser7\/tai-utc.dat\" +-- $ ghci --package thyme +-- > import "Data.Thyme" +-- > import "Data.Thyme.Clock.TAI" +-- > import "Data.ByteString" ('S.readFile') +-- > Right tum \<- 'parseTAIUTCDAT' '<$>' 'S.readFile' \"tai-utc.dat\" +-- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30 +-- 86401s +-- @ +parseTAIUTCDAT :: S.ByteString -> Either String TAIUTCMap +parseTAIUTCDAT = P.parseOnly $ makeTAIUTCMap <$> P.manyTill + (parseTAIUTCRow <* P.endOfLine) P.endOfInput + +------------------------------------------------------------------------ + +-- | Add a duration to an 'AbsoluteTime'. +-- +-- @ +-- 'addAbsoluteTime' = 'flip' ('.+^') +-- 'addAbsoluteTime' d t ≡ t '.+^' d +-- @ +-- +-- See also the 'AffineSpace' instance for 'AbsoluteTime'. +{-# INLINE addAbsoluteTime #-} +addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime +addAbsoluteTime = flip (.+^) + +-- | The duration difference between two 'AbsoluteTime's. +-- +-- @ +-- 'diffAbsoluteTime' = ('.-.') +-- 'diffAbsoluteTime' a b ≡ a '.-.' b +-- @ +-- +-- See also the 'AffineSpace' instance for 'AbsoluteTime'. +{-# INLINE diffAbsoluteTime #-} +diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime +diffAbsoluteTime = (.-.) + +-- | Using a 'TAIUTCMap', convert a 'UTCTime' to 'AbsoluteTime'. +-- +-- @ +-- 'utcToTAITime' = 'view' '.' 'absoluteTime' +-- @ +{-# INLINE utcToTAITime #-} +utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime +utcToTAITime m = view (absoluteTime m) + +-- | Using a 'TAIUTCMap', convert a 'AbsoluteTime' to 'UTCTime'. +-- +-- @ +-- 'taiToUTCTime' = 'review' '.' 'absoluteTime' +-- @ +{-# INLINE taiToUTCTime #-} +taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime +taiToUTCTime m = review (absoluteTime m) +
+ src/Data/Thyme/Docs.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Data.Thyme.Docs + ( + -- * #api#API + -- $api + + -- ** #compat#Compatibility with @time@ + -- $compat + + -- ** #spaces#VectorSpace and AffineSpace + -- $spaces + + -- ** #lenses#Isomorphisms and Lenses + -- $lenses + + -- * #tutorial#Tutorial + -- $tutorial + + -- * #impl#Implementation + -- $impl + + -- ** #range#Range + -- $range + + -- ** #prec#Precision + -- $prec + + -- ** #perf#Performance + -- $perf + ) where + +import Control.Lens +import Data.AffineSpace +import Data.Int +import Data.IntMap (Key, IntMap) +import Data.Map.Strict (Map) +import Data.Thyme +import Data.Thyme.Calendar.WeekDate +import Data.Thyme.Clock.TAI +import Data.Thyme.Format.Human +import Data.Thyme.Time.Core +import qualified Data.Time as T +import Data.VectorSpace + +-- Note: {{{ and }}} below are fold markers for Vim. Please ignore. + +{- {{{ api -} +{- $api + +In general stick to 'UTCTime' and 'NominalDiffTime' for time calculations, +converting from/to 'LocalTime', or 'ZonedTime' et cetera only for +input/output. + +Synonyms for 'Int'—such as 'Year', 'Month', and 'DayOfMonth'—are provided +for more descriptive type signatures. There are records (with strict and +unpacked fields) for some common tuples, e.g. 'YearMonthDay', instead of +@('Integer', 'Int', 'Int')@. + +On platforms where the native 'Int' is 64-bits wide, types with an 'Enum' +instance such as 'Day' can be used as 'Key's for 'IntMap', preferably via an +@<http://hackage.haskell.org/package/enummapset-th EnumMap>@ wrapper. In any +case the 'Ord' instances are much faster, if you must use 'Map'. + +-}{- }}} -} + +{- {{{ compat -} +{- $compat + +@thyme@ tries to maintain API compatibility with @time@ and each module +exports the same functions as corresponding one in @time@. There are however +some differences to keep in mind: + +* 'UTCTime' is an opaque type and there is no @UTCTime@ constructor. Since + GHC 7.8 you can use the @<Data-Thyme-Clock.html#v:UTCTime UTCTime>@ + pattern synonym. In any case, 'utcTime' can convert it to a 'UTCView'. + +* 'UniversalTime' similarly has the + @<Data-Thyme-Clock.html#v:ModJulianDate ModJulianDate>@ pattern synonym, + along with 'modJulianDate'. + +* 'Year's are 'Int's, not 'Integer's: you may need 'fromIntegral'. + +* If you'd rather not use @lens@ or @vector-space@ directly, most modules + list functions under a ‘Compatibility’ section that mimics the @time@ API. + +* Where a third party library uses @time@, you can use 'toThyme' and + 'fromThyme' from "Data.Thyme.Time.Core" to convert between the + corresponding types. + +* "Data.Thyme.Time" provides 'Num', 'Real', 'Fractional', and 'RealFrac' + instances for 'DiffTime' and 'NominalDiffTime'. Avoid using this in new + code, <#spaces because of reasons>. + +Any other differences not covered here may be unintentional. Please check +<https://github.com/liyang/thyme/issues?q= the list of issues> on GitHub and +file a new one if necessary. + +-}{- }}} -} + +{- {{{ spaces -} +{- $spaces + +One of the issues arising from 'Num', 'Real', 'Fractional', and 'RealFrac' +instances for e.g. 'NominalDiffTime' is that we must also supply nonsensical +operations such as @('*')@: multiplying two quantities of +<https://en.wikipedia.org/wiki/Dimensional_analysis#Definition dimension T> +gives something of dimension /T²/, yet according to the type of @('*')@ the +result is another 'NominalDiffTime' of dimension /T/. + +A more principled approach is to invoke our geometric intuition and think of +instants in time as points in a one-dimensional affine space—that is, a line +without an origin per se; a time-line, if you will. Taking the distance +(displacement) between two points in this space amounts to finding the +(signed) duration between two instants in time. These durations are akin to +vectors in the geometric sense, and as such we can add, subtract, or scaled +them by some factor to obtain another duration. Conversely a point plus (or +minus) a vector results in another point, and likewise an instant in time +plus (or minus) a duration takes us to another instant in time. + +The 'AffineSpace' and 'VectorSpace' classes from +<http://hackage.haskell.org/package/vector-space vector-space> allows us to +express exactly this idea: 'UTCTime' correspond to points on the time-line, +and is therefore an instance of 'AffineSpace' with the associated + +@ +type 'Diff' 'UTCTime' = 'NominalDiffTime' +@ + +as the type of durations between instants. It may help to think of the +provided operations as having these restricted types: + +@ +('.-.') :: 'UTCTime' -> 'UTCTime' -> 'NominalDiffTime' +('.+^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime' +('.-^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime' +@ + +In turn 'NominalDiffTime' is an instance of 'VectorSpace' (and also +'AdditiveGroup') which comes with the following operations: + +@ +('^+^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime' +('^-^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime' +@ + +Said instance also defines @type 'Scalar' 'NominalDiffTime' = 'Rational'@, +so we can scale 'NominalDiffTime's thusly: + +@ +('*^') :: 'Rational' -> 'NominalDiffTime' -> 'NominalDiffTime' +('^*') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime' +('^/') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime' +@ + +On operator naming: remember that @.@ are points, and @^@ are vectors. +Thus @('.+^')@ corresponds to the operation /point plus vector/, and +@('^-^')@ means /vector minus vector/, and so on. + +Similarly, 'AbsoluteTime' is an 'AffineSpace', and 'DiffTime' is +a 'VectorSpace', with + +@ +type 'Diff' 'AbsoluteTime' = 'DiffTime' +type 'Scalar' 'DiffTime' = 'Rational' +@ + +If you must have 'Num', 'Real', 'Fractional', and 'RealFrac' for 'DiffTime' +and 'NominalDiffTime', they are provided as orhpan instances in the +"Data.Thyme.Time" module. + +-}{- }}} -} + +{- {{{ lenses -} +{- $lenses + +Since a large part of @thyme@'s functionality is involved in converting back +and forth between various representations of time, it's convenient to expose +these as "Control.Lens.Iso"s from the +@<http://hackage.haskell.org/package/lens lens>@ package, and field +accessors as "Control.Lens.Lens"es. + +A full @lens@ <https://www.google.com/search?q=haskell+lens+tutorial tutorial> +is however beyond the scope of this documentation. As far as /using/ @thyme@ +is concerned, it's sufficient to restrict ourselves to a subset of the +@lens@ API: + +@ +'view' :: 'Lens'' s a -> s -> a +'review' :: 'Iso'' s a -> a -> s +'over' :: 'Lens'' s a -> (a -> a) -> s -> s +@ + +There are infix versions of the above: + +@ +('^.') = 'flip' 'view' +('Control.Lens.#') = 'review' +('%~') = 'over' +@ + +An 'Iso'' can be used wherever a 'Lens'' is required, so it is helpful to +think of 'view' and 'over' as also having the following types: + +@ +'view' :: 'Iso'' s a -> s -> a +'over' :: 'Iso'' s a -> (a -> a) -> s -> s +@ + +You can use a @'Lens'' s a@ to extract an @a@ out of an @s@ with 'view'. An +'Iso' s a' means you can also construct an @s@ from an @a@ with 'review'. +Furthermore 'Lens''s and 'Iso''s can be chained with the standard @('.')@ +function composition. + +@ +('.') :: 'Lens'' s u -> 'Lens'' u a -> 'Lens'' s a +('.') :: 'Iso'' s u -> 'Iso'' u a -> 'Iso'' s a +@ + +Composing an 'Iso'' with a 'Lens'' however ‘downgrades’ the result to +a 'Lens''. + +The <#tutorial tutorial below> has some examples. + +-}{- }}} -} + +{- {{{ tutorial -} +{- $tutorial + +Start @ghci@ with the @lens@ and @vector-space@ packages, along with some +preliminary imports: + +@ +$ ghci -package thyme -package lens -package vector-space +> import "Control.Lens" +> import "Data.AffineSpace" +> import "Data.Thyme" +> import "Data.VectorSpace" +@ + +Let's begin by getting the current UTC date and time from the local system +clock: + +@ +> now <- 'getCurrentTime' +> now +2016-04-06 03:50:11.159991 UTC +@ + +What date and time is it in my local time zone, formatted using the default +locale? + +@ +> zone <- 'getCurrentTimeZone' +> 'formatTime' 'defaultTimeLocale' \"%c\" $ (zone, now) '^.' 'zonedTime' +"Wed Apr 6 12:50:11 JST 2016" +@ + +See also: 'getZonedTime'. + +What will be the local time-of-day be /1000/ seconds from now? + +@ +> (now '.+^' 'fromSeconds'' 1000) '^.' 'utcLocalTime' zone '.' '_localTimeOfDay' +12:50:11.159991 +@ + +Approximately how long has it been since the Unix epoch at midnight +/1970-01-01/? + +@ +> import "Data.Thyme.Format.Human" +> let posixEpoch = 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 1970 1 1) 'zeroV' +> 'humanTimeDiff' (now '.-.' posixEpoch) +"5 decades" +@ + +Two months from today, what day of the week will it be? + +@ +> import "Data.Thyme.Calendar.WeekDate" +> let later = now '&' '_utctDay' '.' 'gregorian' '%~' 'gregorianMonthsClip' 2 +> later +2016-06-06 03:50:11.159991 UTC +> later '^.' '_utctDay' '.' 'weekDate' +'WeekDate' {'wdYear' = 2016, 'wdWeek' = 23, 'wdDay' = 1} +> 'formatTime' 'defaultTimeLocale' \"%A\" later +"Monday" +@ + +-}{- }}} -} + +{- {{{ impl -} +{- $impl + +The performance improvement of "Data.Thyme" comes chiefly from representing +times internally as a single @newtype@d 'Int64's instead of multiple +'GHC.Integer.GMP.Internals.Integer's, as is the case with +"Data.Time.Clock"@.@'T.UTCTime'. The trade-offs are summarised below. + +-}{- }}} -} + +{- {{{ range -} +{- $range + +'T.UTCTime' from "Data.Time.Clock" has unbounded range, whereas 'UTCTime' +from "Data.Thyme.Clock" has a usable range just under 600,000 years, between +the following times inclusive: + +@ +-290419-11-07 19:59:05.224192 UTC + 294135-11-26 04:00:54.775807 UTC +@ + +@thyme@ is therefore not Y294K-compliant. + +-}{- }}} -} + +{- {{{ prec -} +{- $prec + +'UTCTime', 'NominalDiffTime', 'DiffTime', and so on from "Data.Thyme.Clock" +have resolutions of /1 μs/ = /10^-6 s/, while those from "Data.Time.Clock" +have resolutions of /1 ps/ = /10^-12 s/. + +However keep in mind that a call to @gettimeofday(3)@ or @clock_gettime(3)@ +takes on the order of ~0.4μs on a relatively recent (circa 2016) desktop, so +the coarser resolution is not really an issue in almost all applications. + +-}{- }}} -} + +{- {{{ perf -} +{- $perf + +"Data.Thyme.Clock"@.@'UTCTime' is implemented as @newtype@ wrappers around +a single 'Int64', so that 'addUTCTime' and 'diffUTCTime' both compile down +to a single arithmetic operation. Likewise "Data.Thyme.Clock"@.@'DiffTime' +(and 'NominalDiffTime') are also @newtype@s over 'Int64's. + +"Data.Time.Clock"@.@'T.UTCTime' on the other hand comprises of two +'Integer's internally: one for the 'T.Day' and another for the 'T.DiffTime' +time-of-day. Here 'T.diffUTCTime' has to account for the difference in +'T.Day's, while 'T.addUTCTime' must normalise its result to ensure +'T.utctDayTime' stays within 'T.posixDayLength'. + +Furthermore, any "Data.Time.Clock"@.@'T.DiffTime' (and 'T.NominalDiffTime') +longer than /~2.15 ms/ exceeds /2^31 ps/, and would overflow a native +'GHC.Prim.Int#' on 32-bit architectures, incurring the cost of using +'GHC.Integer.GMP.Internals.BigNat's inside +'GHC.Integer.GMP.Internals.Integer'. Even for 64-bit 'Int#'s, /2^63 ps/ +corresponds to only /~106 days/, and it's not inconceivable to deal with +durations longer than this. In both cases, there is the additional overhead +of working with lifted 'GHC.Integer.GMP.Internals.Integer's. + +-}{- }}} -} +
src/Data/Thyme/Format.hs view
@@ -1,726 +1,989 @@-{-# 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)-+{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans -Wno-unused-record-wildcards #-} + +#include "thyme.h" + +-- | Formatting and parsing for dates and times. +module Data.Thyme.Format + ( + -- * Formatting Date/Time to String + FormatTime (..) + , formatTime + -- * Parsing Date/Time from String + , ParseTime (..) + , parseTime + , readTime + , readsTime + , TimeParse (..) + , timeParser + + -- * Time Locale + , TimeLocale (..) + , defaultTimeLocale + ) 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 + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (TimeLocale (..), defaultTimeLocale) +#else +import System.Locale +#endif + +-- | All instances of this class may be formatted by 'formatTime'. +class FormatTime t where + showsTime + :: TimeLocale + -> t + -> (Char -> ShowS) + -> Char + -> ShowS + + +-- TODO Here are the formatting codes from the @time@ library which are not +-- implemented. +-- +-- [@%t@] tab +-- +-- [@%n@] newline +-- +-- === glibc-style modifiers can be used before the letter (here marked as @z@) +-- +-- [@%-z@] no padding +-- +-- [@%_z@] pad with spaces +-- +-- [@%0z@] pad with zeros +-- +-- [@%^z@] convert to upper case +-- +-- [@%#z@] convert to lower case (consistently, unlike glibc) +-- +-- === For 'UTCTime' and 'ZonedTime' +-- [@%s@] doesn't work for 'ZonedTime' +-- +-- [@%Y@] Note __@%0Y@__ and __@%_Y@__ pad to four chars +-- +-- [@%G@] Note __@%0G@__ and __@%_G@__ pad to four chars +-- +-- [@%f@] Note __@%0f@__ and __@%_f@__ pad to two chars +-- +-- [@%C@] Note __@%0C@__ and __@%_C@__ pad to two chars +-- +-- +-- TODO Format codes for week-of-month? +-- +-- TODO It's impossible to print out an ordinal day of month or day of week +-- without padding. Implement the @time@ padding modifiers? Of course +-- the work-around, the 'Show' instance for 'Int', isn't too bad. +-- +-- TODO drop the dependency on @old-locale@ for the TimeLocale type? + + + +-- | Format a 'FormatTime' instance value according to a template string. +-- +-- These formatting template codes are intended to be compatible with +-- __@glibc@__ @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime()>@ +-- function, following "Data.Time.Format", which +-- follows 'System.Time.formatCalendarTime' from the @old-time@ package. +-- Codes which differ from @strftime()@ are marked as +-- /EXTENSION/. +-- +-- == Show/Parse template string spec +-- +-- === For all types +-- +-- [@%%@] literal @\"%\"@ +-- +-- === For 'TimeZone' (and 'ZonedTime' and 'UTCTime'): +-- +-- [@%z@] RFC 822/ISO 8601:1988 style numeric time zone (e.g., @\"-0600\"@ or @\"+0100\"@) +-- +-- [@%N@] ISO 8601 style numeric time zone (e.g., @\"-06:00\"@ or @\"+01:00\"@) /EXTENSION/ +-- +-- [@%Z@] timezone name +-- +-- === For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime') +-- +-- [@%c@] The preferred calendar time representation for the current locale. As 'dateTimeFmt' @locale@ (e.g. __@%a %b %e %H:%M:%S %Z %Y@__) +-- +-- === For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime') +-- +-- [@%R@] same as __@%H:%M@__ +-- +-- [@%T@] same as __@%H:%M:%S@__ +-- +-- [@%X@] The preferred time of day representation for the current locale. As 'timeFmt' @locale@ (e.g. __@%H:%M:%S@__) +-- +-- [@%r@] The complete calendar time using the AM/PM format of the current locale. As 'time12Fmt' @locale@ (e.g. __@%I:%M:%S %p@__) +-- +-- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @\"am\"@, @\"pm\"@ +-- +-- [@%p@] day-half of day from ('amPm' @locale@), @\"AM\"@, @\"PM\"@ +-- +-- [@%H@] hour of day (24-hour), 0-padded to two chars, @\"00\"@–@\"23\"@ +-- +-- [@%k@] hour of day (24-hour), space-padded to two chars, @\" 0\"@–@\"23\"@ +-- +-- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @\"01\"@–@\"12\"@ +-- +-- [@%l@] hour of day-half (12-hour), space-padded to two chars, @\" 1\"@–@\"12\"@ +-- +-- [@%M@] minute of hour, 0-padded to two chars, @\"00\"@–@\"59\"@ +-- +-- [@%S@] second of minute (without decimal part), 0-padded to two chars, @\"00\"@–@\"60\"@ +-- +-- [@%q@] picosecond of second, 0-padded to twelve chars, @\"000000000000\"@–@\"999999999999\"@. /EXTENSION/ +-- +-- [@%v@] microsecond of second, 0-padded to six chars, @\"000000\"@–@\"999999\"@. /EXTENSION/ +-- +-- [@%Q@] decimal point and fraction of second, up to 6 second decimals, without trailing zeros. +-- For a whole number of seconds, __@%Q@__ produces the empty string. /EXTENSION/ +-- +-- === For 'UTCTime' +-- +-- [@%s@] number of whole seconds since the Unix epoch. For times before +-- the Unix epoch, this is a negative number. Note that in __@%s.%q@__ and __@%s%Q@__ +-- the decimals are positive, not negative. For example, 0.9 seconds +-- before the Unix epoch is formatted as @\"-1.1\"@ with __@%s%Q@__. +-- +-- === For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime') +-- +-- [@%D@] same as __@%m\/%d\/%y@__ +-- +-- [@%F@] same as __@%Y-%m-%d@__ +-- +-- [@%x@] as 'dateFmt' @locale@ (e.g. __@%m\/%d\/%y@__) +-- +-- [@%Y@] year, no padding. +-- +-- [@%y@] year of century, 0-padded to two chars, @\"00\"@–@\"99\"@ +-- +-- [@%C@] century, no padding. +-- +-- [@%B@] month name, long form ('fst' from 'months' @locale@), @\"January\"@–@\"December\"@ +-- +-- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @\"Jan\"@–@\"Dec\"@ +-- +-- [@%m@] month of year, 0-padded to two chars, @\"01\"@–@\"12\"@ +-- +-- [@%d@] day of month, 0-padded to two chars, @\"01\"@–@\"31\"@ +-- +-- [@%e@] day of month, space-padded to two chars, @\" 1\"@–@\"31\"@ +-- +-- [@%j@] day of year, 0-padded to three chars, @\"001\"@–@\"366\"@ +-- +-- [@%G@] year for Week Date format, no padding. +-- +-- [@%g@] year of century for Week Date format, 0-padded to two chars, @\"00\"@–@\"99\"@ +-- +-- [@%f@] century for Week Date format, no padding. /EXTENSION/ +-- +-- [@%V@] week of year for Week Date format, 0-padded to two chars, @\"01\"@–@\"53\"@ +-- +-- [@%u@] day of week for Week Date format, @\"1\"@–@\"7\"@ +-- +-- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @\"Sun\"@–@\"Sat\"@ +-- +-- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @\"Sunday\"@–@\"Saturday\"@ +-- +-- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @\"00\"@–@\"53\"@ +-- +-- [@%w@] day of week number, @\"0\"@ (= Sunday) – @\"6\"@ (= Saturday) +-- +-- [@%W@] week of year where weeks start on Monday (as 'Data.Thyme.Calendar.WeekdayOfMonth.mondayStartWeek'), 0-padded to two chars, @\"00\"@–@\"53\"@ +-- +-- == Examples +-- +-- ==== <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601> +-- @ +-- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" $ 'mkUTCTime' 2015 1 15 12 34 56.78 +-- "2015-01-15T12:34:56+00:00" +-- @ +-- +-- ==== <http://tools.ietf.org/html/rfc822#section-5 RFC822> +-- @ +-- > 'formatTime' 'defaultTimeLocale' "%a, %_d %b %Y %H:%M:%S %Z" $ 'mkUTCTime' 2015 1 15 12 34 56.78 +-- "Thu, 15 Jan 2015 12:34:56 UTC" +-- @ +-- +-- ==== YYYY-MM-DD hh:mm:ss.000000 +-- @ +-- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%d %H:%M:%S.%v" $ 'mkUTCTime' 2015 1 15 12 34 56.78 +-- "2015-01-15 12:34:56.780000" +-- @ +{-# INLINEABLE formatTime #-} +formatTime :: (FormatTime t) + => TimeLocale + -- ^ Locale for formatting. + -> String + -- ^ Template spec string. + -> t + -- ^ 'FormatTime' instance value to be formatted. + -> 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 + +-- | 'ShowS' a year with a minimum of four digits (even in the first +-- millennium), to comply with +-- <https://en.wikipedia.org/wiki/ISO_8601#Years ISO 8601 Years>. +{-# 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" + 'v' -> fills06 su . shows su + '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) + 'N' -> (++) (timeZoneOffsetStringColon 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 tum) . utcLocalTime utc + tum = TAIUTCMap mempty mempty + +------------------------------------------------------------------------ + +data TimeFlag + = PostMeridiem + | TwelveHour + | HasCentury + | IsPOSIXTime + | IsOrdinalDate + | IsGregorian + | IsWeekDate + | IsSundayWeek + | IsMondayWeek + deriving (Enum, Show) + +-- | Unconstituted date-time for parsing. +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) + +-- | Produce a 'Parser' for UTF-8 encoded 'ByteString's. +-- +-- This function is used internally by 'parseTime', 'readTime', and 'readsTime'; +-- consider using one of those functions instead. +-- +-- 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 + -- ^ Locale. + -> String + -- ^ Parser template spec string. See 'formatTime' for spec. + -> 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 + 'v' -> 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 + 'N' -> 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 + +-- | Parse a string as a 'ParseTime' instance value. +-- +-- Return 'Nothing' if parsing fails. +-- +-- === Examples +-- +-- ==== <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601> +-- @ +-- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" "2015-01-15T12:34:56+00:00" :: 'Maybe' 'UTCTime' +-- Just 2015-01-15 12:34:56 UTC +-- +-- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" "2015-01-15T12:34:56-12:00" :: 'Maybe' 'UTCTime' +-- Just 2015-01-16 00:34:56 UTC +-- @ +-- +-- ==== YYYY-MM-DD hh:mm:ss.0 +-- @ +-- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%d %H:%M:%S%Q" "2015-01-15 12:34:56.78" :: 'Maybe' 'UTCTime' +-- Just 2015-01-15 12:34:56.78 UTC +-- @ +{-# INLINEABLE parseTime #-} +parseTime :: (ParseTime t) + => TimeLocale + -- ^ Locale. + -> String + -- ^ Parser template spec string. See 'formatTime' for spec. + -> String + -- ^ String value to be parsed as a 'ParseTime' instance value. + -> 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 + +-- | Parse a string as a 'ParseTime' instance value. +-- +-- Call 'error' if parsing fails. +{-# INLINEABLE readTime #-} +readTime :: (ParseTime t) + => TimeLocale + -- ^ Locale. + -> String + -- ^ Parser template spec string. See 'formatTime' for spec. + -> String + -- ^ String value to be parsed as a 'ParseTime' instance value. + -> t +readTime l spec = either error id . P.parseOnly parser . utf8String where + parser = buildTime <$ P.skipSpace <*> timeParser l spec + <* P.skipSpace <* P.endOfInput + +-- | Produce a 'ReadS' to parse a string as a 'ParseTime' instance value. +{-# INLINEABLE readsTime #-} +readsTime :: (ParseTime t) + => TimeLocale + -- ^ Locale. + -> String + -- ^ Parser template spec string. See 'formatTime' for spec. + -> 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 + +------------------------------------------------------------------------ + +-- | All instances of this class may be parsed by 'parseTime', 'readTime', and +-- 'readsTime'. +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 (TAIUTCMap mempty mempty) + +------------------------------------------------------------------------ + +-- 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) +
src/Data/Thyme/Format/Aeson.hs view
@@ -1,102 +1,108 @@-{-# 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 #-}-+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if HLINT +#include "cabal_macros.h" +#endif + +-- | 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 +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif +import Data.Text (pack, unpack) +import qualified Data.Text as T +import Data.Thyme + +-- 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 #-} +
src/Data/Thyme/Format/Human.hs view
@@ -1,87 +1,94 @@-{-# 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', ..}-+{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +#include "thyme.h" +#if HLINT +#include "cabal_macros.h" +#endif + +-- | Vague textual descriptions of time durations. +module Data.Thyme.Format.Human + ( humanTimeDiff + , humanTimeDiffs + , humanRelTime + , humanRelTimes + ) where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +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', ..} +
src/Data/Thyme/Format/Internal.hs view
@@ -1,147 +1,147 @@-{-# 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-+{-# 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 +
src/Data/Thyme/Internal/Micro.hs view
@@ -1,106 +1,107 @@-{-# 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-+{-# 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.Hashable +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 + {-# INLINE (*^) #-} + s *^ Micro a = Micro . fromInteger $ -- 'round'-to-even + 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 +
src/Data/Thyme/LocalTime.hs view
@@ -1,381 +1,671 @@-{-# 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)-+{-# 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" +#if HLINT +#include "cabal_macros.h" +#endif + +-- | Local time and time zones. +module Data.Thyme.LocalTime + ( Hour, Minute + , module Data.Thyme.LocalTime + ) where + +import Prelude hiding ((.)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +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.Hashable +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 ((.&.)) + +-- | Hours duration. +type Hours = Int +-- | Minutes duration. +type Minutes = Int + +------------------------------------------------------------------------ +-- * Time Zones + +-- | Description of one time zone. +-- +-- A 'TimeZone' is a whole number of minutes offset from UTC, together with +-- a name and a ‘summer time’ flag. +data TimeZone = TimeZone + { timeZoneMinutes :: {-# UNPACK #-}!Minutes + -- ^ The number of minutes offset from UTC. + , timeZoneSummerOnly :: !Bool + -- ^ Is this a summer-only (i.e. daylight savings) time zone? + , timeZoneName :: String + -- ^ The name of the zone, typically a three- or four-letter acronym. + } deriving (INSTANCES_USUAL) + +LENS(TimeZone,timeZoneMinutes,Minutes) +LENS(TimeZone,timeZoneSummerOnly,Bool) +LENS(TimeZone,timeZoneName,String) + +instance Hashable TimeZone +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 'Data.Thyme.Format.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) + +-- | Text representing the offset of this timezone in ISO 8601 style, +-- e.g. \"-08:00\" or +-- \"+04:00\" (like @%N@ in 'Data.Thyme.Format.formatTime') +{-# INLINEABLE timeZoneOffsetStringColon #-} +timeZoneOffsetStringColon :: TimeZone -> String +timeZoneOffsetStringColon 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) + +-- | The UTC (Zulu) time zone. +-- +-- @ +-- 'utc' = 'TimeZone' 0 'False' \"UTC\" +-- @ +utc :: TimeZone +utc = TimeZone 0 False "UTC" + +-- | Get the local time zone at the given time, varying as per summer time +-- adjustments. +-- +-- Performed by +-- <https://www.gnu.org/software/libc/manual/html_node/Broken_002ddown-Time.html localtime_r> +-- or a similar call. +{-# INLINEABLE getTimeZone #-} +getTimeZone :: UTCTime -> IO TimeZone +getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where + day = T.ModifiedJulianDay (toInteger mjd) + UTCView (ModifiedJulianDay mjd) dt = t ^. utcTime + thyme T.TimeZone {..} = TimeZone {..} + +-- | Get the current local time zone. +-- +-- @ +-- 'getCurrentTimeZone' = 'getCurrentTime' >>= 'getTimeZone' +-- @ +-- +-- @ +-- > 'getCurrentTimeZone' +-- JST +-- @ +{-# INLINE getCurrentTimeZone #-} +getCurrentTimeZone :: IO TimeZone +getCurrentTimeZone = getCurrentTime >>= getTimeZone + +------------------------------------------------------------------------ +-- * Time of Day + +-- | Time of day in hour, minute, second. +data TimeOfDay = TimeOfDay + { todHour :: {-# UNPACK #-}!Hour + , todMin :: {-# UNPACK #-}!Minute + , todSec :: {-# UNPACK #-}!DiffTime -- ^ Second. + } deriving (INSTANCES_USUAL) + +LENS(TimeOfDay,todHour,Hour) +LENS(TimeOfDay,todMin,Minute) +LENS(TimeOfDay,todSec,DiffTime) + +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 Hashable TimeOfDay +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 + +-- | The maximum possible length of a minute. Always /60s/, except at +-- /23:59/ due to leap seconds. +-- +-- @ +-- 'minuteLength' 23 59 = 'fromSeconds'' 61 +-- 'minuteLength' _ _ = 'fromSeconds'' 60 +-- @ +{-# INLINE minuteLength #-} +minuteLength :: Hour -> Minute -> DiffTime +minuteLength 23 59 = fromSeconds' 61 +minuteLength _ _ = fromSeconds' 60 + +-- | Hour zero, midnight. +-- +-- @ +-- 'midnight' = 'TimeOfDay' 0 0 'zeroV' +-- @ +midnight :: TimeOfDay +midnight = TimeOfDay 0 0 zeroV + +-- | Hour twelve, noon. +-- +-- @ +-- 'midday' = 'TimeOfDay' 12 0 'zeroV' +-- @ +midday :: TimeOfDay +midday = TimeOfDay 12 0 zeroV + +-- | Construct a 'TimeOfDay' from the hour, minute, and second. +-- +-- Returns 'Nothing' if these constraints are not satisfied: +-- +-- * /0 ≤ @hour@ ≤ 23/ +-- * /0 ≤ @minute@ ≤ 59/ +-- * /0 ≤ @second@ < 'minuteLength' @hour@ @minute@/ +{-# 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) + +-- | Conversion between 'DiffTime' and 'TimeOfDay'. +-- +-- @ +-- > 'fromSeconds'' 100 '^.' 'timeOfDay' +-- 00:01:40 +-- +-- > 'timeOfDay' 'Control.Lens.#' 'TimeOfDay' 0 1 40 +-- 100s +-- @ +{-# 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'; the result includes a day adjustment. +-- +-- @ +-- > 'addMinutes' 10 ('TimeOfDay' 23 55 0) +-- (1,00:05:00) +-- @ +{-# 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 + +-- | Conversion between 'TimeOfDay' and the fraction of a day. +-- +-- @ +-- > 'TimeOfDay' 6 0 0 '^.' 'dayFraction' +-- 1 % 4 +-- > 'TimeOfDay' 8 0 0 '^.' 'dayFraction' +-- 1 % 3 +-- +-- > 'dayFraction' 'Control.Lens.#' (1 / 4) +-- 06:00:00 +-- > 'dayFraction' 'Control.Lens.#' (1 / 3) +-- 08:00:00 +-- @ +{-# 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 + +-- | Local calendar date and time-of-day. +-- +-- This type is appropriate for inputting from and outputting to the +-- outside world. +-- +-- To actually perform logic and arithmetic on local date-times, a 'LocalTime' +-- should first be converted to a 'UTCTime' by the 'utcLocalTime' Iso. +-- +-- See also: 'ZonedTime'. +data LocalTime = LocalTime + { localDay :: {-# UNPACK #-}!Day + -- ^ Local calendar date. + , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay + -- ^ Local time-of-day. + } deriving (INSTANCES_USUAL) + +LENS(LocalTime,localDay,Day) +LENS(LocalTime,localTimeOfDay,TimeOfDay) + +derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |] + [| \ LocalTime {..} -> (localDay, localTimeOfDay) |] + [| \ (localDay, localTimeOfDay) -> LocalTime {..} |] + +instance Hashable 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 + +-- | Conversion between 'UTCTime' and 'LocalTime'. +-- +-- @ +-- > tz <- 'getCurrentTimeZone' +-- +-- > 'timeZoneName' tz +-- \"JST\" +-- +-- > 'timeZoneOffsetString' tz +-- \"+0900\" +-- +-- > now <- 'getCurrentTime' +-- > now +-- 2016-04-23 02:00:00.000000 UTC +-- +-- > let local = now '^.' 'utcLocalTime' tz +-- > local +-- 2016-04-23 11:00:00.000000 +-- +-- > 'utcLocalTime' tz 'Control.Lens.#' local +-- 2016-04-23 02:00:00.000000 UTC +-- @ +-- +-- See also: 'zonedTime'. +{-# INLINE utcLocalTime #-} +utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime +utcLocalTime TimeZone {..} = utcTime . iso localise globalise where + + {-# INLINEABLE localise #-} + localise :: UTCView -> LocalTime + localise (UTCView day dt) = LocalTime (day .+^ dd) tod where + (dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay) + + {-# INLINEABLE globalise #-} + globalise :: LocalTime -> UTCView + globalise (LocalTime day tod) = UTCView (day .+^ dd) + (timeOfDay # utcToD) where + (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod + +-- | Conversion between 'UniversalTime' and 'LocalTime'. +{-# 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 + +-- | A 'LocalTime' and its 'TimeZone'. +-- +-- This type is appropriate for inputting from and outputting to the +-- outside world. +-- +-- To actually perform logic and arithmetic on local date-times, a 'ZonedTime' +-- should first be converted to a 'UTCTime' by the 'zonedTime' Iso. +data ZonedTime = ZonedTime + { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime + , zonedTimeZone :: !TimeZone + } deriving (INSTANCES_USUAL) + +LENS(ZonedTime,zonedTimeToLocalTime,LocalTime) +LENS(ZonedTime,zonedTimeZone,TimeZone) + +instance Hashable ZonedTime +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 + +-- | Conversion between ('TimeZone', 'UTCTime') and 'ZonedTime'. +-- +-- @ +-- > now <- 'getZonedTime' +-- > now +-- 2016-04-04 16:00:00.000000 JST +-- +-- > 'zonedTime' 'Control.Lens.#' now +-- (JST,2016-04-04 07:00:00.000000 UTC) +-- +-- > ('zonedTime' 'Control.Lens.#' now) '^.' 'zonedTime' +-- 2016-04-04 16:00:00.000000 JST +-- @ +-- +-- See also: 'utcLocalTime'. +{-# 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 + +-- | Get the current local date, time, and time zone. +-- +-- @ +-- > 'getZonedTime' +-- 2016-04-23 11:57:22.516064 JST +-- @ +-- +-- See also: 'getCurrentTime', 'Data.Thyme.Clock.POSIX.getPOSIXTime'. +{-# INLINE getZonedTime #-} +getZonedTime :: IO ZonedTime +getZonedTime = utcToLocalZonedTime =<< getCurrentTime + +-- | Convert a 'UTCTime' to a 'ZonedTime' according to the local time zone +-- returned by 'getTimeZone'. +-- +-- See also: 'zonedTime'. +{-# INLINEABLE utcToLocalZonedTime #-} +utcToLocalZonedTime :: UTCTime -> IO ZonedTime +utcToLocalZonedTime time = do + tz <- getTimeZone time + return $ (tz, time) ^. zonedTime + +-- * Compatibility + +-- | Convert a UTC 'TimeOfDay' to a 'TimeOfDay' in some timezone, together +-- with a day adjustment. +-- +-- @ +-- 'utcToLocalTimeOfDay' = 'addMinutes' '.' 'timeZoneMinutes' +-- @ +{-# INLINE utcToLocalTimeOfDay #-} +utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) +utcToLocalTimeOfDay = addMinutes . timeZoneMinutes + +-- | Convert a 'TimeOfDay' in some timezone to a UTC 'TimeOfDay', together +-- with a day adjustment. +-- +-- @ +-- 'localToUTCTimeOfDay' = 'addMinutes' '.' 'negate' '.' 'timeZoneMinutes' +-- @ +{-# INLINE localToUTCTimeOfDay #-} +localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) +localToUTCTimeOfDay = addMinutes . negate . timeZoneMinutes + +-- | Convert a 'DiffTime' of the duration since midnight to a 'TimeOfDay'. +-- Durations exceeding 24 hours will be treated as leap-seconds. +-- +-- @ +-- 'timeToTimeOfDay' = 'view' 'timeOfDay' +-- 'timeToTimeOfDay' d ≡ d '^.' 'timeOfDay' +-- @ +{-# INLINE timeToTimeOfDay #-} +timeToTimeOfDay :: DiffTime -> TimeOfDay +timeToTimeOfDay = view timeOfDay + +-- | Convert a 'TimeOfDay' to a 'DiffTime' of the duration since midnight. +-- 'TimeOfDay' greater than 24 hours will be treated as leap-seconds. +-- +-- @ +-- 'timeOfDayToTime' = 'review' 'timeOfDay' +-- 'timeOfDayToTime' tod ≡ 'timeOfDay' 'Control.Lens.#' tod +-- @ +{-# INLINE timeOfDayToTime #-} +timeOfDayToTime :: TimeOfDay -> DiffTime +timeOfDayToTime = review timeOfDay + +-- | Convert a fraction of a day since midnight to a 'TimeOfDay'. +-- +-- @ +-- 'dayFractionToTimeOfDay' = 'review' 'dayFraction' +-- @ +{-# INLINE dayFractionToTimeOfDay #-} +dayFractionToTimeOfDay :: Rational -> TimeOfDay +dayFractionToTimeOfDay = review dayFraction + +-- | Convert a 'TimeOfDay' to a fraction of a day since midnight. +-- +-- @ +-- 'timeOfDayToDayFraction' = 'view' 'dayFraction' +-- @ +{-# INLINE timeOfDayToDayFraction #-} +timeOfDayToDayFraction :: TimeOfDay -> Rational +timeOfDayToDayFraction = view dayFraction + +-- | Convert a 'UTCTime' to a 'LocalTime' in the given 'TimeZone'. +-- +-- @ +-- 'utcToLocalTime' = 'view' '.' 'utcLocalTime' +-- @ +{-# INLINE utcToLocalTime #-} +utcToLocalTime :: TimeZone -> UTCTime -> LocalTime +utcToLocalTime tz = view (utcLocalTime tz) + +-- | Convert a 'LocalTime' in the given 'TimeZone' to a 'UTCTime'. +-- +-- @ +-- 'localTimeToUTC' = 'review' '.' 'utcLocalTime' +-- @ +{-# INLINE localTimeToUTC #-} +localTimeToUTC :: TimeZone -> LocalTime -> UTCTime +localTimeToUTC tz = review (utcLocalTime tz) + +-- | Convert a 'UniversalTime' to a 'LocalTime' at the given medidian in +-- degrees East. +-- +-- @ +-- 'ut1ToLocalTime' = 'view' '.' 'ut1LocalTime' +-- @ +{-# INLINE ut1ToLocalTime #-} +ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime +ut1ToLocalTime l = view (ut1LocalTime l) + +-- | Convert a 'LocalTime' at the given meridian in degrees East to +-- a 'UniversalTime'. +-- +-- @ +-- 'localTimeToUT1' = 'review' '.' 'ut1LocalTime' +-- @ +{-# INLINE localTimeToUT1 #-} +localTimeToUT1 :: Rational -> LocalTime -> UniversalTime +localTimeToUT1 l = review (ut1LocalTime l) + +-- | Convert a 'UTCTime' and the given 'TimeZone' into a 'ZonedTime'. +-- +-- @ +-- 'utcToZonedTime' z t = 'view' 'zonedTime' (z, t) +-- @ +{-# INLINE utcToZonedTime #-} +utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime +utcToZonedTime z t = view zonedTime (z, t) + +-- | Converts a 'ZonedTime' to a 'UTCTime'. +-- +-- @ +-- 'zonedTimeToUTC' = 'snd' '.' 'review' 'zonedTime' +-- @ +{-# INLINE zonedTimeToUTC #-} +zonedTimeToUTC :: ZonedTime -> UTCTime +zonedTimeToUTC = snd . review zonedTime +
src/Data/Thyme/Time.hs view
@@ -1,102 +1,78 @@-{-# 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 <https://github.com/liyang/thyme/issues>.--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 #-}-+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module provides 'Num', 'Real', 'Fractional', and 'RealFrac' +-- instances for 'DiffTime' and 'NominalDiffTime'. +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 #-} +
src/Data/Thyme/Time/Core.hs view
@@ -1,343 +1,155 @@-{-# 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-+{-# LANGUAGE CPP #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +#if HLINT +#include "cabal_macros.h" +#endif + +-- | This module provides the 'Thyme' typeclass, and instances for +-- converting between "Data.Time" and "Data.Thyme" types. It also provides +-- compatibility wrappers for existing code using "Data.Time". +-- +-- Note that we do not provide 'Num' hierarchy instances for 'DiffTime' nor +-- 'NominalDiffTime' here. If you want to use them anyway despite parts of +-- them being ill-defined (e.g. @('*')@ on 'DiffTime'), import +-- "Data.Thyme.Time" instead. + +module Data.Thyme.Time.Core + ( module Data.Thyme + , module Data.Thyme.Time.Core + ) where + +import Prelude +import Control.Lens +import Data.AffineSpace +import Data.Fixed +import Data.Ratio +import Data.Thyme +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 Data.Thyme.TrueName + +------------------------------------------------------------------------ +-- * Type conversion + +-- | Typeclass for converting between "Data.Time" and "Data.Thyme" types. +class Thyme time thyme | thyme -> time where + -- | Convert between "Data.Time" and "Data.Thyme" types. + -- + -- @ + -- > :set -t + -- > import qualified "Data.Time" + -- + -- > 'thyme' 'Control.Lens.#' ('fromSeconds'' 10 :: 'DiffTime') + -- 10s + -- it :: 'Data.Time.DiffTime' + -- + -- > 'Data.Time.secondsToDiffTime' 10 '^.' 'thyme' :: 'DiffTime' + -- 10s + -- it :: 'DiffTime' + -- @ + thyme :: Iso' time thyme + +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 = dt . fixed . from picoseconds where + dt = iso (\ [truename| ''T.DiffTime MkDiffTime | ps |] -> ps ) + [truename| ''T.DiffTime MkDiffTime |] +#if MIN_VERSION_base(4,7,0) + fixed = iso (\ (MkFixed n) -> n ) MkFixed +#else + fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n ) + [truename| ''Fixed MkFixed |] +#endif + +instance Thyme T.NominalDiffTime NominalDiffTime where + {-# INLINE thyme #-} + thyme = ndt . fixed . from picoseconds where + ndt = iso (\ [truename| ''T.NominalDiffTime MkNominalDiffTime | ps |] -> ps ) + [truename| ''T.NominalDiffTime MkNominalDiffTime |] +#if MIN_VERSION_base(4,7,0) + fixed = iso (\ (MkFixed n) -> n ) MkFixed +#else + fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n ) + [truename| ''Fixed MkFixed |] +#endif + +instance Thyme T.UTCTime UTCView where + {-# INLINE thyme #-} + thyme = iso + (\ (T.UTCTime d t) -> UTCView (d ^. thyme) (t ^. thyme)) + (\ (UTCView 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)) + +-- | Convert a "Data.Time" type to a "Data.Thyme" type, if you would rather +-- not use "Control.Lens" directly. +-- +-- @ +-- 'toThyme' = 'view' 'thyme' +-- 'toThyme' t ≡ t '^.' 'thyme' +-- @ +{-# INLINE toThyme #-} +toThyme :: (Thyme time thyme) => time -> thyme +toThyme = view thyme + +-- | Convert a "Data.Thyme" type to a "Data.Time" type, if you would rather +-- not use "Control.Lens" directly. +-- +-- @ +-- 'fromThyme' = 'review' 'thyme' +-- 'fromThyme' t ≡ 'thyme' 'Control.Lens.#' t +-- @ +{-# INLINE fromThyme #-} +fromThyme :: (Thyme time thyme) => thyme -> time +fromThyme = review thyme +
+ src/Data/Thyme/TrueName.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE CPP #-} + +-- | Refer to <https://github.com/liyang/true-name/blob/master/test/sanity.hs these examples>. + +module Data.Thyme.TrueName (summon, truename) where + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad +import Data.List (nub) +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.PprLib +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax + +conNames :: Con -> [Name]{- {{{ -} +conNames con = case con of + NormalC name _ -> [name] + RecC name vbts -> name : [ fname | (fname, _, _) <- vbts ] + InfixC _ name _ -> [name] + ForallC _ _ con' -> conNames con' + +#if MIN_VERSION_template_haskell(2,11,0) + GadtC names _ typ -> names ++ typNames typ + RecGadtC names vbts typ -> names ++ typNames typ + ++ [ fname | (fname, _, _) <- vbts] +#endif +{- }}} -} + +decNames :: Dec -> [Name]{- {{{ -} +decNames dec = case dec of + FunD _ _ -> [] + ValD _ _ _ -> [] + TySynD _ _ typ -> typNames typ + ClassD _ _ _ _ decs -> decNames =<< decs +#if MIN_VERSION_template_haskell(2,11,0) + InstanceD _ cxt typ decs -> +#else + InstanceD cxt typ decs -> +#endif + (predNames =<< cxt) ++ typNames typ ++ (decNames =<< decs) + SigD name typ -> name : typNames typ + +#if MIN_VERSION_template_haskell(2,16,0) + KiSigD name kind -> name : typNames kind +#endif + + ForeignD frgn -> case frgn of + ImportF _ _ _ name t -> name : typNames t + ExportF _ _ name t -> name : typNames t + PragmaD _ -> [] + +#if MIN_VERSION_template_haskell(2,11,0) + DataD _ _ _ _ cons _ -> conNames =<< cons + NewtypeD _ _ _ _ con _ -> conNames con +#else + DataD _ _ _ cons _ -> conNames =<< cons + NewtypeD _ _ _ con _ -> conNames con +#endif + +#if MIN_VERSION_template_haskell(2,12,0) + PatSynD _name _args _dir _pat -> [] + PatSynSigD _name typ -> typNames typ +#endif + +#if MIN_VERSION_template_haskell(2,8,0) + InfixD _ _ -> [] +#endif + +#if MIN_VERSION_template_haskell(2,12,0) + DataInstD cxt _name _typs _kind cons derivs -> + datatypeNames cxt cons ++ derivNames derivs + NewtypeInstD cxt _name _typs _kind con derivs -> + datatypeNames cxt [con] ++ derivNames derivs +#elif MIN_VERSION_template_haskell(2,11,0) + DataInstD cxt _ _ _ cons derivs -> + datatypeNames cxt cons ++ (predNames =<< derivs) + NewtypeInstD cxt _ _ _ con derivs -> + datatypeNames cxt [con] ++ (predNames =<< derivs) +#else + DataInstD cxt _ _ cons derivs -> datatypeNames cxt cons ++ derivs + NewtypeInstD cxt _ _ con derivs -> datatypeNames cxt [con] ++ derivs +#endif + +#if MIN_VERSION_template_haskell(2,11,0) + DataFamilyD _ _ _ -> [] + OpenTypeFamilyD _ -> [] +#else + FamilyD _ _ _ _ -> [] +#endif + +#if MIN_VERSION_template_haskell(2,11,0) + ClosedTypeFamilyD _ tses -> tseNames =<< tses +#elif MIN_VERSION_template_haskell(2,9,0) + ClosedTypeFamilyD _ _ _ tses -> tseNames =<< tses +#endif + +#if MIN_VERSION_template_haskell(2,15,0) + TySynInstD tse -> tseNames tse +#elif MIN_VERSION_template_haskell(2,9,0) + TySynInstD _ tse -> tseNames tse +#else + TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t +#endif + +#if MIN_VERSION_template_haskell(2,9,0) + RoleAnnotD _ _ -> [] +#endif + +#if MIN_VERSION_template_haskell(2,12,0) + StandaloneDerivD _strat cxt typ -> (predNames =<< cxt) ++ typNames typ +#elif MIN_VERSION_template_haskell(2,10,0) + StandaloneDerivD cxt typ -> (predNames =<< cxt) ++ typNames typ +#endif + +#if MIN_VERSION_template_haskell(2,10,0) + DefaultSigD _ _ -> [] +#endif + +#if MIN_VERSION_template_haskell(2,15,0) + ImplicitParamBindD _ _ -> [] +#endif + +{- }}} -} + +datatypeNames :: Cxt -> [Con] -> [Name] +datatypeNames cxt cons = (conNames =<< cons) ++ (predNames =<< cxt) + +#if MIN_VERSION_template_haskell(2,12,0) +derivNames :: [DerivClause] -> [Name] +derivNames derivs = predNames =<< + [ p | DerivClause _strat cxt <- derivs, p <- cxt ] +#endif + +tseNames :: TySynEqn -> [Name] +#if MIN_VERSION_template_haskell(2,15,0) +tseNames (TySynEqn _ l r) = typNames l ++ typNames r +#elif MIN_VERSION_template_haskell(2,9,0) +tseNames (TySynEqn ts t) = (typNames =<< ts) ++ typNames t +#endif + +predNames :: Pred -> [Name]{- {{{ -} +#if MIN_VERSION_template_haskell(2,10,0) +predNames = typNames +#else +predNames p = case p of + ClassP n ts -> n : (typNames =<< ts) + EqualP s t -> typNames s ++ typNames t +#endif +{- }}} -} + +typNames :: Type -> [Name]{- {{{ -} +typNames typ = case typ of + ForallT _ c t -> (predNames =<< c) ++ typNames t + AppT s t -> typNames s ++ typNames t + SigT t _ -> typNames t + VarT _ -> [] + ConT name -> [name] + TupleT _ -> [] + UnboxedTupleT _ -> [] + ArrowT -> [] + ListT -> [] + +#if MIN_VERSION_template_haskell(2,8,0) + PromotedT _ -> [] + PromotedTupleT _ -> [] + PromotedNilT -> [] + PromotedConsT -> [] + StarT -> [] + ConstraintT -> [] + LitT _ -> [] +#endif + +#if MIN_VERSION_template_haskell(2,10,0) + EqualityT -> [] +#endif + +#if MIN_VERSION_template_haskell(2,11,0) + InfixT s n t -> n : typNames s ++ typNames t + UInfixT s n t -> n : typNames s ++ typNames t + ParensT t -> typNames t + WildCardT -> [] +#endif + +#if MIN_VERSION_template_haskell(2,12,0) + UnboxedSumT _arity -> [] +#endif + +#if MIN_VERSION_template_haskell(2,15,0) + AppKindT k t -> typNames k ++ typNames t + ImplicitParamT _ t -> typNames t +#endif + +#if MIN_VERSION_template_haskell(2,16,0) + ForallVisT _ t -> typNames t +#endif + +#if MIN_VERSION_template_haskell(2,17,0) + MulArrowT -> [] +#endif + +#if MIN_VERSION_template_haskell(2,19,0) + PromotedInfixT s n t -> n : typNames s ++ typNames t + PromotedUInfixT s n t -> n : typNames s ++ typNames t +#endif +{- }}} -} + +infoNames :: Info -> [Name]{- {{{ -} +infoNames info = case info of + ClassI dec _ -> decNames dec + TyConI dec -> decNames dec + FamilyI _ decs -> decNames =<< decs + PrimTyConI _ _ _ -> [] + TyVarI _ typ -> typNames typ + +#if MIN_VERSION_template_haskell(2,11,0) + ClassOpI _ typ _ -> typNames typ + DataConI _ typ parent -> parent : typNames typ + VarI _ typ _ -> typNames typ +#else + ClassOpI _ typ _ _ -> typNames typ + DataConI _ typ parent _ -> parent : typNames typ + VarI _ typ _ _ -> typNames typ +#endif + +#if MIN_VERSION_template_haskell(2,12,0) + PatSynI _name typ -> typNames typ +#endif +{- }}} -} + +{- {{{ -} +-- | Summons a 'Name' using @template-haskell@'s 'reify' function. +-- +-- The first argument is a 'String' matching the 'Name' we want: either its +-- 'nameBase', or qualified with its module. The second argument gives the +-- 'Name' to 'reify'. +-- +-- If no match is found or there is some ambiguity, 'summon' will fail with +-- a list of 'Name's found, along with the output of 'reify' for reference. +-- +-- Suppose we are given a module @M@ that exports a function @s@, but not +-- the type @T@, the constrcutor @C@, nor the field @f@: +-- +-- > module M (s) where +-- > newtype T = C { f :: Int } +-- > s :: T -> T +-- > s = C . succ . f +-- +-- In our own module we have no legitimate way of passing @s@ an argument of +-- type @T@. We can get around this in a type-safe way with 'summon': +-- +-- >{-# LANGUAGE TemplateHaskell #-} +-- >module Main where +-- >import Language.Haskell.TH.Syntax +-- >import Unsafe.TrueName +-- >import M +-- > +-- >type T = $(fmap ConT $ summon "T" 's) +-- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int +-- >mkC = $(fmap ConE $ summon "C" =<< summon "T" 's) +-- >unC $(fmap (`ConP` [VarP $ mkName "n"]) $ summon "C" =<< summon "T" 's) = n +-- >f = $(fmap VarE $ summon "f" =<< summon "T" 's) +-- > +-- >main :: IO () +-- >main = print (unC t, n) where +-- > t = s (mkC 42 :: T) +-- > n = f (s t) +-- +-- Note that 'summon' cannot obtain the 'Name' for an unexported function, +-- since GHC <http://hackage.haskell.org/package/template-haskell/docs/Language-Haskell-TH.html#v:VarI does not currently return the RHS of function definitons>. +-- The only workaround is to copypasta the definition. D: +{- }}} -} +summon :: String -> Name -> Q Name{- {{{ -} +summon name thing = do + info <- reify thing + let ns = nub (infoNames info) + case filter (\ n -> name == nameBase n || name == show n) ns of + [n] -> return n + _ -> fail $ "summon: you wanted " ++ show name ++ ", but I have:\n" + ++ unlines ((++) " " . namespace <$> ns) + ++ " reify " ++ show thing ++ " returned:\n" + ++ show (nest 8 $ ppr info) + where + namespace n@(Name _ flavour) = show n ++ case flavour of + NameG VarName _ _ -> " (var)" + NameG DataName _ _ -> " (cons)" + NameG TcClsName _ _ -> " (type)" + _ -> " (?)" +{- }}} -} + +{- {{{ -} +-- | A more convenient 'QuasiQuoter' interface to 'summon'. +-- +-- The first space-delimited token gives the initial 'Name' passed to +-- 'summon': it must be ‘quoted’ with a @'@ or @''@ prefix to indicate +-- whether it should be interpreted in an expression or a type context, +-- as per <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/template-haskell.html#th-syntax the usual TH syntax>. +-- Subsequent tokens correspond to the 'String' argument of 'summon', and +-- are iterated over. Thus +-- +-- > [truename| ''A B C D |] +-- +-- is roughly equivalent to: +-- +-- > summon "D" =<< summon "C" =<< summon "B" ''A +-- +-- but with the resulting 'Name' wrapped up in 'ConE', 'VarE', 'ConP', or +-- 'ConT', depending on the context. (There is no 'quoteDec'.) +-- +-- Variable bindings are given after a @|@ token in a 'Pat' context: +-- +-- > [truename| ''Chan Chan | chanR chanW |] <- newChan +-- +-- These may be prefixed with @!@ or @~@ to give the usual semantics. +-- A single @..@ token invokes @RecordWildCards@ in 'Pat' contexts, and for +-- record construction in 'Exp' contexts. +-- Nested or more exotic patterns are not supported. +-- +-- With this, the example from 'summon' may be more succinctly written: +-- +-- >{-# LANGUAGE QuasiQuotes #-} +-- >module Main where +-- >import Unsafe.TrueName +-- >import M +-- > +-- >type T = [truename| 's T |] +-- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int +-- >mkC = [truename| 's T C |] +-- >unC [truename| 's T C | n |] = n +-- >f = [truename| 's T f |] +-- > +-- >main :: IO () +-- >main = print (unC t, n) where +-- > t = s (mkC 42 :: T) +-- > n = f (s t) +{- }}} -} +truename :: QuasiQuoter{- {{{ -} +truename = QuasiQuoter + { quoteExp = makeE <=< nameVars + , quotePat = makeP <=< nameVars + , quoteType = makeT <=< nameVars + , quoteDec = \ _ -> err "I'm not sure how this would work" + } where + err = fail . (++) "truename: " + noPat = err . (++) "unexpected pattern variables: " . unwords + + makeT (name, vars) = ConT name <$ unless (null vars) (noPat vars) + makeE (name@(Name occ flavour), vars) = case flavour of + NameG VarName _ _ -> VarE name <$ unless (null vars) (noPat vars) + NameG DataName _ _ -> case vars of + [] -> return (ConE name) + [".."] -> RecConE name . capture VarE <$> recFields name + _ -> noPat vars + _ -> err $ occString occ ++ " has a strange flavour" + makeP (name, vars) = if vars == [".."] + then RecP name . capture VarP <$> recFields name + else +#if MIN_VERSION_template_haskell(2,18,0) + return $ ConP name [] (map pat vars) where +#else + return $ ConP name (map pat vars) where +#endif + pat n = case n of + "_" -> WildP + '!' : ns -> BangP (pat ns) + '~' : ns -> TildeP (pat ns) + _ -> VarP (mkName n) + capture v = map $ \ f -> (f, v (mkName $ nameBase f)) + + recFields :: Name -> Q [Name] + recFields name = do + parent <- reify name >>= \ info -> case info of +#if MIN_VERSION_template_haskell(2,11,0) + DataConI _ _ p -> return p +#else + DataConI _ _ p _ -> return p +#endif + _ -> err $ show name ++ " is not a data constructor" + dec <- reify parent >>= \ info -> case info of + TyConI d -> return d + _ -> err $ "parent " ++ show parent ++ " is not a plain type" + case dec of +#if MIN_VERSION_template_haskell(2,11,0) + DataD _ _ _ _ cs _ -> return (fields =<< cs) + NewtypeD _ _ _ _ c _ -> return (fields c) +#else + DataD _ _ _ cs _ -> return (fields =<< cs) + NewtypeD _ _ _ c _ -> return (fields c) +#endif + _ -> err $ "parent " ++ show parent ++ " neither data nor newtype" + where + fields :: Con -> [Name] + fields con = case con of + NormalC _ _ -> [] + RecC n vbts -> if n /= name then [] else [ v | (v, _, _) <- vbts ] + InfixC _ _ _ -> [] + ForallC _ _ c -> fields c +#if MIN_VERSION_template_haskell(2,11,0) + GadtC _ _ _ -> [] + RecGadtC ns vbts _ -> if name `notElem` ns then [] + else [ v | (v, _, _) <- vbts ] +#endif + + lookupThing :: String -> Q Name + lookupThing s0 = case s0 of + '\'' : s1 -> case s1 of + '\'' : s2 -> hmm s2 "lookupTypeName" =<< lookupTypeName s2 + _ -> hmm s1 "lookupValueName" =<< lookupValueName s1 + _ -> err $ "please specify either '" ++ s0 ++ " or ''" ++ s0 + where + hmm s l = maybe (err $ unwords [l, show s, "failed"]) return + + nameVars :: String -> Q (Name, [String]) + nameVars spec = case words spec of + [] -> err "expecting at least one token" + start : rest -> do + thing <- lookupThing start + let (names, vars) = break ("|" ==) rest + name <- foldM (flip summon) thing names + return (name, dropWhile ("|" ==) vars) +{- }}} -}
tests/Common.hs view
@@ -1,71 +1,78 @@-{-# 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"-+{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Common where + +#if HLINT +#include "cabal_macros.h" +#endif + +import Prelude +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +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) $ UTCView + <$> 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" +
tests/bench.hs view
@@ -1,166 +1,2 @@-{-# 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)+main :: IO () +main = return ()
tests/hlint.hs view
@@ -1,19 +1,19 @@-module 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"- ]-+module 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" + ] +
tests/rewrite.hs view
@@ -1,88 +1,59 @@-{-# 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"+{-# OPTIONS_GHC -O2 -dumpdir dump -ddump-to-file -ddump-rule-firings #-} + +import Prelude +import Data.Int +import Data.List (stripPrefix) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Thyme.Time +import System.Exit +import System.Random + +main :: IO () +main = do + useless + checkRuleFirings "dump/tests/rewrite.dump-rule-firings" + +checkRuleFirings :: FilePath -> IO () +checkRuleFirings file = do + dump <- readFile file + let strip = maybe id Set.insert . stripPrefix "Rule fired: " + let fired = foldr strip Set.empty (lines dump) + let unmatched = wanted `Set.difference` fired + case Set.null unmatched of + True -> do + putStrLn "All wanted rules fired." + exitSuccess + False -> do + putStrLn "Unmatched rules:" + mapM_ (putStrLn . (++) " ") (Set.toList 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 :: Set String +wanted = Set.fromList + [ "fromSeconds/Float (Data.Thyme.Clock.Internal)" + , "fromSeconds/Double (Data.Thyme.Clock.Internal)" + , "fromSeconds/Int (Data.Thyme.Clock.Internal)" + , "fromSeconds/Int64 (Data.Thyme.Clock.Internal)" + , "fromSeconds/Integer (Data.Thyme.Clock.Internal)" + , "realToFrac/DiffTime-NominalDiffTime (Data.Thyme.Time)" + , "realToFrac/NominalDiffTime-DiffTime (Data.Thyme.Time)" + , "realToFrac/DiffTime-Fractional (Data.Thyme.Time)" + , "realToFrac/NominalDiffTime-Fractional (Data.Thyme.Time)" + , "realToFrac/Real-DiffTime (Data.Thyme.Time)" + , "realToFrac/Real-NominalDiffTime (Data.Thyme.Time)" ]-
tests/sanity.hs view
@@ -1,93 +1,98 @@-{-# 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}-+{-# 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.Calendar.OrdinalDate +import Data.Thyme.Time +import qualified Data.Time as T +import qualified Data.Time.Calendar.OrdinalDate as T +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 +#if MIN_VERSION_time(1,5,0) + t' = T.parseTimeM True defaultTimeLocale spec s +#else + t' = T.parseTime defaultTimeLocale spec s +#endif + 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.cabal view
@@ -1,195 +1,202 @@-name: 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 <http://hackage.haskell.org/package/thyme/docs/Data-Thyme.html Data.Thyme> 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:-+name: thyme +version: 0.3.6 +synopsis: A faster time library +description: + @thyme@ is a performance-optimized rewrite of the excellent + @<http://hackage.haskell.org/package/time time>@ library. + . + See @<http://hackage.haskell.org/package/thyme/docs/Data-Thyme-Docs.html Data.Thyme.Docs>@ + for a full description. +homepage: https://github.com/liyang/thyme +license: BSD3 +license-file: LICENSE +author: Liyang HU, Ashley Yakeley +maintainer: Fumiaki Kinoshita <fumiexcel@gmail.com> +copyright: © 2013−2014 Liyang HU +category: Data, System +build-type: Simple +cabal-version: >= 1.10 +stability: experimental +extra-source-files: + CHANGELOG.md + README.md + include/thyme.h +tested-with: + GHC == 7.6.3, GHC == 7.8.4, + GHC == 7.10.2, GHC == 7.10.3, + GHC >= 8.0 && < 8.2 + +source-repository head + type: git + location: https://github.com/fumieval/thyme + +flag bug-for-bug + description: bug-for-bug compatibility with time + default: True + manual: True + +flag docs + description: include extra packages for Data.Thyme.Docs; implies -flens + default: False + 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 + +library + default-language: Haskell2010 + include-dirs: include + hs-source-dirs: src + if !(flag(lens) || flag(docs)) + hs-source-dirs: lens + exposed-modules: + Data.Thyme + Data.Thyme.Docs + 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 + Data.Thyme.TrueName + if !(flag(lens) || flag(docs)) + other-modules: Control.Lens + build-depends: + QuickCheck >= 2.4, + attoparsec >= 0.10, + aeson >= 0.6, + base >= 4.5 && < 5, + bytestring >= 0.9, + containers >= 0.5, + deepseq >= 1.2, + hashable >= 1.2, + mtl >= 1.1, + old-locale >= 1.0, + random, + text >= 0.11, + template-haskell >= 2.7 && < 2.20, + 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) || os(freebsd) + build-tools: cpphs + ghc-options: "-pgmP cpphs --cpp" + if flag(lens) || flag(docs) + build-depends: lens >= 3.9 + else + build-depends: profunctors >= 3.1.2 + if flag(docs) + build-depends: integer-gmp, ghc-prim + ghc-options: -Wall + if flag(bug-for-bug) + cpp-options: -DBUG_FOR_BUG=1 + if flag(show-internal) + cpp-options: -DSHOW_INTERNAL=1 + +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: + base, + containers, + random, + thyme + ghc-options: -Wall + +test-suite hlint + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: hlint.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + 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: +