diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,32 +1,30 @@ -# thyme - -[![Status](https://travis-ci.org/liyang/thyme.png)][travis] [Hackage][] - -A faster date and time library based on [time][]. - -* Trades speed for slightly less precision: micro- (μs; 10-6) - versus pico-seconds (ps; 10-12). -* 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 + +[![CI](https://github.com/haskell-github-trust/thyme/actions/workflows/haskell.yml/badge.svg)](https://github.com/haskell-github-trust/thyme/actions/workflows/haskell.yml) [![Hackage](https://img.shields.io/hackage/v/thyme.svg?logo=haskell)](http://hackage.haskell.org/package/thyme) + +A faster date and time library based on [time][]. + +* Trades speed for slightly less precision: micro- (μs; 10-6) + versus pico-seconds (ps; 10-12). +* 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 + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/include/thyme.h b/include/thyme.h --- a/include/thyme.h +++ b/include/thyme.h @@ -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 +#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 diff --git a/lens/Control/Lens.hs b/lens/Control/Lens.hs --- a/lens/Control/Lens.hs +++ b/lens/Control/Lens.hs @@ -1,156 +1,156 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -#if HLINT -#include "cabal_macros.h" -#endif - --- | Small replacement for . -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 . +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 (.=) #-} + diff --git a/src/Data/Thyme.hs b/src/Data/Thyme.hs --- a/src/Data/Thyme.hs +++ b/src/Data/Thyme.hs @@ -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 diff --git a/src/Data/Thyme/Calendar.hs b/src/Data/Thyme/Calendar.hs --- a/src/Data/Thyme/Calendar.hs +++ b/src/Data/Thyme/Calendar.hs @@ -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 --- calendar for --- dates before its adoption (from 1582 onwards, but varies from one country --- to the next) produces --- , --- which may cause some confusion. - --- | The number of days in a given month in the --- 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 +-- calendar for +-- dates before its adoption (from 1582 onwards, but varies from one country +-- to the next) produces +-- , +-- which may cause some confusion. + +-- | The number of days in a given month in the +-- 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 + diff --git a/src/Data/Thyme/Calendar/Internal.hs b/src/Data/Thyme/Calendar/Internal.hs --- a/src/Data/Thyme/Calendar/Internal.hs +++ b/src/Data/Thyme/Calendar/Internal.hs @@ -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 --- --- (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 --- --- /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 --- . -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 - --- | . --- --- 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 --- @@. --- --- 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 --- @@. --- --- 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 +-- +-- (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 +-- +-- /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 +-- . +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 + +-- | . +-- +-- 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 +-- @@. +-- +-- 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 +-- @@. +-- +-- 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) |] + diff --git a/src/Data/Thyme/Calendar/MonthDay.hs b/src/Data/Thyme/Calendar/MonthDay.hs --- a/src/Data/Thyme/Calendar/MonthDay.hs +++ b/src/Data/Thyme/Calendar/MonthDay.hs @@ -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) + diff --git a/src/Data/Thyme/Calendar/OrdinalDate.hs b/src/Data/Thyme/Calendar/OrdinalDate.hs --- a/src/Data/Thyme/Calendar/OrdinalDate.hs +++ b/src/Data/Thyme/Calendar/OrdinalDate.hs @@ -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) + diff --git a/src/Data/Thyme/Calendar/WeekDate.hs b/src/Data/Thyme/Calendar/WeekDate.hs --- a/src/Data/Thyme/Calendar/WeekDate.hs +++ b/src/Data/Thyme/Calendar/WeekDate.hs @@ -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 . --- --- @ --- '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 --- 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 --- 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 . +-- +-- @ +-- '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 +-- 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 +-- 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) + diff --git a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs --- a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs +++ b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs @@ -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 + diff --git a/src/Data/Thyme/Clock.hs b/src/Data/Thyme/Clock.hs --- a/src/Data/Thyme/Clock.hs +++ b/src/Data/Thyme/Clock.hs @@ -1,203 +1,203 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE PatternSynonyms #-} -#endif - -{-| Types and functions for - and -. - -If you don't care about leap seconds, keep to 'UTCTime' and -'NominalDiffTime' for your clock calculations, and you'll be fine. - -"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 --- . --- --- @ --- 'getModJulianDate' = 'view' 'modJulianDate' --- @ -{-# INLINE getModJulianDate #-} -getModJulianDate :: UniversalTime -> Rational -getModJulianDate = view modJulianDate - --- | Construct a 'UniversalTime' from the fractional number of days since the --- . --- --- @ --- '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 --- @@. -{-# 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 + and +. + +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 +-- . +-- +-- @ +-- 'getModJulianDate' = 'view' 'modJulianDate' +-- @ +{-# INLINE getModJulianDate #-} +getModJulianDate :: UniversalTime -> Rational +getModJulianDate = view modJulianDate + +-- | Construct a 'UniversalTime' from the fractional number of days since the +-- . +-- +-- @ +-- '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 +-- @@. +{-# 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 + diff --git a/src/Data/Thyme/Clock/Internal.hs b/src/Data/Thyme/Clock/Internal.hs --- a/src/Data/Thyme/Clock/Internal.hs +++ b/src/Data/Thyme/Clock/Internal.hs @@ -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 ? -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 --- . --- --- 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 --- . -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 --- . -{-# 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 - ------------------------------------------------------------------------- - --- | --- ('UTCTime') is the most commonly used standard for civil timekeeping. It --- is synchronised with --- --- ('Data.Thyme.Clock.AbsoluteTime') and both tick in increments of SI --- seconds, but UTC includes occasional leap-seconds to keep it close to --- --- ('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' . --- 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 ? +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 +-- . +-- +-- 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 +-- . +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 +-- . +{-# 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 + +------------------------------------------------------------------------ + +-- | +-- ('UTCTime') is the most commonly used standard for civil timekeeping. It +-- is synchronised with +-- +-- ('Data.Thyme.Clock.AbsoluteTime') and both tick in increments of SI +-- seconds, but UTC includes occasional leap-seconds to keep it close to +-- +-- ('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' . +-- 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) + diff --git a/src/Data/Thyme/Clock/POSIX.hsc b/src/Data/Thyme/Clock/POSIX.hsc --- a/src/Data/Thyme/Clock/POSIX.hsc +++ b/src/Data/Thyme/Clock/POSIX.hsc @@ -1,108 +1,108 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -#ifndef mingw32_HOST_OS -#include -#endif - --- | -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 --- @@. -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 --- @@, --- 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 +#endif + +-- | +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 +-- @@. +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 +-- @@, +-- 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 + diff --git a/src/Data/Thyme/Clock/TAI.hs b/src/Data/Thyme/Clock/TAI.hs --- a/src/Data/Thyme/Clock/TAI.hs +++ b/src/Data/Thyme/Clock/TAI.hs @@ -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 @@ - --- | --- (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 - --- | --- (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 --- 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 @@ + +-- | +-- (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 + +-- | +-- (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 +-- 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) + diff --git a/src/Data/Thyme/Docs.hs b/src/Data/Thyme/Docs.hs --- a/src/Data/Thyme/Docs.hs +++ b/src/Data/Thyme/Docs.hs @@ -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 -@@ 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 @@ - pattern synonym. In any case, 'utcTime' can convert it to a 'UTCView'. - -* 'UniversalTime' similarly has the - @@ 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 - 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 - -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 - 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 -@@ package, and field -accessors as "Control.Lens.Lens"es. - -A full @lens@ -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 +@@ 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 @@ + pattern synonym. In any case, 'utcTime' can convert it to a 'UTCView'. + +* 'UniversalTime' similarly has the + @@ 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 + 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 + +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 + 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 +@@ package, and field +accessors as "Control.Lens.Lens"es. + +A full @lens@ +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. + +-}{- }}} -} + diff --git a/src/Data/Thyme/Format.hs b/src/Data/Thyme/Format.hs --- a/src/Data/Thyme/Format.hs +++ b/src/Data/Thyme/Format.hs @@ -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@__ @@ --- 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 --- --- ==== --- @ --- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" $ 'mkUTCTime' 2015 1 15 12 34 56.78 --- "2015-01-15T12:34:56+00:00" --- @ --- --- ==== --- @ --- > '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 --- . -{-# 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 --- --- ==== --- @ --- > '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@__ @@ +-- 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 +-- +-- ==== +-- @ +-- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" $ 'mkUTCTime' 2015 1 15 12 34 56.78 +-- "2015-01-15T12:34:56+00:00" +-- @ +-- +-- ==== +-- @ +-- > '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 +-- . +{-# 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 +-- +-- ==== +-- @ +-- > '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) + diff --git a/src/Data/Thyme/Format/Aeson.hs b/src/Data/Thyme/Format/Aeson.hs --- a/src/Data/Thyme/Format/Aeson.hs +++ b/src/Data/Thyme/Format/Aeson.hs @@ -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 #-} + diff --git a/src/Data/Thyme/Format/Human.hs b/src/Data/Thyme/Format/Human.hs --- a/src/Data/Thyme/Format/Human.hs +++ b/src/Data/Thyme/Format/Human.hs @@ -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', ..} + diff --git a/src/Data/Thyme/Format/Internal.hs b/src/Data/Thyme/Format/Internal.hs --- a/src/Data/Thyme/Format/Internal.hs +++ b/src/Data/Thyme/Format/Internal.hs @@ -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 + diff --git a/src/Data/Thyme/Internal/Micro.hs b/src/Data/Thyme/Internal/Micro.hs --- a/src/Data/Thyme/Internal/Micro.hs +++ b/src/Data/Thyme/Internal/Micro.hs @@ -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 + diff --git a/src/Data/Thyme/LocalTime.hs b/src/Data/Thyme/LocalTime.hs --- a/src/Data/Thyme/LocalTime.hs +++ b/src/Data/Thyme/LocalTime.hs @@ -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 --- --- 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 +-- +-- 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 + diff --git a/src/Data/Thyme/Time.hs b/src/Data/Thyme/Time.hs --- a/src/Data/Thyme/Time.hs +++ b/src/Data/Thyme/Time.hs @@ -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 #-} + diff --git a/src/Data/Thyme/Time/Core.hs b/src/Data/Thyme/Time/Core.hs --- a/src/Data/Thyme/Time/Core.hs +++ b/src/Data/Thyme/Time/Core.hs @@ -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 + diff --git a/src/Data/Thyme/TrueName.hs b/src/Data/Thyme/TrueName.hs --- a/src/Data/Thyme/TrueName.hs +++ b/src/Data/Thyme/TrueName.hs @@ -1,423 +1,430 @@ -{-# LANGUAGE CPP #-} - --- | Refer to . - -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 . --- 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 . --- 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 . + +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 . +-- 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 . +-- 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) +{- }}} -} diff --git a/tests/Common.hs b/tests/Common.hs --- a/tests/Common.hs +++ b/tests/Common.hs @@ -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" + diff --git a/tests/bench.hs b/tests/bench.hs --- a/tests/bench.hs +++ b/tests/bench.hs @@ -1,2 +1,2 @@ -main :: IO () -main = return () +main :: IO () +main = return () diff --git a/tests/hlint.hs b/tests/hlint.hs --- a/tests/hlint.hs +++ b/tests/hlint.hs @@ -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" + ] + diff --git a/tests/rewrite.hs b/tests/rewrite.hs --- a/tests/rewrite.hs +++ b/tests/rewrite.hs @@ -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)" ] diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -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} + diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -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 - @@ library. - . - See @@ - for a full description. -homepage: https://github.com/liyang/thyme -license: BSD3 -license-file: LICENSE -author: Liyang HU, Ashley Yakeley -maintainer: Fumiaki Kinoshita -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 + @@ library. + . + See @@ + for a full description. +homepage: https://github.com/fumieval/thyme +license: BSD3 +license-file: LICENSE +author: Liyang HU, Ashley Yakeley +maintainer: Fumiaki Kinoshita +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: +