thyme 0.3.6 → 0.4.1
raw patch · 33 files changed
Files
- CHANGELOG.md +6/−2
- LICENSE +30/−30
- README.md +30/−32
- Setup.hs +2/−2
- include/thyme.h +7/−7
- lens/Control/Lens.hs +156/−156
- src/Data/Thyme.hs +12/−12
- src/Data/Thyme/Calendar.hs +267/−267
- src/Data/Thyme/Calendar/Internal.hs +750/−750
- src/Data/Thyme/Calendar/MonthDay.hs +63/−63
- src/Data/Thyme/Calendar/OrdinalDate.hs +170/−170
- src/Data/Thyme/Calendar/WeekDate.hs +123/−123
- src/Data/Thyme/Calendar/WeekdayOfMonth.hs +148/−148
- src/Data/Thyme/Clock.hs +203/−203
- src/Data/Thyme/Clock/Internal.hs +434/−434
- src/Data/Thyme/Clock/POSIX.hsc +108/−108
- src/Data/Thyme/Clock/TAI.hs +357/−357
- src/Data/Thyme/Docs.hs +357/−357
- src/Data/Thyme/Format.hs +992/−989
- src/Data/Thyme/Format/Aeson.hs +108/−108
- src/Data/Thyme/Format/Human.hs +94/−94
- src/Data/Thyme/Format/Internal.hs +147/−147
- src/Data/Thyme/Internal/Micro.hs +107/−107
- src/Data/Thyme/LocalTime.hs +671/−671
- src/Data/Thyme/Time.hs +78/−78
- src/Data/Thyme/Time/Core.hs +155/−155
- src/Data/Thyme/TrueName.hs +430/−423
- tests/Common.hs +78/−78
- tests/bench.hs +2/−2
- tests/hlint.hs +19/−19
- tests/rewrite.hs +58/−58
- tests/sanity.hs +98/−98
- thyme.cabal +200/−202
CHANGELOG.md view
@@ -1,3 +1,7 @@-### 0.3.6 - +## unreleased++## 0.4+ * Supported GHC 9 and older+* Changed the type of `mkUTCTime :: Day -> DiffTime -> UTCTime` to `mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime`. Use the `UTCTime` pattern synonym instead if needed.+* Miscellaneous API additions and refactors
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
@@ -1,32 +1,30 @@-# 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 - +# thyme++[](https://github.com/haskell-github-trust/thyme/actions/workflows/haskell.yml) [](http://hackage.haskell.org/package/thyme)++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++```+cabal build+```++### Haddock++```+cabal haddock+```++[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+
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
include/thyme.h view
@@ -1,7 +1,7 @@-#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> +#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,156 +1,156 @@-{-# 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 (.=) #-} - +{-# 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,12 +1,12 @@--- | 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 +-- | 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,267 +1,267 @@-{-# 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 - +{-# 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,750 +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" -#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) |] - +{-# 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,63 +1,63 @@-{-# 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) - +{-# 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,170 +1,170 @@-{-# 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) - +{-# 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,123 +1,123 @@-{-# 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) - +{-# 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,148 +1,148 @@-{-# 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 - +{-# 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,203 +1,203 @@-{-# 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 - +{-# 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,434 +1,434 @@-{-# 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) - +{-# 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,108 +1,108 @@-{-# 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 - +{-# 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,357 +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 - -#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) - +{-# 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
@@ -1,357 +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. - --}{- }}} -} - +{-# 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,989 +1,992 @@-{-# 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) - +{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}+#endif++#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+ | 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,108 +1,108 @@-{-# 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 #-} - +{-# 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,94 +1,94 @@-{-# 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', ..} - +{-# 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,107 +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.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 - +{-# 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,671 +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" -#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 - +{-# 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,78 +1,78 @@-{-# 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 #-} - +{-# 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,155 +1,155 @@-{-# 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 - +{-# 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
@@ -1,423 +1,430 @@-{-# 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) -{- }}} -} +{-# 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,22,0)+ InfixD _ _ _ -> []+#elif 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++#if MIN_VERSION_template_haskell(2,22,0)+ TypeDataD _ _ _ _ -> []+ DefaultD _ -> []+#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,78 +1,78 @@-{-# 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" - +{-# 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,2 +1,2 @@-main :: IO () -main = return () +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,59 +1,59 @@-{-# 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)" +{-# 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,98 +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.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} - +{-# 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,202 +1,200 @@-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: - +name: thyme+version: 0.4.1+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/fumieval/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 >= 8.4 && < 9.12++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.23,+ 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 < 5,+ 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 < 5,+ 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 < 5, 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 < 5,+ 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:+