thyme 0.3.6 → 0.4

raw patch · 33 files changed

+6453/−6450 lines, 33 filesdep ~template-haskellsetup-changed

Dependency ranges changed: template-haskell

Files

CHANGELOG.md +6/−2
LICENSE +30/−30
README.md +30/−32
Setup.hs +2/−2
include/thyme.h +7/−7
lens/Control/Lens.hs +156/−156
src/Data/Thyme.hs +12/−12
src/Data/Thyme/Calendar.hs +267/−267
src/Data/Thyme/Calendar/Internal.hs +750/−750
src/Data/Thyme/Calendar/MonthDay.hs +63/−63
src/Data/Thyme/Calendar/OrdinalDate.hs +170/−170
src/Data/Thyme/Calendar/WeekDate.hs +123/−123
src/Data/Thyme/Calendar/WeekdayOfMonth.hs +148/−148
src/Data/Thyme/Clock.hs +203/−203
src/Data/Thyme/Clock/Internal.hs +434/−434
src/Data/Thyme/Clock/POSIX.hsc +108/−108
src/Data/Thyme/Clock/TAI.hs +357/−357
src/Data/Thyme/Docs.hs +357/−357
src/Data/Thyme/Format.hs +992/−989
src/Data/Thyme/Format/Aeson.hs +108/−108
src/Data/Thyme/Format/Human.hs +94/−94
src/Data/Thyme/Format/Internal.hs +147/−147
src/Data/Thyme/Internal/Micro.hs +107/−107
src/Data/Thyme/LocalTime.hs +671/−671
src/Data/Thyme/Time.hs +78/−78
src/Data/Thyme/Time/Core.hs +155/−155
src/Data/Thyme/TrueName.hs +423/−423
tests/Common.hs +78/−78
tests/bench.hs +2/−2
tests/hlint.hs +19/−19
tests/rewrite.hs +58/−58
tests/sanity.hs +98/−98
thyme.cabal +200/−202

CHANGELOG.md view

@@ -1,3 +1,7 @@-### 0.3.6
-
+## unreleased++## 0.4+ * Supported GHC 9 and older+* Changed the type of `mkUTCTime :: Day -> DiffTime -> UTCTime` to `mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime`. Use the `UTCTime` pattern synonym instead if needed.+* Miscellaneous API additions and refactors

LICENSE view

@@ -1,30 +1,30 @@-Copyright (c) 2013, Liyang HU
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Liyang HU nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2013, Liyang HU++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Liyang HU nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md view

@@ -1,32 +1,30 @@-# thyme
-
-[![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<sup>-6</sup>)
-  versus pico-seconds (ps; 10<sup>-12</sup>).
-* Better type-safety for date and time arithmetic.
-* Ships with a selection of [Iso'][]s and [Lens'][]s for [lens][].
-
-## Building
-
-### Library
-
-```
-stack build --flag thyme:lens
-```
-
-### Haddock
-
-```
-stack haddock --flag thyme:lens
-```
-
-[Hackage]: http://hackage.haskell.org/package/thyme
-[Iso']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Iso.html#t:Iso-39-
-[Lens']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens-39-
-[lens]: http://hackage.haskell.org/package/lens
-[time]: http://hackage.haskell.org/package/time
-[travis]: https://travis-ci.org/liyang/thyme
-
+# thyme++[![CI](https://github.com/fumieval/thyme/actions/workflows/haskell.yml/badge.svg)](https://github.com/fumieval/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<sup>-6</sup>)+  versus pico-seconds (ps; 10<sup>-12</sup>).+* Better type-safety for date and time arithmetic.+* Ships with a selection of [Iso'][]s and [Lens'][]s for [lens][].++## Building++### Library++```+cabal build+```++### Haddock++```+cabal haddock+```++[Iso']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Iso.html#t:Iso-39-+[Lens']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens-39-+[lens]: http://hackage.haskell.org/package/lens+[time]: http://hackage.haskell.org/package/time+

Setup.hs view

@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain

include/thyme.h view

@@ -1,7 +1,7 @@-#define INSTANCES_USUAL     Eq, Ord, Data, Typeable, Generic
-#define INSTANCES_NEWTYPE   INSTANCES_USUAL, Enum, Ix, Hashable, NFData
-#define INSTANCES_MICRO     INSTANCES_NEWTYPE, Bounded, Random, Arbitrary, CoArbitrary
-#define LensP Lens'
-#define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \ S {..} F/**/_ -> S {F = F/**/_, ..}
-
-#define W_GREGORIAN <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian>
+#define INSTANCES_USUAL     Eq, Ord, Data, Typeable, Generic+#define INSTANCES_NEWTYPE   INSTANCES_USUAL, Enum, Ix, Hashable, NFData+#define INSTANCES_MICRO     INSTANCES_NEWTYPE, Bounded, Random, Arbitrary, CoArbitrary+#define LensP Lens'+#define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \ S {..} F/**/_ -> S {F = F/**/_, ..}++#define W_GREGORIAN <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian>

lens/Control/Lens.hs view

@@ -1,156 +1,156 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Small replacement for <http://hackage.haskell.org/package/lens lens>.
-module Control.Lens
-    ( (&)
-    , Iso, Iso', iso
-    , from
-    , review, ( # )
-    , Lens, Lens', lens
-    , view, (^.)
-    , set, over, (%~), assign, (.=)
-    ) where
-
-import Control.Applicative
-import Control.Monad.Identity
-import Control.Monad.State.Class as State
-import Data.Profunctor
-import Data.Profunctor.Unsafe
-#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0)
-import Data.Coerce
-#else
-import Unsafe.Coerce
-#endif
-
-infixl 1 &
-(&) :: a -> (a -> b) -> b
-a & f = f a
-{-# INLINE (&) #-}
-
-type Overloaded p f s t a b = p a (f b) -> p s (f t)
-
-------------------------------------------------------------------------
-
-type Iso s t a b = forall p f. (Profunctor p, Functor f) => Overloaded p f s t a b
-type Iso' s a = Iso s s a a
-
-iso :: (s -> a) -> (b -> t) -> Iso s t a b
-iso sa bt = dimap sa (fmap bt)
-{-# INLINE iso #-}
-
-------------------------------------------------------------------------
-
-data Exchange a b s t = Exchange (s -> a) (b -> t)
-
-instance Profunctor (Exchange a b) where
-  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
-  {-# INLINE dimap #-}
-  lmap f (Exchange sa bt) = Exchange (sa . f) bt
-  {-# INLINE lmap #-}
-  rmap f (Exchange sa bt) = Exchange sa (f . bt)
-  {-# INLINE rmap #-}
-#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0)
-  ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t
-  ( .# ) p _ = coerce p
-#else
-  ( #. ) _ = unsafeCoerce
-  ( .# ) p _ = unsafeCoerce p
-#endif
-  {-# INLINE ( #. ) #-}
-  {-# INLINE ( .# ) #-}
-
-type AnIso s t a b = Overloaded (Exchange a b) Identity s t a b
-
-from :: AnIso s t a b -> Iso b a t s
-from l = case l (Exchange id Identity) of
-  Exchange sa bt -> iso (runIdentity #. bt) sa
-{-# INLINE from #-}
-
-------------------------------------------------------------------------
-
-newtype Reviewed a b = Reviewed
-    { runReviewed :: b
-    } deriving (Functor)
-
-instance Profunctor Reviewed where
-  dimap _ f (Reviewed c) = Reviewed (f c)
-  {-# INLINE dimap #-}
-  lmap _ (Reviewed c) = Reviewed c
-  {-# INLINE lmap #-}
-  rmap = fmap
-  {-# INLINE rmap #-}
-  Reviewed b .# _ = Reviewed b
-  {-# INLINE ( .# ) #-}
-#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0)
-  ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t
-#else
-  ( #. ) _ = unsafeCoerce
-#endif
-  {-# INLINE ( #. ) #-}
-
-type AReview s t a b = Overloaded Reviewed Identity s t a b
-
-review :: AReview s t a b -> b -> t
-review p = runIdentity #. runReviewed #. p .# Reviewed .# Identity
-{-# INLINE review #-}
-
-infixr 8 #
-( # ) :: AReview s t a b -> b -> t
-( # ) = review
-{-# INLINE ( # ) #-}
-
-------------------------------------------------------------------------
-
-type Lens s t a b = forall f. Functor f => Overloaded (->) f s t a b
-type Lens' s a = Lens s s a a
-
-lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
-lens sa sbt afb s = sbt s <$> afb (sa s)
-{-# INLINE lens #-}
-
-------------------------------------------------------------------------
-
-type Getting r s a = Overloaded (->) (Const r) s s a a
-
-view :: Getting a s a -> s -> a
-view l s = getConst (l Const s)
-{-# INLINE view #-}
-
-infixl 8 ^.
-(^.) :: s -> Getting a s a -> a
-(^.) = flip view
-{-# INLINE (^.) #-}
-
-------------------------------------------------------------------------
-
-type Setter s t a b = Overloaded (->) Identity s t a b
-
-set :: Setter s t a b -> b -> s -> t
-set l b = runIdentity #. l (\ _ -> Identity b)
-{-# INLINE set #-}
-
-over :: Setter s t a b -> (a -> b) -> s -> t
-over l f = runIdentity #. l (Identity #. f)
-{-# INLINE over #-}
-
-infixr 4 %~
-(%~) :: Setter s t a b -> (a -> b) -> s -> t
-(%~) = over
-{-# INLINE (%~) #-}
-
-assign :: (MonadState s m) => Setter s s a b -> b -> m ()
-assign l b = State.modify (set l b)
-{-# INLINE assign #-}
-
-infix 4 .=
-(.=) :: (MonadState s m) => Setter s s a b -> b -> m ()
-(.=) = assign
-{-# INLINE (.=) #-}
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if HLINT+#include "cabal_macros.h"+#endif++-- | Small replacement for <http://hackage.haskell.org/package/lens lens>.+module Control.Lens+    ( (&)+    , Iso, Iso', iso+    , from+    , review, ( # )+    , Lens, Lens', lens+    , view, (^.)+    , set, over, (%~), assign, (.=)+    ) where++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.State.Class as State+import Data.Profunctor+import Data.Profunctor.Unsafe+#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0)+import Data.Coerce+#else+import Unsafe.Coerce+#endif++infixl 1 &+(&) :: a -> (a -> b) -> b+a & f = f a+{-# INLINE (&) #-}++type Overloaded p f s t a b = p a (f b) -> p s (f t)++------------------------------------------------------------------------++type Iso s t a b = forall p f. (Profunctor p, Functor f) => Overloaded p f s t a b+type Iso' s a = Iso s s a a++iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso sa bt = dimap sa (fmap bt)+{-# INLINE iso #-}++------------------------------------------------------------------------++data Exchange a b s t = Exchange (s -> a) (b -> t)++instance Profunctor (Exchange a b) where+  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)+  {-# INLINE dimap #-}+  lmap f (Exchange sa bt) = Exchange (sa . f) bt+  {-# INLINE lmap #-}+  rmap f (Exchange sa bt) = Exchange sa (f . bt)+  {-# INLINE rmap #-}+#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0)+  ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t+  ( .# ) p _ = coerce p+#else+  ( #. ) _ = unsafeCoerce+  ( .# ) p _ = unsafeCoerce p+#endif+  {-# INLINE ( #. ) #-}+  {-# INLINE ( .# ) #-}++type AnIso s t a b = Overloaded (Exchange a b) Identity s t a b++from :: AnIso s t a b -> Iso b a t s+from l = case l (Exchange id Identity) of+  Exchange sa bt -> iso (runIdentity #. bt) sa+{-# INLINE from #-}++------------------------------------------------------------------------++newtype Reviewed a b = Reviewed+    { runReviewed :: b+    } deriving (Functor)++instance Profunctor Reviewed where+  dimap _ f (Reviewed c) = Reviewed (f c)+  {-# INLINE dimap #-}+  lmap _ (Reviewed c) = Reviewed c+  {-# INLINE lmap #-}+  rmap = fmap+  {-# INLINE rmap #-}+  Reviewed b .# _ = Reviewed b+  {-# INLINE ( .# ) #-}+#if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0)+  ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t+#else+  ( #. ) _ = unsafeCoerce+#endif+  {-# INLINE ( #. ) #-}++type AReview s t a b = Overloaded Reviewed Identity s t a b++review :: AReview s t a b -> b -> t+review p = runIdentity #. runReviewed #. p .# Reviewed .# Identity+{-# INLINE review #-}++infixr 8 #+( # ) :: AReview s t a b -> b -> t+( # ) = review+{-# INLINE ( # ) #-}++------------------------------------------------------------------------++type Lens s t a b = forall f. Functor f => Overloaded (->) f s t a b+type Lens' s a = Lens s s a a++lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s = sbt s <$> afb (sa s)+{-# INLINE lens #-}++------------------------------------------------------------------------++type Getting r s a = Overloaded (->) (Const r) s s a a++view :: Getting a s a -> s -> a+view l s = getConst (l Const s)+{-# INLINE view #-}++infixl 8 ^.+(^.) :: s -> Getting a s a -> a+(^.) = flip view+{-# INLINE (^.) #-}++------------------------------------------------------------------------++type Setter s t a b = Overloaded (->) Identity s t a b++set :: Setter s t a b -> b -> s -> t+set l b = runIdentity #. l (\ _ -> Identity b)+{-# INLINE set #-}++over :: Setter s t a b -> (a -> b) -> s -> t+over l f = runIdentity #. l (Identity #. f)+{-# INLINE over #-}++infixr 4 %~+(%~) :: Setter s t a b -> (a -> b) -> s -> t+(%~) = over+{-# INLINE (%~) #-}++assign :: (MonadState s m) => Setter s s a b -> b -> m ()+assign l b = State.modify (set l b)+{-# INLINE assign #-}++infix 4 .=+(.=) :: (MonadState s m) => Setter s s a b -> b -> m ()+(.=) = assign+{-# INLINE (.=) #-}+

src/Data/Thyme.hs view

@@ -1,12 +1,12 @@--- | This simply re-exports some commonly-used modules.
-module Data.Thyme
-    ( module Data.Thyme.Calendar
-    , module Data.Thyme.Clock
-    , module Data.Thyme.Format
-    , module Data.Thyme.LocalTime
-    ) where
-
-import Data.Thyme.Calendar
-import Data.Thyme.Clock
-import Data.Thyme.Format
-import Data.Thyme.LocalTime
+-- | This simply re-exports some commonly-used modules.+module Data.Thyme+    ( module Data.Thyme.Calendar+    , module Data.Thyme.Clock+    , module Data.Thyme.Format+    , module Data.Thyme.LocalTime+    ) where++import Data.Thyme.Calendar+import Data.Thyme.Clock+import Data.Thyme.Format+import Data.Thyme.LocalTime

src/Data/Thyme/Calendar.hs view

@@ -1,267 +1,267 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Calendar calculations.
---
--- Note that 'UTCTime' is not Y294K-compliant, and 'Bounded' instances for
--- the various calendar types reflect this fact. That said, the calendar
--- calculations by themselves work perfectly fine for a wider range of
--- dates, subject to the size of 'Int' for your platform.
-module Data.Thyme.Calendar
-    (
-    -- * Day
-      Day (..), modifiedJulianDay
-
-    -- * Calendar
-    , Year, Month, DayOfMonth
-    , YearMonthDay (..), _ymdYear, _ymdMonth, _ymdDay
-    , Years, Months, Days
-
-    -- * Gregorian calendar
-    -- $proleptic
-    , isLeapYear
-    , yearMonthDay, gregorian, gregorianValid, showGregorian
-    , module Data.Thyme.Calendar
-    ) where
-
-import Prelude hiding ((.))
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.Category
-import Control.Lens
-import Control.Monad
-import Data.AdditiveGroup
-import Data.AffineSpace
-import Data.Thyme.Calendar.Internal
-import Data.Thyme.Clock.Internal
-import System.Random
-import Test.QuickCheck
-
--- "Data.Thyme.Calendar.Internal" cannot import "Data.Thyme.Clock.Internal",
--- therefore these orphan 'Bounded' instances must live here.
-instance Bounded Day where
-    minBound = minBound ^. _utctDay
-    maxBound = maxBound ^. _utctDay
-
-instance Bounded YearMonthDay where
-    minBound = minBound ^. gregorian
-    maxBound = maxBound ^. gregorian
-
-instance Random Day where
-    randomR r = first (^. _utctDay) . randomR (range r) where
-        -- upper bound is one Micro second before the next day
-        range = toMidnight *** pred . toMidnight . succ
-        toMidnight day = utcTime # UTCView day zeroV
-    random = randomR (minBound, maxBound)
-
-instance Random YearMonthDay where
-    randomR = randomIsoR gregorian
-    random = first (^. gregorian) . random
-
-instance Arbitrary Day where
-    arbitrary = ModifiedJulianDay
-        <$> choose (join (***) toModifiedJulianDay (minBound, maxBound))
-    shrink (ModifiedJulianDay mjd) = ModifiedJulianDay <$> shrink mjd
-
-instance Arbitrary YearMonthDay where
-    arbitrary = view gregorian <$> arbitrary
-    shrink ymd = view gregorian <$> shrink (gregorian # ymd)
-
-instance CoArbitrary YearMonthDay where
-    coarbitrary (YearMonthDay y m d)
-        = coarbitrary y . coarbitrary m . coarbitrary d
-
-------------------------------------------------------------------------
-
--- $proleptic
---
--- Note that using the
--- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar for
--- dates before its adoption (from 1582 onwards, but varies from one country
--- to the next) produces
--- <https://en.wikipedia.org/wiki/Gregorian_calendar#Proleptic_Gregorian_calendar a proleptic calendar>,
--- which may cause some confusion.
-
--- | The number of days in a given month in the
--- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar.
---
--- @
--- > 'gregorianMonthLength' 2005 2
--- 28
--- @
-{-# INLINE gregorianMonthLength #-}
-gregorianMonthLength :: Year -> Month -> Days
-gregorianMonthLength = monthLength . isLeapYear
-
--- | Add months, with days past the last day of the month clipped to the
--- last day.
---
--- See also 'addGregorianMonthsClip'.
---
--- @
--- > 'gregorianMonthsClip' 1 '$' 'YearMonthDay' 2005 1 30
--- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 2, 'ymdDay' = 28}
--- @
-{-# INLINEABLE gregorianMonthsClip #-}
-gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay
-gregorianMonthsClip n (YearMonthDay y m d) = YearMonthDay y' m'
-        $ min (gregorianMonthLength y' m') d where
-    ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12
-
--- | Add months, with days past the last day of the month rolling over to
--- the next month.
---
--- See also 'addGregorianMonthsRollover'.
---
--- @
--- > 'gregorianMonthsRollover' 1 $ 'YearMonthDay' 2005 1 30
--- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 3, 'ymdDay' = 2}
--- @
-{-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-}
-{-# INLINEABLE gregorianMonthsRollover #-}
-gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay
-gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of
-    True -> YearMonthDay y' m' d
-    False -> case m' < 12 of
-        True -> YearMonthDay y' (m' + 1) (d - len)
-        False -> YearMonthDay (y' + 1) 1 (d - len)
-  where
-    ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12
-    len = gregorianMonthLength y' m'
-
--- | Add years, matching month and day, with /February 29th/ clipped to the
--- /28th/ if necessary.
---
--- See also 'addGregorianYearsClip'.
---
--- @
--- > 'gregorianYearsClip' 2 $ 'YearMonthDay' 2004 2 29
--- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 2, 'ymdDay' = 28}
--- @
-{-# INLINEABLE gregorianYearsClip #-}
-gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay
-gregorianYearsClip n (YearMonthDay ((+) n -> y') 2 29)
-    | not (isLeapYear y') = YearMonthDay y' 2 28
-gregorianYearsClip n (YearMonthDay y m d) = YearMonthDay (y + n) m d
-
--- | Add years, matching month and day, with /February 29th/ rolled over to
--- /March 1st/ if necessary.
---
--- See also 'addGregorianYearsRollover'.
---
--- @
--- > 'gregorianYearsRollover' 2 $ 'YearMonthDay' 2004 2 29
--- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 3, 'ymdDay' = 1}
--- @
-{-# INLINEABLE gregorianYearsRollover #-}
-gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay
-gregorianYearsRollover n (YearMonthDay ((+) n -> y') 2 29)
-    | not (isLeapYear y') = YearMonthDay y' 3 1
-gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d
-
--- * Compatibility
-
--- | Add some 'Days' to a calendar 'Day' to get a new 'Day'.
---
--- @
--- 'addDays' = 'flip' ('.+^')
--- 'addDays' n d ≡ d '.+^' n
--- @
---
--- See also the 'AffineSpace' instance for 'Day'.
-{-# INLINE addDays #-}
-addDays :: Days -> Day -> Day
-addDays = flip (.+^)
-
--- | Subtract two calendar 'Day's for the difference in 'Days'.
---
--- @
--- 'diffDays' = ('.-.')
--- 'diffDays' a b = a '.-.' b
--- @
---
--- See also the 'AffineSpace' instance for 'Day'.
-{-# INLINE diffDays #-}
-diffDays :: Day -> Day -> Days
-diffDays = (.-.)
-
--- | Convert a 'Day' to its Gregorian 'Year', 'Month', and 'DayOfMonth'.
---
--- @
--- 'toGregorian' ('view' 'gregorian' -> 'YearMonthDay' y m d) = (y, m, d)
--- @
-{-# INLINE toGregorian #-}
-toGregorian :: Day -> (Year, Month, DayOfMonth)
-toGregorian (view gregorian -> YearMonthDay y m d) = (y, m, d)
-
--- | Construct a 'Day' from a Gregorian calendar date.
--- Does not validate the input.
---
--- @
--- 'fromGregorian' y m d = 'gregorian' 'Control.Lens.#' 'YearMonthDay' y m d
--- @
-{-# INLINE fromGregorian #-}
-fromGregorian :: Year -> Month -> DayOfMonth -> Day
-fromGregorian y m d = gregorian # YearMonthDay y m d
-
--- | Construct a 'Day' from a Gregorian calendar date.
--- Returns 'Nothing' for invalid input.
---
--- @
--- 'fromGregorianValid' y m d = 'gregorianValid' ('YearMonthDay' y m d)
--- @
-{-# INLINE fromGregorianValid #-}
-fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day
-fromGregorianValid y m d = gregorianValid (YearMonthDay y m d)
-
--- | Add some number of 'Months' to the given 'Day'; if the original
--- 'DayOfMonth' exceeds that of the new 'Month', it will be clipped to the
--- last day of the new 'Month'.
---
--- @
--- 'addGregorianMonthsClip' n = 'gregorian' '%~' 'gregorianMonthsClip' n
--- @
-{-# INLINE addGregorianMonthsClip #-}
-addGregorianMonthsClip :: Months -> Day -> Day
-addGregorianMonthsClip n = gregorian %~ gregorianMonthsClip n
-
--- | Add some number of 'Months' to the given 'Day'; if the original
--- 'DayOfMonth' exceeds that of the new 'Month', it will be rolled over into
--- the following 'Month'.
---
--- @
--- 'addGregorianMonthsRollover' n = 'gregorian' '%~' 'gregorianMonthsRollover' n
--- @
-{-# INLINE addGregorianMonthsRollover #-}
-addGregorianMonthsRollover :: Months -> Day -> Day
-addGregorianMonthsRollover n = gregorian %~ gregorianMonthsRollover n
-
--- | Add some number of 'Years' to the given 'Day', with /February 29th/
--- clipped to /February 28th/ if necessary.
---
--- @
--- 'addGregorianYearsClip' n = 'gregorian' '%~' 'gregorianYearsClip' n
--- @
-{-# INLINE addGregorianYearsClip #-}
-addGregorianYearsClip :: Years -> Day -> Day
-addGregorianYearsClip n = gregorian %~ gregorianYearsClip n
-
--- | Add some number of 'Years' to the given 'Day', with /February 29th/
--- rolled over to /March 1st/ if necessary.
---
--- @
--- 'addGregorianYearsRollover' n = 'gregorian' '%~' 'gregorianYearsRollover' n
--- @
-{-# INLINE addGregorianYearsRollover #-}
-addGregorianYearsRollover :: Years -> Day -> Day
-addGregorianYearsRollover n = gregorian %~ gregorianYearsRollover n
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++-- | Calendar calculations.+--+-- Note that 'UTCTime' is not Y294K-compliant, and 'Bounded' instances for+-- the various calendar types reflect this fact. That said, the calendar+-- calculations by themselves work perfectly fine for a wider range of+-- dates, subject to the size of 'Int' for your platform.+module Data.Thyme.Calendar+    (+    -- * Day+      Day (..), modifiedJulianDay++    -- * Calendar+    , Year, Month, DayOfMonth+    , YearMonthDay (..), _ymdYear, _ymdMonth, _ymdDay+    , Years, Months, Days++    -- * Gregorian calendar+    -- $proleptic+    , isLeapYear+    , yearMonthDay, gregorian, gregorianValid, showGregorian+    , module Data.Thyme.Calendar+    ) where++import Prelude hiding ((.))+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.Category+import Control.Lens+import Control.Monad+import Data.AdditiveGroup+import Data.AffineSpace+import Data.Thyme.Calendar.Internal+import Data.Thyme.Clock.Internal+import System.Random+import Test.QuickCheck++-- "Data.Thyme.Calendar.Internal" cannot import "Data.Thyme.Clock.Internal",+-- therefore these orphan 'Bounded' instances must live here.+instance Bounded Day where+    minBound = minBound ^. _utctDay+    maxBound = maxBound ^. _utctDay++instance Bounded YearMonthDay where+    minBound = minBound ^. gregorian+    maxBound = maxBound ^. gregorian++instance Random Day where+    randomR r = first (^. _utctDay) . randomR (range r) where+        -- upper bound is one Micro second before the next day+        range = toMidnight *** pred . toMidnight . succ+        toMidnight day = utcTime # UTCView day zeroV+    random = randomR (minBound, maxBound)++instance Random YearMonthDay where+    randomR = randomIsoR gregorian+    random = first (^. gregorian) . random++instance Arbitrary Day where+    arbitrary = ModifiedJulianDay+        <$> choose (join (***) toModifiedJulianDay (minBound, maxBound))+    shrink (ModifiedJulianDay mjd) = ModifiedJulianDay <$> shrink mjd++instance Arbitrary YearMonthDay where+    arbitrary = view gregorian <$> arbitrary+    shrink ymd = view gregorian <$> shrink (gregorian # ymd)++instance CoArbitrary YearMonthDay where+    coarbitrary (YearMonthDay y m d)+        = coarbitrary y . coarbitrary m . coarbitrary d++------------------------------------------------------------------------++-- $proleptic+--+-- Note that using the+-- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar for+-- dates before its adoption (from 1582 onwards, but varies from one country+-- to the next) produces+-- <https://en.wikipedia.org/wiki/Gregorian_calendar#Proleptic_Gregorian_calendar a proleptic calendar>,+-- which may cause some confusion.++-- | The number of days in a given month in the+-- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar.+--+-- @+-- > 'gregorianMonthLength' 2005 2+-- 28+-- @+{-# INLINE gregorianMonthLength #-}+gregorianMonthLength :: Year -> Month -> Days+gregorianMonthLength = monthLength . isLeapYear++-- | Add months, with days past the last day of the month clipped to the+-- last day.+--+-- See also 'addGregorianMonthsClip'.+--+-- @+-- > 'gregorianMonthsClip' 1 '$' 'YearMonthDay' 2005 1 30+-- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 2, 'ymdDay' = 28}+-- @+{-# INLINEABLE gregorianMonthsClip #-}+gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay+gregorianMonthsClip n (YearMonthDay y m d) = YearMonthDay y' m'+        $ min (gregorianMonthLength y' m') d where+    ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12++-- | Add months, with days past the last day of the month rolling over to+-- the next month.+--+-- See also 'addGregorianMonthsRollover'.+--+-- @+-- > 'gregorianMonthsRollover' 1 $ 'YearMonthDay' 2005 1 30+-- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 3, 'ymdDay' = 2}+-- @+{-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-}+{-# INLINEABLE gregorianMonthsRollover #-}+gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay+gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of+    True -> YearMonthDay y' m' d+    False -> case m' < 12 of+        True -> YearMonthDay y' (m' + 1) (d - len)+        False -> YearMonthDay (y' + 1) 1 (d - len)+  where+    ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12+    len = gregorianMonthLength y' m'++-- | Add years, matching month and day, with /February 29th/ clipped to the+-- /28th/ if necessary.+--+-- See also 'addGregorianYearsClip'.+--+-- @+-- > 'gregorianYearsClip' 2 $ 'YearMonthDay' 2004 2 29+-- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 2, 'ymdDay' = 28}+-- @+{-# INLINEABLE gregorianYearsClip #-}+gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay+gregorianYearsClip n (YearMonthDay ((+) n -> y') 2 29)+    | not (isLeapYear y') = YearMonthDay y' 2 28+gregorianYearsClip n (YearMonthDay y m d) = YearMonthDay (y + n) m d++-- | Add years, matching month and day, with /February 29th/ rolled over to+-- /March 1st/ if necessary.+--+-- See also 'addGregorianYearsRollover'.+--+-- @+-- > 'gregorianYearsRollover' 2 $ 'YearMonthDay' 2004 2 29+-- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 3, 'ymdDay' = 1}+-- @+{-# INLINEABLE gregorianYearsRollover #-}+gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay+gregorianYearsRollover n (YearMonthDay ((+) n -> y') 2 29)+    | not (isLeapYear y') = YearMonthDay y' 3 1+gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d++-- * Compatibility++-- | Add some 'Days' to a calendar 'Day' to get a new 'Day'.+--+-- @+-- 'addDays' = 'flip' ('.+^')+-- 'addDays' n d ≡ d '.+^' n+-- @+--+-- See also the 'AffineSpace' instance for 'Day'.+{-# INLINE addDays #-}+addDays :: Days -> Day -> Day+addDays = flip (.+^)++-- | Subtract two calendar 'Day's for the difference in 'Days'.+--+-- @+-- 'diffDays' = ('.-.')+-- 'diffDays' a b = a '.-.' b+-- @+--+-- See also the 'AffineSpace' instance for 'Day'.+{-# INLINE diffDays #-}+diffDays :: Day -> Day -> Days+diffDays = (.-.)++-- | Convert a 'Day' to its Gregorian 'Year', 'Month', and 'DayOfMonth'.+--+-- @+-- 'toGregorian' ('view' 'gregorian' -> 'YearMonthDay' y m d) = (y, m, d)+-- @+{-# INLINE toGregorian #-}+toGregorian :: Day -> (Year, Month, DayOfMonth)+toGregorian (view gregorian -> YearMonthDay y m d) = (y, m, d)++-- | Construct a 'Day' from a Gregorian calendar date.+-- Does not validate the input.+--+-- @+-- 'fromGregorian' y m d = 'gregorian' 'Control.Lens.#' 'YearMonthDay' y m d+-- @+{-# INLINE fromGregorian #-}+fromGregorian :: Year -> Month -> DayOfMonth -> Day+fromGregorian y m d = gregorian # YearMonthDay y m d++-- | Construct a 'Day' from a Gregorian calendar date.+-- Returns 'Nothing' for invalid input.+--+-- @+-- 'fromGregorianValid' y m d = 'gregorianValid' ('YearMonthDay' y m d)+-- @+{-# INLINE fromGregorianValid #-}+fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day+fromGregorianValid y m d = gregorianValid (YearMonthDay y m d)++-- | Add some number of 'Months' to the given 'Day'; if the original+-- 'DayOfMonth' exceeds that of the new 'Month', it will be clipped to the+-- last day of the new 'Month'.+--+-- @+-- 'addGregorianMonthsClip' n = 'gregorian' '%~' 'gregorianMonthsClip' n+-- @+{-# INLINE addGregorianMonthsClip #-}+addGregorianMonthsClip :: Months -> Day -> Day+addGregorianMonthsClip n = gregorian %~ gregorianMonthsClip n++-- | Add some number of 'Months' to the given 'Day'; if the original+-- 'DayOfMonth' exceeds that of the new 'Month', it will be rolled over into+-- the following 'Month'.+--+-- @+-- 'addGregorianMonthsRollover' n = 'gregorian' '%~' 'gregorianMonthsRollover' n+-- @+{-# INLINE addGregorianMonthsRollover #-}+addGregorianMonthsRollover :: Months -> Day -> Day+addGregorianMonthsRollover n = gregorian %~ gregorianMonthsRollover n++-- | Add some number of 'Years' to the given 'Day', with /February 29th/+-- clipped to /February 28th/ if necessary.+--+-- @+-- 'addGregorianYearsClip' n = 'gregorian' '%~' 'gregorianYearsClip' n+-- @+{-# INLINE addGregorianYearsClip #-}+addGregorianYearsClip :: Years -> Day -> Day+addGregorianYearsClip n = gregorian %~ gregorianYearsClip n++-- | Add some number of 'Years' to the given 'Day', with /February 29th/+-- rolled over to /March 1st/ if necessary.+--+-- @+-- 'addGregorianYearsRollover' n = 'gregorian' '%~' 'gregorianYearsRollover' n+-- @+{-# INLINE addGregorianYearsRollover #-}+addGregorianYearsRollover :: Years -> Day -> Day+addGregorianYearsRollover n = gregorian %~ gregorianYearsRollover n+

src/Data/Thyme/Calendar/Internal.hs view

@@ -1,750 +1,750 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-#if SHOW_INTERNAL
-{-# LANGUAGE StandaloneDeriving #-}
-#endif
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
-module Data.Thyme.Calendar.Internal where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.DeepSeq
-import Control.Lens
-import Control.Monad
-import Data.AffineSpace
-import Data.Bits
-import Data.Data
-import Data.Hashable
-import Data.Int
-import Data.Ix
-import Data.Thyme.Format.Internal
-#if __GLASGOW_HASKELL__ == 704
-import qualified Data.Vector.Generic
-import qualified Data.Vector.Generic.Mutable
-#endif
-import qualified Data.Vector.Unboxed as VU
-import Data.Vector.Unboxed.Deriving
-import GHC.Generics (Generic)
-import System.Random
-import Test.QuickCheck hiding ((.&.))
-
--- | A duration/count of years.
-type Years = Int
-
--- | A duration/count of months.
-type Months = Int
-
--- | A duration/count of days.
-type Days = Int
-
--- | A calendar-agnostic day, internally represented as a count of days
--- since /1858-11-17/, the
--- <https://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day>
--- (MJD) epoch.
---
--- To convert a 'Day' to the corresponding 'YearMonthDay' in the W_GREGORIAN
--- calendar, see 'gregorian'.
---
--- @
--- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1
--- 2016-03-01
--- @
---
--- 'Day' is an instance of 'AffineSpace' where @'Diff' 'Day' = 'Days'@, so
--- arithmetic on 'Day' and 'Days' can be performed with the '.-.', '.+^',
--- and '.-^' operators.
---
--- @
--- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1  '.-.'  'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 2 1
--- 29
--- @
---
--- @
--- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-^' 1
--- 2016-02-29
--- @
---
--- Other ways of viewing a 'Day' include 'ordinalDate', and 'weekDate'.
-newtype Day = ModifiedJulianDay
-    { toModifiedJulianDay :: Int
-    } deriving (INSTANCES_NEWTYPE, CoArbitrary)
-
-instance AffineSpace Day where
-    type Diff Day = Days
-    {-# INLINE (.-.) #-}
-    (.-.) = \ (ModifiedJulianDay a) (ModifiedJulianDay b) -> a - b
-    {-# INLINE (.+^) #-}
-    (.+^) = \ (ModifiedJulianDay a) d -> ModifiedJulianDay (a + d)
-
--- | Convert between a 'Day' and the corresponding count of days from
--- 1858-11-17, the MJD epoch.
---
--- @
--- 'modifiedJulianDay' = 'iso' 'toModifiedJulianDay' 'ModifiedJulianDay'
--- @
---
--- @
--- > 'modifiedJulianDay' 'Control.Lens.#' 0
--- 1858-11-17
--- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '&' 'modifiedJulianDay' '%~' 'subtract' 1
--- 2016-02-29
--- @
-{-# INLINE modifiedJulianDay #-}
-modifiedJulianDay :: Iso' Day Int
-modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay
-
--- | Conversion between a W_GREGORIAN 'OrdinalDate' and the corresponding
--- 'YearMonthDay'.
---
--- @
--- > 'OrdinalDate' 2016 32 '^.' 'yearMonthDay'
--- 'YearMonthDay' {ymdYear = 2016, ymdMonth = 2, ymdDay = 1}
--- @
---
--- @
--- > 'yearMonthDay' 'Control.Lens.#' 'YearMonthDay' 2016 2 1
--- 'OrdinalDate' {odYear = 2016, odDay = 32}
--- @
-{-# INLINE yearMonthDay #-}
-yearMonthDay :: Iso' OrdinalDate YearMonthDay
-yearMonthDay = iso fromOrdinal toOrdinal where
-
-    {-# INLINEABLE fromOrdinal #-}
-    fromOrdinal :: OrdinalDate -> YearMonthDay
-    fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where
-        MonthDay m d = yd ^. monthDay (isLeapYear y)
-
-    {-# INLINEABLE toOrdinal #-}
-    toOrdinal :: YearMonthDay -> OrdinalDate
-    toOrdinal (YearMonthDay y m d) = OrdinalDate y $
-        monthDay (isLeapYear y) # MonthDay m d
-
--- | Conversion between a 'Day' and its 'YearMonthDay'.
---
--- @
--- 'gregorian' = 'ordinalDate' . 'yearMonthDay'
--- @
---
--- @
--- > 'ModifiedJulianDay' 0 '^.' 'gregorian'
--- 'YearMonthDay' {ymdYear = 1858, ymdMonth = 11, ymdDay = 17}
--- @
---
--- @
--- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 1858 11 17
--- 1858-11-17
--- @
-{-# INLINE gregorian #-}
-gregorian :: Iso' Day YearMonthDay
-gregorian = ordinalDate . yearMonthDay
-
--- | Conversion between a 'YearMonthDay' and the corresponding 'Day'.
--- Returns 'Nothing' for invalid input.
---
--- @
--- > 'gregorianValid' ('YearMonthDay' 2015 2 28)
--- 'Just' 2015-02-28
--- @
---
--- @
--- > 'gregorianValid' ('YearMonthDay' 2015 2 29)
--- 'Nothing'
--- @
-{-# INLINEABLE gregorianValid #-}
-gregorianValid :: YearMonthDay -> Maybe Day
-gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y
-    <$> monthDayValid (isLeapYear y) (MonthDay m d)
-
--- | Shows a 'Day' in
--- <https://en.wikipedia.org/wiki/ISO_8601#Calendar_dates ISO 8601>
--- /YYYY-MM-DD/ format.
---
--- See "Data.Thyme.Format" for other possibilities.
-{-# INLINEABLE showGregorian #-}
-showGregorian :: Day -> String
-showGregorian (view gregorian -> YearMonthDay y m d) =
-    showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ ""
-
-#if SHOW_INTERNAL
-deriving instance Show Day
-#else
-instance Show Day where show = showGregorian
-#endif
-
-------------------------------------------------------------------------
-
--- | Calendar year.
-type Year = Int
-
--- | Calendar month. /January = 1/
-type Month = Int
-
--- | Calendar day-of-month, starting from /1/.
-type DayOfMonth = Int
-
--- | A strict triple of a 'Year', a 'Day', and a 'Month'.
-data YearMonthDay = YearMonthDay
-    { ymdYear :: {-# UNPACK #-}!Year
-    , ymdMonth :: {-# UNPACK #-}!Month
-    , ymdDay :: {-# UNPACK #-}!DayOfMonth
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(YearMonthDay,ymdYear,Year)
-LENS(YearMonthDay,ymdMonth,Month)
-LENS(YearMonthDay,ymdDay,DayOfMonth)
-
-instance Hashable YearMonthDay
-instance NFData YearMonthDay
-
-------------------------------------------------------------------------
-
--- | Is it a leap year according to the W_GREGORIAN calendar?
-isLeapYear :: Year -> Bool
-isLeapYear y = y .&. 3 == 0 && (r100 /= 0 || q100 .&. 3 == 0) where
-    (q100, r100) = y `quotRem` 100
-
--- | The day of the year, with /1 = January 1st/.
-type DayOfYear = Int
-
--- | An
--- <https://en.wikipedia.org/wiki/ISO_8601#Ordinal_dates ISO 8601 ordinal date>.
-data OrdinalDate = OrdinalDate
-    { odYear :: {-# UNPACK #-}!Year
-    , odDay :: {-# UNPACK #-}!DayOfYear
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(OrdinalDate,odYear,Year)
-LENS(OrdinalDate,odDay,DayOfYear)
-
-instance Hashable OrdinalDate
-instance NFData OrdinalDate
-
--- | Conversion between the MJD 'Day' and 'OrdinalDate'.
---
--- @
--- > 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32
--- 2016-02-01
--- @
---
--- @
--- > 'toModifiedJulianDay' $ 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32
--- 57419
--- @
---
--- @
--- > 'ModifiedJulianDay' 57419 '^.' 'ordinalDate'
--- 'OrdinalDate' {odYear = 2016, odDay = 32}
--- @
-{-# INLINE ordinalDate #-}
-ordinalDate :: Iso' Day OrdinalDate
-ordinalDate = iso toOrd fromOrd where
-
--- Brief description of the toOrd computation
---
--- The length of the years in the Gregorian calendar is periodic with period
--- of /400/ years. There are /100 - 4 + 1 = 97/ leap years in a period, so
--- the average length of a year is /365 + 97\/400 = 146097\/400/ days.
---
--- Now, if you consider these — let's call them nominal — years,
--- then for any point in time, for any linear day number we can
--- determine which nominal year does it fall into by a single
--- division. Moreover, if we align the start of the calendar year /1/
--- with the start of the nominal year /1/, then the calendar years and
--- nominal years never get too much out of sync. Specifically:
---
---  * The start of the first day of a calendar year might fall into the
---    preceding nominal year, but never more than by /1.5/ days (/591\/400/
---    days, to be precise).
---
---  * The start of the last day of a calendar year always falls into
---    its nominal year (even for the leap years).
---
--- So, to find out the calendar year for a given day, we calculate
--- on which nominal year does its start fall. And, if we are not too
--- close to the end of year, we have the right calendar
--- year. Othewise, we just check whether it falls within the next
--- calendar year.
---
--- Notes: to make the reasoning simpler and more efficient ('quot' is
--- faster than 'div') we do the computation directly only for positive
--- years (days after /0001-01-01/). For earlier dates we translate by an
--- integral number of /400/ year periods, do the computation and
--- translate back.
-
-    {-# INLINEABLE toOrd #-}
-    toOrd :: Day -> OrdinalDate
-    toOrd (ModifiedJulianDay mjd)
-      | dayB0 <= 0 = case toOrdB0 dayInQC of
-        OrdinalDate y yd -> OrdinalDate (y + quadCent * 400) yd
-      | otherwise = toOrdB0 dayB0
-      where
-        dayB0 = mjd + 678575
-        (quadCent, dayInQC) = dayB0 `divMod` 146097
-
-    -- Input: days since 0001-01-01. Precondition: has to be positive!
-    {-# INLINE toOrdB0 #-}
-    toOrdB0 :: Int -> OrdinalDate
-    toOrdB0 dayB0 = res
-      where
-        (y0, r) = (400 * dayB0) `quotRem` 146097
-        d0 = dayInYear y0 dayB0
-        d1 = dayInYear (y0 + 1) dayB0
-        res = if r > 146097 - 600 && d1 > 0
-              then OrdinalDate (y0 + 1 + 1) d1
-              else OrdinalDate (y0 + 1) d0
-
-    -- Input: (year - 1) (day as days since 0001-01-01)
-    -- Precondition: year is positive!
-    {-# INLINE dayInYear #-}
-    dayInYear :: Int -> Int -> Int
-    dayInYear y0 dayB0 = dayB0 - 365 * y0 - leaps + 1
-      where
-        leaps = y0 `shiftR` 2 - centuries + centuries `shiftR` 2
-        centuries = y0 `quot` 100
-
-    {-# INLINEABLE fromOrd #-}
-    fromOrd :: OrdinalDate -> Day
-    fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where
-        years = year - 1
-        centuries = years `div` 100
-        leaps = years `shiftR` 2 - centuries + centuries `shiftR` 2
-        mjd = 365 * years + leaps - 678576
-            + clip 1 (if isLeapYear year then 366 else 365) yd
-        clip a b = max a . min b
-
-------------------------------------------------------------------------
--- Lookup tables for Data.Thyme.Calendar.MonthDay
-
-{-# NOINLINE monthLengths #-}
-{-# NOINLINE monthLengthsLeap #-}
-monthLengths, monthLengthsLeap :: VU.Vector Days
-monthLengths     = VU.fromList [31,28,31,30,31,30,31,31,30,31,30,31]
-monthLengthsLeap = VU.fromList [31,29,31,30,31,30,31,31,30,31,30,31]
-                             -- J  F  M  A  M  J  J  A  S  O  N  D
-
-{-# ANN monthDays "HLint: ignore Use fromMaybe" #-}
-{-# NOINLINE monthDays #-}
-monthDays :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)
-monthDays = VU.generate 365 go where
-    dom01 = VU.prescanl' (+) 0 monthLengths
-    go yd = (fromIntegral m, fromIntegral d) where
-        m = maybe 12 id $ VU.findIndex (yd <) dom01
-        d = succ yd - VU.unsafeIndex dom01 (pred m)
-
-{-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-}
-{-# NOINLINE monthDaysLeap #-}
-monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)
-monthDaysLeap = VU.generate 366 go where
-    dom01 = VU.prescanl' (+) 0 monthLengthsLeap
-    go yd = (fromIntegral m, fromIntegral d) where
-        m = maybe 12 id $ VU.findIndex (yd <) dom01
-        d = succ yd - VU.unsafeIndex dom01 (pred m)
-
--- | No good home for this within the current hierarchy. This will do.
-{-# INLINEABLE randomIsoR #-}
-randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g)
-randomIsoR l (x, y) = first (^. l) . randomR (l # x, l # y)
-
-------------------------------------------------------------------------
-
--- | A strict pair of a 'Month' and a 'DayOfMonth'.
-data MonthDay = MonthDay
-    { mdMonth :: {-# UNPACK #-}!Month
-    , mdDay :: {-# UNPACK #-}!DayOfMonth
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(MonthDay,mdMonth,Month)
-LENS(MonthDay,mdDay,DayOfMonth)
-
-instance Hashable MonthDay
-instance NFData MonthDay
-
-instance Bounded MonthDay where
-    minBound = MonthDay 1 1
-    maxBound = MonthDay 12 31
-
-instance Random MonthDay where
-    randomR r g = randomIsoR (monthDay leap) r g' where
-        (isLeapYear -> leap, g') = random g
-    random = randomR (minBound, maxBound)
-
-instance Arbitrary MonthDay where
-    arbitrary = choose (minBound, maxBound)
-    shrink md = view (monthDay True) <$> shrink (monthDay True # md)
-
-instance CoArbitrary MonthDay where
-    coarbitrary (MonthDay m d) = coarbitrary m . coarbitrary d
-
--- | Predicated on whether or not it's a leap year, convert between an
--- ordinal 'DayOfYear' and the corresponding 'Month' and 'DayOfMonth'.
---
--- @
--- > 60 '^.' 'monthDay' ('isLeapYear' 2015)
--- 'MonthDay' {'mdMonth' = 3, 'mdDay' = 1}
--- @
---
--- @
--- > 60 '^.' 'monthDay' ('isLeapYear' 2016)
--- 'MonthDay' {'mdMonth' = 2, 'mdDay' = 29}
--- @
---
--- @
--- > 'monthDay' ('isLeapYear' 2016) 'Control.Lens.#' 'MonthDay' 2 29
--- 60
--- @
---
--- @
--- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 28
--- 59
--- @
---
--- Note that 'monthDay' is an improper 'Iso', as the following example
--- shows. To handle this case correctly, use 'monthDayValid'.
---
--- @
--- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 29
--- 59
--- @
-{-# INLINE monthDay #-}
-monthDay
-    :: Bool -- ^ 'isLeapYear'?
-    -> Iso' DayOfYear MonthDay
-monthDay leap = iso fromOrdinal toOrdinal where
-    (lastDay, lengths, table, ok) = if leap
-        then (365, monthLengthsLeap, monthDaysLeap, -1)
-        else (364, monthLengths, monthDays, -2)
-
-    {-# INLINE fromOrdinal #-}
-    fromOrdinal :: DayOfYear -> MonthDay
-    fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where
-        (fromIntegral -> m, fromIntegral -> d) = VU.unsafeIndex table i
-
-    {-# INLINE toOrdinal #-}
-    toOrdinal :: MonthDay -> DayOfYear
-    toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where
-        m = max 1 . min 12 $ month
-        l = VU.unsafeIndex lengths (pred m)
-        d = max 1 . min l $ day
-        k = if m <= 2 then 0 else ok
-
--- | Predicated on whether or not it's a leap year, convert a 'MonthDay' to
--- an ordinal 'DayOfYear'.
---
--- @
--- > 'monthDayValid' ('isLeapYear' 2016) ('MonthDay' 2 29)
--- 'Just' 60
--- @
---
--- @
--- > 'monthDayValid' ('isLeapYear' 2015) ('MonthDay' 2 29)
--- 'Nothing'
--- @
-{-# INLINEABLE monthDayValid #-}
-monthDayValid
-    :: Bool -- ^ 'isLeapYear'?
-    -> MonthDay
-    -> Maybe DayOfYear
-monthDayValid leap md@(MonthDay m d) = monthDay leap # md
-    <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m)
-
--- | Predicated on whether or not the year is a leap year, return the number
--- of 'Days' in the given 'Month'.
---
--- @
--- > monthLength ('isLeapYear' 2015) 2
---   28
--- @
---
--- @
--- > monthLength ('isLeapYear' 2016) 2
---   29
--- @
-{-# INLINEABLE monthLength #-}
-monthLength
-    :: Bool -- ^ 'isLeapYear'?
-    -> Month
-    -> Days
-monthLength leap = VU.unsafeIndex ls . max 0 . min 11 . pred where
-    ls = if leap then monthLengthsLeap else monthLengths
-
-------------------------------------------------------------------------
-
--- | Week of the year.
---
--- Meaning of values depends on context; see 'wdWeek', 'swWeek', 'mwWeek'.
-type WeekOfYear = Int
-
--- | Day of the week.
---
--- [/0/] /Sunday/ for 'SundayWeek'
---
--- [/1/…/6/] /Monday/…/Saturday/
---
--- [/7/] /Sunday/ for 'WeekDate', 'MondayWeek', and 'Data.Thyme.Calendar.WeekdayOfMonth.WeekdayOfMonth'
-type DayOfWeek = Int
-
--- | <https://en.wikipedia.org/wiki/ISO_week_date ISO 8601 Week Date>.
---
--- Note that week /01/ is defined as the week with the first Thursday, thus
--- 'wdYear' may differ from the Gregorian year between /December 29th/ and
--- /January 3rd/.
-data WeekDate = WeekDate
-    { wdYear :: {-# UNPACK #-}!Year
-    , wdWeek :: {-# UNPACK #-}!WeekOfYear
-        -- ^ Numbered /01/ to /53/. Days before week /01/ are considered to
-        -- belong to the previous year.
-    , wdDay :: {-# UNPACK #-}!DayOfWeek
-        -- ^ /1 = Monday/ … /7 = Sunday/.
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(WeekDate,wdYear,Year)
-LENS(WeekDate,wdWeek,WeekOfYear)
-LENS(WeekDate,wdDay,DayOfWeek)
-
-instance Hashable WeekDate
-instance NFData WeekDate
-
--- | Convert between a 'Day' and an ISO 8601 'WeekDate'.
---
--- @
--- > 'YearMonthDay' 2016 1 1 '^.' 'from' 'gregorian' '.' 'weekDate'
--- 'WeekDate' {'wdYear' = 2015, 'wdWeek' = 53, 'wdDay' = 5}
--- @
-{-# INLINE weekDate #-}
-weekDate :: Iso' Day WeekDate
-weekDate = iso toWeek fromWeek where
-
-    {-# INLINEABLE toWeek #-}
-    toWeek :: Day -> WeekDate
-    toWeek = join (toWeekOrdinal . view ordinalDate)
-
-    {-# INLINEABLE fromWeek #-}
-    fromWeek :: WeekDate -> Day
-    fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd
-
-{-# INLINE toWeekOrdinal #-}
-toWeekOrdinal :: OrdinalDate -> Day -> WeekDate
-toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) =
-        WeekDate y1 (w1 + 1) (d7mod + 1) where
-    -- pilfered and refactored; no idea what foo and bar mean
-    d = mjd + 2
-    (d7div, d7mod) = divMod d 7
-    foo :: Year -> {-WeekOfYear-1-}Int
-    foo y = bar $ ordinalDate # OrdinalDate y 6
-    bar :: Day -> {-WeekOfYear-1-}Int
-    bar (ModifiedJulianDay k) = d7div - div k 7
-    w0 = bar $ ModifiedJulianDay (d - yd + 4)
-    (y1, w1) = case w0 of
-        -1 -> (y0 - 1, foo (y0 - 1))
-        52 | foo (y0 + 1) == 0 -> (y0 + 1, 0)
-        _ -> (y0, w0)
-
-{-# INLINE lastWeekOfYear #-}
-lastWeekOfYear :: Year -> WeekOfYear
-lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where
-    wd = OrdinalDate y 365 ^. from ordinalDate . weekDate
-
-{-# INLINE fromWeekLast #-}
-fromWeekLast :: WeekOfYear -> WeekDate -> Day
-fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where
-    -- pilfered and refactored
-    ModifiedJulianDay k = ordinalDate # OrdinalDate y 6
-    mjd = k - mod k 7 - 10 + clip 1 7 d + clip 1 wMax w * 7
-    clip a b = max a . min b
-
--- | Convert a 'WeekDate' to a 'Day', or 'Nothing' for invalid 'WeekDate'.
-{-# INLINEABLE weekDateValid #-}
-weekDateValid :: WeekDate -> Maybe Day
-weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) =
-    fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax)
-
--- | Shows a 'Day' using the @yyyy-Www-d@ ISO 8601 Week Date format.
---
--- @
--- > 'showWeekDate' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2006 11 15)
--- "2006-W46-3"
--- @
-{-# INLINEABLE showWeekDate #-}
-showWeekDate :: Day -> String
-showWeekDate (view weekDate -> WeekDate y w d) =
-    showsYear y . (++) "-W" . shows02 w . (:) '-' $ show d
-
-------------------------------------------------------------------------
-
--- | Week-based calendar date with the first /Sunday/ of the year as the first
--- day of week /01/. This corresponds to @%U@ and @%w@ of
--- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@.
---
--- The final week of a given year and week /00/ of the next both refer to
--- the same week.
-data SundayWeek = SundayWeek
-    { swYear :: {-# UNPACK #-}!Year
-        -- ^ Coincides with that of 'gregorian'.
-    , swWeek :: {-# UNPACK #-}!WeekOfYear
-        -- ^ Weeks numbered from /00/ to /53/, starting with the first
-        -- /Sunday/ of the year as the first day of week /01/.
-    , swDay :: {-# UNPACK #-}!DayOfWeek
-        -- ^ /0 = Sunday/.
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(SundayWeek,swYear,Year)
-LENS(SundayWeek,swWeek,WeekOfYear)
-LENS(SundayWeek,swDay,DayOfWeek)
-
-instance Hashable SundayWeek
-instance NFData SundayWeek
-
--- | Conversion between 'Day' and 'SundayWeek'.
---
--- @
--- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'sundayWeek'
--- 'SundayWeek' {'swYear' = 2016, 'swWeek' = 1, 'swDay' = 0}
--- @
-{-# INLINE sundayWeek #-}
-sundayWeek :: Iso' Day SundayWeek
-sundayWeek = iso toSunday fromSunday where
-
-    {-# INLINEABLE toSunday #-}
-    toSunday :: Day -> SundayWeek
-    toSunday = join (toSundayOrdinal . view ordinalDate)
-
-    {-# INLINEABLE fromSunday #-}
-    fromSunday :: SundayWeek -> Day
-    fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where
-        ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1
-        -- following are all 0-based year days
-        firstSunday = mod (4 - firstDay) 7
-        yd = firstSunday + 7 * (w - 1) + d
-
-{-# INLINE toSundayOrdinal #-}
-toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek
-toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) =
-        SundayWeek y (d7div - div k 7) d7mod where
-    d = mjd + 3
-    k = d - yd
-    (d7div, d7mod) = divMod d 7
-
--- | Convert a 'SundayWeek' to a 'Day', or 'Nothing' for invalid 'SundayWeek'.
-{-# INLINEABLE sundayWeekValid #-}
-sundayWeekValid :: SundayWeek -> Maybe Day
-sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd)
-        <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where
-    ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1
-    -- following are all 0-based year days
-    firstSunday = mod (4 - firstDay) 7
-    yd = firstSunday + 7 * (w - 1) + d
-    lastDay = if isLeapYear y then 365 else 364
-
-------------------------------------------------------------------------
-
--- | Week-based calendar date with the first /Monday/ of the year as the first
--- day of week /01/. This corresponds to @%W@ and @%u@ of
--- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@.
---
--- The final week of a given year and week /00/ of the next both refer to
--- the same week.
-data MondayWeek = MondayWeek
-    { mwYear :: {-# UNPACK #-}!Year
-        -- ^ Coincides with that of 'gregorian'.
-    , mwWeek :: {-# UNPACK #-}!WeekOfYear
-        -- ^ Weeks numbered from /00/ to /53/, starting with the first
-        -- /Monday/ of the year as the first day of week /01/.
-    , mwDay :: {-# UNPACK #-}!DayOfWeek
-        -- ^ /7 = Sunday/.
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(MondayWeek,mwYear,Year)
-LENS(MondayWeek,mwWeek,WeekOfYear)
-LENS(MondayWeek,mwDay,DayOfWeek)
-
-instance Hashable MondayWeek
-instance NFData MondayWeek
-
--- | Conversion between 'Day' and 'MondayWeek'.
---
--- @
--- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'mondayWeek'
--- 'MondayWeek' {'mwYear' = 2016, 'mwWeek' = 0, 'mwDay' = 7}
--- @
-{-# INLINE mondayWeek #-}
-mondayWeek :: Iso' Day MondayWeek
-mondayWeek = iso toMonday fromMonday where
-
-    {-# INLINEABLE toMonday #-}
-    toMonday :: Day -> MondayWeek
-    toMonday = join (toMondayOrdinal . view ordinalDate)
-
-    {-# INLINEABLE fromMonday #-}
-    fromMonday :: MondayWeek -> Day
-    fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where
-        ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1
-        -- following are all 0-based year days
-        firstMonday = mod (5 - firstDay) 7
-        yd = firstMonday + 7 * (w - 1) + d - 1
-
-{-# INLINE toMondayOrdinal #-}
-toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek
-toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) =
-        MondayWeek y (d7div - div k 7) (d7mod + 1) where
-    d = mjd + 2
-    k = d - yd
-    (d7div, d7mod) = divMod d 7
-
--- | Convert a 'MondayWeek' to a 'Day', or 'Nothing' for invalid 'MondayWeek'.
-{-# INLINEABLE mondayWeekValid #-}
-mondayWeekValid :: MondayWeek -> Maybe Day
-mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd)
-        <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where
-    ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1
-    -- following are all 0-based year days
-    firstMonday = mod (5 - firstDay) 7
-    yd = firstMonday + 7 * (w - 1) + d - 1
-    lastDay = if isLeapYear y then 365 else 364
-
-------------------------------------------------------------------------
--- Unbox instances at the end avoids TH-related declaration order issues
-
-derivingUnbox "Day" [t| Day -> Int |]
-    [| toModifiedJulianDay |] [| ModifiedJulianDay |]
-
-derivingUnbox "YearMonthDay" [t| YearMonthDay -> Int |]
-    [| \ YearMonthDay {..} -> shiftL ymdYear 9 .|. shiftL ymdMonth 5 .|. ymdDay |]
-    [| \ n -> YearMonthDay (shiftR n 9) (shiftR n 5 .&. 0xf) (n .&. 0x1f) |]
-
-derivingUnbox "OrdinalDate" [t| OrdinalDate -> Int |]
-    [| \ OrdinalDate {..} -> shiftL odYear 9 .|. odDay |]
-    [| \ n -> OrdinalDate (shiftR n 9) (n .&. 0x1ff) |]
-
-derivingUnbox "MonthDay" [t| MonthDay -> Int |]
-    [| \ MonthDay {..} -> shiftL mdMonth 5 .|. mdDay |]
-    [| \ n -> MonthDay (shiftR n 5) (n .&. 0x1f) |]
-
-derivingUnbox "WeekDate" [t| WeekDate -> Int |]
-    [| \ WeekDate {..} -> shiftL wdYear 9 .|. shiftL wdWeek 3 .|. wdDay |]
-    [| \ n -> WeekDate (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]
-
-derivingUnbox "SundayWeek" [t| SundayWeek -> Int |]
-    [| \ SundayWeek {..} -> shiftL swYear 9 .|. shiftL swWeek 3 .|. swDay |]
-    [| \ n -> SundayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]
-
-derivingUnbox "MondayWeek" [t| MondayWeek -> Int |]
-    [| \ MondayWeek {..} -> shiftL mwYear 9 .|. shiftL mwWeek 3 .|. mwDay |]
-    [| \ n -> MondayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+#if SHOW_INTERNAL+{-# LANGUAGE StandaloneDeriving #-}+#endif+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++module Data.Thyme.Calendar.Internal where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.AffineSpace+import Data.Bits+import Data.Data+import Data.Hashable+import Data.Int+import Data.Ix+import Data.Thyme.Format.Internal+#if __GLASGOW_HASKELL__ == 704+import qualified Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable+#endif+import qualified Data.Vector.Unboxed as VU+import Data.Vector.Unboxed.Deriving+import GHC.Generics (Generic)+import System.Random+import Test.QuickCheck hiding ((.&.))++-- | A duration/count of years.+type Years = Int++-- | A duration/count of months.+type Months = Int++-- | A duration/count of days.+type Days = Int++-- | A calendar-agnostic day, internally represented as a count of days+-- since /1858-11-17/, the+-- <https://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day>+-- (MJD) epoch.+--+-- To convert a 'Day' to the corresponding 'YearMonthDay' in the W_GREGORIAN+-- calendar, see 'gregorian'.+--+-- @+-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1+-- 2016-03-01+-- @+--+-- 'Day' is an instance of 'AffineSpace' where @'Diff' 'Day' = 'Days'@, so+-- arithmetic on 'Day' and 'Days' can be performed with the '.-.', '.+^',+-- and '.-^' operators.+--+-- @+-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1  '.-.'  'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 2 1+-- 29+-- @+--+-- @+-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-^' 1+-- 2016-02-29+-- @+--+-- Other ways of viewing a 'Day' include 'ordinalDate', and 'weekDate'.+newtype Day = ModifiedJulianDay+    { toModifiedJulianDay :: Int+    } deriving (INSTANCES_NEWTYPE, CoArbitrary)++instance AffineSpace Day where+    type Diff Day = Days+    {-# INLINE (.-.) #-}+    (.-.) = \ (ModifiedJulianDay a) (ModifiedJulianDay b) -> a - b+    {-# INLINE (.+^) #-}+    (.+^) = \ (ModifiedJulianDay a) d -> ModifiedJulianDay (a + d)++-- | Convert between a 'Day' and the corresponding count of days from+-- 1858-11-17, the MJD epoch.+--+-- @+-- 'modifiedJulianDay' = 'iso' 'toModifiedJulianDay' 'ModifiedJulianDay'+-- @+--+-- @+-- > 'modifiedJulianDay' 'Control.Lens.#' 0+-- 1858-11-17+-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '&' 'modifiedJulianDay' '%~' 'subtract' 1+-- 2016-02-29+-- @+{-# INLINE modifiedJulianDay #-}+modifiedJulianDay :: Iso' Day Int+modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay++-- | Conversion between a W_GREGORIAN 'OrdinalDate' and the corresponding+-- 'YearMonthDay'.+--+-- @+-- > 'OrdinalDate' 2016 32 '^.' 'yearMonthDay'+-- 'YearMonthDay' {ymdYear = 2016, ymdMonth = 2, ymdDay = 1}+-- @+--+-- @+-- > 'yearMonthDay' 'Control.Lens.#' 'YearMonthDay' 2016 2 1+-- 'OrdinalDate' {odYear = 2016, odDay = 32}+-- @+{-# INLINE yearMonthDay #-}+yearMonthDay :: Iso' OrdinalDate YearMonthDay+yearMonthDay = iso fromOrdinal toOrdinal where++    {-# INLINEABLE fromOrdinal #-}+    fromOrdinal :: OrdinalDate -> YearMonthDay+    fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where+        MonthDay m d = yd ^. monthDay (isLeapYear y)++    {-# INLINEABLE toOrdinal #-}+    toOrdinal :: YearMonthDay -> OrdinalDate+    toOrdinal (YearMonthDay y m d) = OrdinalDate y $+        monthDay (isLeapYear y) # MonthDay m d++-- | Conversion between a 'Day' and its 'YearMonthDay'.+--+-- @+-- 'gregorian' = 'ordinalDate' . 'yearMonthDay'+-- @+--+-- @+-- > 'ModifiedJulianDay' 0 '^.' 'gregorian'+-- 'YearMonthDay' {ymdYear = 1858, ymdMonth = 11, ymdDay = 17}+-- @+--+-- @+-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 1858 11 17+-- 1858-11-17+-- @+{-# INLINE gregorian #-}+gregorian :: Iso' Day YearMonthDay+gregorian = ordinalDate . yearMonthDay++-- | Conversion between a 'YearMonthDay' and the corresponding 'Day'.+-- Returns 'Nothing' for invalid input.+--+-- @+-- > 'gregorianValid' ('YearMonthDay' 2015 2 28)+-- 'Just' 2015-02-28+-- @+--+-- @+-- > 'gregorianValid' ('YearMonthDay' 2015 2 29)+-- 'Nothing'+-- @+{-# INLINEABLE gregorianValid #-}+gregorianValid :: YearMonthDay -> Maybe Day+gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y+    <$> monthDayValid (isLeapYear y) (MonthDay m d)++-- | Shows a 'Day' in+-- <https://en.wikipedia.org/wiki/ISO_8601#Calendar_dates ISO 8601>+-- /YYYY-MM-DD/ format.+--+-- See "Data.Thyme.Format" for other possibilities.+{-# INLINEABLE showGregorian #-}+showGregorian :: Day -> String+showGregorian (view gregorian -> YearMonthDay y m d) =+    showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ ""++#if SHOW_INTERNAL+deriving instance Show Day+#else+instance Show Day where show = showGregorian+#endif++------------------------------------------------------------------------++-- | Calendar year.+type Year = Int++-- | Calendar month. /January = 1/+type Month = Int++-- | Calendar day-of-month, starting from /1/.+type DayOfMonth = Int++-- | A strict triple of a 'Year', a 'Day', and a 'Month'.+data YearMonthDay = YearMonthDay+    { ymdYear :: {-# UNPACK #-}!Year+    , ymdMonth :: {-# UNPACK #-}!Month+    , ymdDay :: {-# UNPACK #-}!DayOfMonth+    } deriving (INSTANCES_USUAL, Show)++LENS(YearMonthDay,ymdYear,Year)+LENS(YearMonthDay,ymdMonth,Month)+LENS(YearMonthDay,ymdDay,DayOfMonth)++instance Hashable YearMonthDay+instance NFData YearMonthDay++------------------------------------------------------------------------++-- | Is it a leap year according to the W_GREGORIAN calendar?+isLeapYear :: Year -> Bool+isLeapYear y = y .&. 3 == 0 && (r100 /= 0 || q100 .&. 3 == 0) where+    (q100, r100) = y `quotRem` 100++-- | The day of the year, with /1 = January 1st/.+type DayOfYear = Int++-- | An+-- <https://en.wikipedia.org/wiki/ISO_8601#Ordinal_dates ISO 8601 ordinal date>.+data OrdinalDate = OrdinalDate+    { odYear :: {-# UNPACK #-}!Year+    , odDay :: {-# UNPACK #-}!DayOfYear+    } deriving (INSTANCES_USUAL, Show)++LENS(OrdinalDate,odYear,Year)+LENS(OrdinalDate,odDay,DayOfYear)++instance Hashable OrdinalDate+instance NFData OrdinalDate++-- | Conversion between the MJD 'Day' and 'OrdinalDate'.+--+-- @+-- > 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32+-- 2016-02-01+-- @+--+-- @+-- > 'toModifiedJulianDay' $ 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32+-- 57419+-- @+--+-- @+-- > 'ModifiedJulianDay' 57419 '^.' 'ordinalDate'+-- 'OrdinalDate' {odYear = 2016, odDay = 32}+-- @+{-# INLINE ordinalDate #-}+ordinalDate :: Iso' Day OrdinalDate+ordinalDate = iso toOrd fromOrd where++-- Brief description of the toOrd computation+--+-- The length of the years in the Gregorian calendar is periodic with period+-- of /400/ years. There are /100 - 4 + 1 = 97/ leap years in a period, so+-- the average length of a year is /365 + 97\/400 = 146097\/400/ days.+--+-- Now, if you consider these — let's call them nominal — years,+-- then for any point in time, for any linear day number we can+-- determine which nominal year does it fall into by a single+-- division. Moreover, if we align the start of the calendar year /1/+-- with the start of the nominal year /1/, then the calendar years and+-- nominal years never get too much out of sync. Specifically:+--+--  * The start of the first day of a calendar year might fall into the+--    preceding nominal year, but never more than by /1.5/ days (/591\/400/+--    days, to be precise).+--+--  * The start of the last day of a calendar year always falls into+--    its nominal year (even for the leap years).+--+-- So, to find out the calendar year for a given day, we calculate+-- on which nominal year does its start fall. And, if we are not too+-- close to the end of year, we have the right calendar+-- year. Othewise, we just check whether it falls within the next+-- calendar year.+--+-- Notes: to make the reasoning simpler and more efficient ('quot' is+-- faster than 'div') we do the computation directly only for positive+-- years (days after /0001-01-01/). For earlier dates we translate by an+-- integral number of /400/ year periods, do the computation and+-- translate back.++    {-# INLINEABLE toOrd #-}+    toOrd :: Day -> OrdinalDate+    toOrd (ModifiedJulianDay mjd)+      | dayB0 <= 0 = case toOrdB0 dayInQC of+        OrdinalDate y yd -> OrdinalDate (y + quadCent * 400) yd+      | otherwise = toOrdB0 dayB0+      where+        dayB0 = mjd + 678575+        (quadCent, dayInQC) = dayB0 `divMod` 146097++    -- Input: days since 0001-01-01. Precondition: has to be positive!+    {-# INLINE toOrdB0 #-}+    toOrdB0 :: Int -> OrdinalDate+    toOrdB0 dayB0 = res+      where+        (y0, r) = (400 * dayB0) `quotRem` 146097+        d0 = dayInYear y0 dayB0+        d1 = dayInYear (y0 + 1) dayB0+        res = if r > 146097 - 600 && d1 > 0+              then OrdinalDate (y0 + 1 + 1) d1+              else OrdinalDate (y0 + 1) d0++    -- Input: (year - 1) (day as days since 0001-01-01)+    -- Precondition: year is positive!+    {-# INLINE dayInYear #-}+    dayInYear :: Int -> Int -> Int+    dayInYear y0 dayB0 = dayB0 - 365 * y0 - leaps + 1+      where+        leaps = y0 `shiftR` 2 - centuries + centuries `shiftR` 2+        centuries = y0 `quot` 100++    {-# INLINEABLE fromOrd #-}+    fromOrd :: OrdinalDate -> Day+    fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where+        years = year - 1+        centuries = years `div` 100+        leaps = years `shiftR` 2 - centuries + centuries `shiftR` 2+        mjd = 365 * years + leaps - 678576+            + clip 1 (if isLeapYear year then 366 else 365) yd+        clip a b = max a . min b++------------------------------------------------------------------------+-- Lookup tables for Data.Thyme.Calendar.MonthDay++{-# NOINLINE monthLengths #-}+{-# NOINLINE monthLengthsLeap #-}+monthLengths, monthLengthsLeap :: VU.Vector Days+monthLengths     = VU.fromList [31,28,31,30,31,30,31,31,30,31,30,31]+monthLengthsLeap = VU.fromList [31,29,31,30,31,30,31,31,30,31,30,31]+                             -- J  F  M  A  M  J  J  A  S  O  N  D++{-# ANN monthDays "HLint: ignore Use fromMaybe" #-}+{-# NOINLINE monthDays #-}+monthDays :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)+monthDays = VU.generate 365 go where+    dom01 = VU.prescanl' (+) 0 monthLengths+    go yd = (fromIntegral m, fromIntegral d) where+        m = maybe 12 id $ VU.findIndex (yd <) dom01+        d = succ yd - VU.unsafeIndex dom01 (pred m)++{-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-}+{-# NOINLINE monthDaysLeap #-}+monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)+monthDaysLeap = VU.generate 366 go where+    dom01 = VU.prescanl' (+) 0 monthLengthsLeap+    go yd = (fromIntegral m, fromIntegral d) where+        m = maybe 12 id $ VU.findIndex (yd <) dom01+        d = succ yd - VU.unsafeIndex dom01 (pred m)++-- | No good home for this within the current hierarchy. This will do.+{-# INLINEABLE randomIsoR #-}+randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g)+randomIsoR l (x, y) = first (^. l) . randomR (l # x, l # y)++------------------------------------------------------------------------++-- | A strict pair of a 'Month' and a 'DayOfMonth'.+data MonthDay = MonthDay+    { mdMonth :: {-# UNPACK #-}!Month+    , mdDay :: {-# UNPACK #-}!DayOfMonth+    } deriving (INSTANCES_USUAL, Show)++LENS(MonthDay,mdMonth,Month)+LENS(MonthDay,mdDay,DayOfMonth)++instance Hashable MonthDay+instance NFData MonthDay++instance Bounded MonthDay where+    minBound = MonthDay 1 1+    maxBound = MonthDay 12 31++instance Random MonthDay where+    randomR r g = randomIsoR (monthDay leap) r g' where+        (isLeapYear -> leap, g') = random g+    random = randomR (minBound, maxBound)++instance Arbitrary MonthDay where+    arbitrary = choose (minBound, maxBound)+    shrink md = view (monthDay True) <$> shrink (monthDay True # md)++instance CoArbitrary MonthDay where+    coarbitrary (MonthDay m d) = coarbitrary m . coarbitrary d++-- | Predicated on whether or not it's a leap year, convert between an+-- ordinal 'DayOfYear' and the corresponding 'Month' and 'DayOfMonth'.+--+-- @+-- > 60 '^.' 'monthDay' ('isLeapYear' 2015)+-- 'MonthDay' {'mdMonth' = 3, 'mdDay' = 1}+-- @+--+-- @+-- > 60 '^.' 'monthDay' ('isLeapYear' 2016)+-- 'MonthDay' {'mdMonth' = 2, 'mdDay' = 29}+-- @+--+-- @+-- > 'monthDay' ('isLeapYear' 2016) 'Control.Lens.#' 'MonthDay' 2 29+-- 60+-- @+--+-- @+-- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 28+-- 59+-- @+--+-- Note that 'monthDay' is an improper 'Iso', as the following example+-- shows. To handle this case correctly, use 'monthDayValid'.+--+-- @+-- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 29+-- 59+-- @+{-# INLINE monthDay #-}+monthDay+    :: Bool -- ^ 'isLeapYear'?+    -> Iso' DayOfYear MonthDay+monthDay leap = iso fromOrdinal toOrdinal where+    (lastDay, lengths, table, ok) = if leap+        then (365, monthLengthsLeap, monthDaysLeap, -1)+        else (364, monthLengths, monthDays, -2)++    {-# INLINE fromOrdinal #-}+    fromOrdinal :: DayOfYear -> MonthDay+    fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where+        (fromIntegral -> m, fromIntegral -> d) = VU.unsafeIndex table i++    {-# INLINE toOrdinal #-}+    toOrdinal :: MonthDay -> DayOfYear+    toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where+        m = max 1 . min 12 $ month+        l = VU.unsafeIndex lengths (pred m)+        d = max 1 . min l $ day+        k = if m <= 2 then 0 else ok++-- | Predicated on whether or not it's a leap year, convert a 'MonthDay' to+-- an ordinal 'DayOfYear'.+--+-- @+-- > 'monthDayValid' ('isLeapYear' 2016) ('MonthDay' 2 29)+-- 'Just' 60+-- @+--+-- @+-- > 'monthDayValid' ('isLeapYear' 2015) ('MonthDay' 2 29)+-- 'Nothing'+-- @+{-# INLINEABLE monthDayValid #-}+monthDayValid+    :: Bool -- ^ 'isLeapYear'?+    -> MonthDay+    -> Maybe DayOfYear+monthDayValid leap md@(MonthDay m d) = monthDay leap # md+    <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m)++-- | Predicated on whether or not the year is a leap year, return the number+-- of 'Days' in the given 'Month'.+--+-- @+-- > monthLength ('isLeapYear' 2015) 2+--   28+-- @+--+-- @+-- > monthLength ('isLeapYear' 2016) 2+--   29+-- @+{-# INLINEABLE monthLength #-}+monthLength+    :: Bool -- ^ 'isLeapYear'?+    -> Month+    -> Days+monthLength leap = VU.unsafeIndex ls . max 0 . min 11 . pred where+    ls = if leap then monthLengthsLeap else monthLengths++------------------------------------------------------------------------++-- | Week of the year.+--+-- Meaning of values depends on context; see 'wdWeek', 'swWeek', 'mwWeek'.+type WeekOfYear = Int++-- | Day of the week.+--+-- [/0/] /Sunday/ for 'SundayWeek'+--+-- [/1/…/6/] /Monday/…/Saturday/+--+-- [/7/] /Sunday/ for 'WeekDate', 'MondayWeek', and 'Data.Thyme.Calendar.WeekdayOfMonth.WeekdayOfMonth'+type DayOfWeek = Int++-- | <https://en.wikipedia.org/wiki/ISO_week_date ISO 8601 Week Date>.+--+-- Note that week /01/ is defined as the week with the first Thursday, thus+-- 'wdYear' may differ from the Gregorian year between /December 29th/ and+-- /January 3rd/.+data WeekDate = WeekDate+    { wdYear :: {-# UNPACK #-}!Year+    , wdWeek :: {-# UNPACK #-}!WeekOfYear+        -- ^ Numbered /01/ to /53/. Days before week /01/ are considered to+        -- belong to the previous year.+    , wdDay :: {-# UNPACK #-}!DayOfWeek+        -- ^ /1 = Monday/ … /7 = Sunday/.+    } deriving (INSTANCES_USUAL, Show)++LENS(WeekDate,wdYear,Year)+LENS(WeekDate,wdWeek,WeekOfYear)+LENS(WeekDate,wdDay,DayOfWeek)++instance Hashable WeekDate+instance NFData WeekDate++-- | Convert between a 'Day' and an ISO 8601 'WeekDate'.+--+-- @+-- > 'YearMonthDay' 2016 1 1 '^.' 'from' 'gregorian' '.' 'weekDate'+-- 'WeekDate' {'wdYear' = 2015, 'wdWeek' = 53, 'wdDay' = 5}+-- @+{-# INLINE weekDate #-}+weekDate :: Iso' Day WeekDate+weekDate = iso toWeek fromWeek where++    {-# INLINEABLE toWeek #-}+    toWeek :: Day -> WeekDate+    toWeek = join (toWeekOrdinal . view ordinalDate)++    {-# INLINEABLE fromWeek #-}+    fromWeek :: WeekDate -> Day+    fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd++{-# INLINE toWeekOrdinal #-}+toWeekOrdinal :: OrdinalDate -> Day -> WeekDate+toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) =+        WeekDate y1 (w1 + 1) (d7mod + 1) where+    -- pilfered and refactored; no idea what foo and bar mean+    d = mjd + 2+    (d7div, d7mod) = divMod d 7+    foo :: Year -> {-WeekOfYear-1-}Int+    foo y = bar $ ordinalDate # OrdinalDate y 6+    bar :: Day -> {-WeekOfYear-1-}Int+    bar (ModifiedJulianDay k) = d7div - div k 7+    w0 = bar $ ModifiedJulianDay (d - yd + 4)+    (y1, w1) = case w0 of+        -1 -> (y0 - 1, foo (y0 - 1))+        52 | foo (y0 + 1) == 0 -> (y0 + 1, 0)+        _ -> (y0, w0)++{-# INLINE lastWeekOfYear #-}+lastWeekOfYear :: Year -> WeekOfYear+lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where+    wd = OrdinalDate y 365 ^. from ordinalDate . weekDate++{-# INLINE fromWeekLast #-}+fromWeekLast :: WeekOfYear -> WeekDate -> Day+fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where+    -- pilfered and refactored+    ModifiedJulianDay k = ordinalDate # OrdinalDate y 6+    mjd = k - mod k 7 - 10 + clip 1 7 d + clip 1 wMax w * 7+    clip a b = max a . min b++-- | Convert a 'WeekDate' to a 'Day', or 'Nothing' for invalid 'WeekDate'.+{-# INLINEABLE weekDateValid #-}+weekDateValid :: WeekDate -> Maybe Day+weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) =+    fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax)++-- | Shows a 'Day' using the @yyyy-Www-d@ ISO 8601 Week Date format.+--+-- @+-- > 'showWeekDate' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2006 11 15)+-- "2006-W46-3"+-- @+{-# INLINEABLE showWeekDate #-}+showWeekDate :: Day -> String+showWeekDate (view weekDate -> WeekDate y w d) =+    showsYear y . (++) "-W" . shows02 w . (:) '-' $ show d++------------------------------------------------------------------------++-- | Week-based calendar date with the first /Sunday/ of the year as the first+-- day of week /01/. This corresponds to @%U@ and @%w@ of+-- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@.+--+-- The final week of a given year and week /00/ of the next both refer to+-- the same week.+data SundayWeek = SundayWeek+    { swYear :: {-# UNPACK #-}!Year+        -- ^ Coincides with that of 'gregorian'.+    , swWeek :: {-# UNPACK #-}!WeekOfYear+        -- ^ Weeks numbered from /00/ to /53/, starting with the first+        -- /Sunday/ of the year as the first day of week /01/.+    , swDay :: {-# UNPACK #-}!DayOfWeek+        -- ^ /0 = Sunday/.+    } deriving (INSTANCES_USUAL, Show)++LENS(SundayWeek,swYear,Year)+LENS(SundayWeek,swWeek,WeekOfYear)+LENS(SundayWeek,swDay,DayOfWeek)++instance Hashable SundayWeek+instance NFData SundayWeek++-- | Conversion between 'Day' and 'SundayWeek'.+--+-- @+-- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'sundayWeek'+-- 'SundayWeek' {'swYear' = 2016, 'swWeek' = 1, 'swDay' = 0}+-- @+{-# INLINE sundayWeek #-}+sundayWeek :: Iso' Day SundayWeek+sundayWeek = iso toSunday fromSunday where++    {-# INLINEABLE toSunday #-}+    toSunday :: Day -> SundayWeek+    toSunday = join (toSundayOrdinal . view ordinalDate)++    {-# INLINEABLE fromSunday #-}+    fromSunday :: SundayWeek -> Day+    fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where+        ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1+        -- following are all 0-based year days+        firstSunday = mod (4 - firstDay) 7+        yd = firstSunday + 7 * (w - 1) + d++{-# INLINE toSundayOrdinal #-}+toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek+toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) =+        SundayWeek y (d7div - div k 7) d7mod where+    d = mjd + 3+    k = d - yd+    (d7div, d7mod) = divMod d 7++-- | Convert a 'SundayWeek' to a 'Day', or 'Nothing' for invalid 'SundayWeek'.+{-# INLINEABLE sundayWeekValid #-}+sundayWeekValid :: SundayWeek -> Maybe Day+sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd)+        <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where+    ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1+    -- following are all 0-based year days+    firstSunday = mod (4 - firstDay) 7+    yd = firstSunday + 7 * (w - 1) + d+    lastDay = if isLeapYear y then 365 else 364++------------------------------------------------------------------------++-- | Week-based calendar date with the first /Monday/ of the year as the first+-- day of week /01/. This corresponds to @%W@ and @%u@ of+-- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@.+--+-- The final week of a given year and week /00/ of the next both refer to+-- the same week.+data MondayWeek = MondayWeek+    { mwYear :: {-# UNPACK #-}!Year+        -- ^ Coincides with that of 'gregorian'.+    , mwWeek :: {-# UNPACK #-}!WeekOfYear+        -- ^ Weeks numbered from /00/ to /53/, starting with the first+        -- /Monday/ of the year as the first day of week /01/.+    , mwDay :: {-# UNPACK #-}!DayOfWeek+        -- ^ /7 = Sunday/.+    } deriving (INSTANCES_USUAL, Show)++LENS(MondayWeek,mwYear,Year)+LENS(MondayWeek,mwWeek,WeekOfYear)+LENS(MondayWeek,mwDay,DayOfWeek)++instance Hashable MondayWeek+instance NFData MondayWeek++-- | Conversion between 'Day' and 'MondayWeek'.+--+-- @+-- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'mondayWeek'+-- 'MondayWeek' {'mwYear' = 2016, 'mwWeek' = 0, 'mwDay' = 7}+-- @+{-# INLINE mondayWeek #-}+mondayWeek :: Iso' Day MondayWeek+mondayWeek = iso toMonday fromMonday where++    {-# INLINEABLE toMonday #-}+    toMonday :: Day -> MondayWeek+    toMonday = join (toMondayOrdinal . view ordinalDate)++    {-# INLINEABLE fromMonday #-}+    fromMonday :: MondayWeek -> Day+    fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where+        ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1+        -- following are all 0-based year days+        firstMonday = mod (5 - firstDay) 7+        yd = firstMonday + 7 * (w - 1) + d - 1++{-# INLINE toMondayOrdinal #-}+toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek+toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) =+        MondayWeek y (d7div - div k 7) (d7mod + 1) where+    d = mjd + 2+    k = d - yd+    (d7div, d7mod) = divMod d 7++-- | Convert a 'MondayWeek' to a 'Day', or 'Nothing' for invalid 'MondayWeek'.+{-# INLINEABLE mondayWeekValid #-}+mondayWeekValid :: MondayWeek -> Maybe Day+mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd)+        <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where+    ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1+    -- following are all 0-based year days+    firstMonday = mod (5 - firstDay) 7+    yd = firstMonday + 7 * (w - 1) + d - 1+    lastDay = if isLeapYear y then 365 else 364++------------------------------------------------------------------------+-- Unbox instances at the end avoids TH-related declaration order issues++derivingUnbox "Day" [t| Day -> Int |]+    [| toModifiedJulianDay |] [| ModifiedJulianDay |]++derivingUnbox "YearMonthDay" [t| YearMonthDay -> Int |]+    [| \ YearMonthDay {..} -> shiftL ymdYear 9 .|. shiftL ymdMonth 5 .|. ymdDay |]+    [| \ n -> YearMonthDay (shiftR n 9) (shiftR n 5 .&. 0xf) (n .&. 0x1f) |]++derivingUnbox "OrdinalDate" [t| OrdinalDate -> Int |]+    [| \ OrdinalDate {..} -> shiftL odYear 9 .|. odDay |]+    [| \ n -> OrdinalDate (shiftR n 9) (n .&. 0x1ff) |]++derivingUnbox "MonthDay" [t| MonthDay -> Int |]+    [| \ MonthDay {..} -> shiftL mdMonth 5 .|. mdDay |]+    [| \ n -> MonthDay (shiftR n 5) (n .&. 0x1f) |]++derivingUnbox "WeekDate" [t| WeekDate -> Int |]+    [| \ WeekDate {..} -> shiftL wdYear 9 .|. shiftL wdWeek 3 .|. wdDay |]+    [| \ n -> WeekDate (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]++derivingUnbox "SundayWeek" [t| SundayWeek -> Int |]+    [| \ SundayWeek {..} -> shiftL swYear 9 .|. shiftL swWeek 3 .|. swDay |]+    [| \ n -> SundayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]++derivingUnbox "MondayWeek" [t| MondayWeek -> Int |]+    [| \ MondayWeek {..} -> shiftL mwYear 9 .|. shiftL mwWeek 3 .|. mwDay |]+    [| \ n -> MondayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]+

src/Data/Thyme/Calendar/MonthDay.hs view

@@ -1,63 +1,63 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-
-#include "thyme.h"
-
--- | Calendar months and day-of-months.
-module Data.Thyme.Calendar.MonthDay
-    ( Month, DayOfMonth
-    , MonthDay (..), _mdMonth, _mdDay
-    , monthDay, monthDayValid, monthLength
-    , module Data.Thyme.Calendar.MonthDay
-    ) where
-
-import Prelude
-import Control.Lens
-import Data.Thyme.Calendar.Internal
-
--- * Compatibility
-
--- | Predicated on whether or not it is a leap year, convert an ordinal
--- 'DayOfYear' to its corresponding 'Month' and 'DayOfMonth'.
---
--- @
--- 'dayOfYearToMonthAndDay' leap ('view' ('monthDay' leap) -> 'MonthDay' m d) = (m, d)
--- @
-{-# INLINE dayOfYearToMonthAndDay #-}
-dayOfYearToMonthAndDay
-    :: Bool -- ^ 'isLeapYear'?
-    -> DayOfYear
-    -> (Month, DayOfMonth)
-dayOfYearToMonthAndDay leap (view (monthDay leap) -> MonthDay m d) = (m, d)
-
--- | Predicated on whether or not it is a leap year, convert a 'Month' and
--- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'.
--- Does not validate the input.
---
--- @
--- 'monthAndDayToDayOfYear' leap m d = 'monthDay' leap 'Control.Lens.#' 'MonthDay' m d
--- @
-{-# INLINE monthAndDayToDayOfYear #-}
-monthAndDayToDayOfYear
-    :: Bool -- ^ 'isLeapYear'?
-    -> Month
-    -> DayOfMonth
-    -> DayOfYear
-monthAndDayToDayOfYear leap m d = monthDay leap # MonthDay m d
-
--- | Predicated on whether or not it is a leap year, convert a 'Month' and
--- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'.
--- Returns 'Nothing' for invalid input.
---
--- @
--- 'monthAndDayToDayOfYearValid' leap m d = 'monthDayValid' leap ('MonthDay' m d)
--- @
-{-# INLINE monthAndDayToDayOfYearValid #-}
-monthAndDayToDayOfYearValid
-    :: Bool -- ^ 'isLeapYear'?
-    -> Month
-    -> DayOfMonth
-    -> Maybe DayOfYear
-monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d)
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++#include "thyme.h"++-- | Calendar months and day-of-months.+module Data.Thyme.Calendar.MonthDay+    ( Month, DayOfMonth+    , MonthDay (..), _mdMonth, _mdDay+    , monthDay, monthDayValid, monthLength+    , module Data.Thyme.Calendar.MonthDay+    ) where++import Prelude+import Control.Lens+import Data.Thyme.Calendar.Internal++-- * Compatibility++-- | Predicated on whether or not it is a leap year, convert an ordinal+-- 'DayOfYear' to its corresponding 'Month' and 'DayOfMonth'.+--+-- @+-- 'dayOfYearToMonthAndDay' leap ('view' ('monthDay' leap) -> 'MonthDay' m d) = (m, d)+-- @+{-# INLINE dayOfYearToMonthAndDay #-}+dayOfYearToMonthAndDay+    :: Bool -- ^ 'isLeapYear'?+    -> DayOfYear+    -> (Month, DayOfMonth)+dayOfYearToMonthAndDay leap (view (monthDay leap) -> MonthDay m d) = (m, d)++-- | Predicated on whether or not it is a leap year, convert a 'Month' and+-- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'.+-- Does not validate the input.+--+-- @+-- 'monthAndDayToDayOfYear' leap m d = 'monthDay' leap 'Control.Lens.#' 'MonthDay' m d+-- @+{-# INLINE monthAndDayToDayOfYear #-}+monthAndDayToDayOfYear+    :: Bool -- ^ 'isLeapYear'?+    -> Month+    -> DayOfMonth+    -> DayOfYear+monthAndDayToDayOfYear leap m d = monthDay leap # MonthDay m d++-- | Predicated on whether or not it is a leap year, convert a 'Month' and+-- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'.+-- Returns 'Nothing' for invalid input.+--+-- @+-- 'monthAndDayToDayOfYearValid' leap m d = 'monthDayValid' leap ('MonthDay' m d)+-- @+{-# INLINE monthAndDayToDayOfYearValid #-}+monthAndDayToDayOfYearValid+    :: Bool -- ^ 'isLeapYear'?+    -> Month+    -> DayOfMonth+    -> Maybe DayOfYear+monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d)+

src/Data/Thyme/Calendar/OrdinalDate.hs view

@@ -1,170 +1,170 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | ISO 8601 Ordinal Date format
-module Data.Thyme.Calendar.OrdinalDate
-    ( Year, isLeapYear
-    , DayOfYear
-    , OrdinalDate (..), _odYear, _odDay
-    , ordinalDate
-    , module Data.Thyme.Calendar.OrdinalDate
-    ) where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.Lens
-import Control.Monad
-import Data.Thyme.Calendar
-import Data.Thyme.Calendar.Internal
-import System.Random
-import Test.QuickCheck
-
-instance Bounded OrdinalDate where
-    minBound = minBound ^. ordinalDate
-    maxBound = maxBound ^. ordinalDate
-
-instance Random OrdinalDate where
-    randomR = randomIsoR ordinalDate
-    random = first (^. ordinalDate) . random
-
-instance Arbitrary OrdinalDate where
-    arbitrary = view ordinalDate <$> arbitrary
-    shrink od = view ordinalDate <$> shrink (ordinalDate # od)
-
-instance CoArbitrary OrdinalDate where
-    coarbitrary (OrdinalDate y d) = coarbitrary y . coarbitrary d
-
--- | Convert an 'OrdinalDate' to a 'Day', or 'Nothing' for invalid input.
---
--- @
--- > 'ordinalDateValid' ('OrdinalDate' 2015 365)
--- 'Just' 2015-12-31
---
--- > 'ordinalDateValid' ('OrdinalDate' 2015 366)
--- 'Nothing'
---
--- > 'ordinalDateValid' ('OrdinalDate' 2016 366)
--- 'Just' 2016-12-31
--- @
-{-# INLINE ordinalDateValid #-}
-ordinalDateValid :: OrdinalDate -> Maybe Day
-ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od
-    <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365)
-
--- * Compatibility
-
-{-# INLINE toOrdinalDate #-}
--- | Convert a 'Day' to its Gregorian 'Year' and 'DayOfYear'.
---
--- @
--- 'toOrdinalDate' ('view' 'ordinalDate' -> 'OrdinalDate' y d) = (y, d)
--- @
-toOrdinalDate :: Day -> (Year, DayOfYear)
-toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d)
-
--- | Convert a Gregorian 'Year' and 'DayOfYear' to a 'Day'.
--- Does not validate the input.
---
--- @
--- 'fromOrdinalDate' y d = 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' y d
--- @
-{-# INLINE fromOrdinalDate #-}
-fromOrdinalDate :: Year -> DayOfYear -> Day
-fromOrdinalDate y d = ordinalDate # OrdinalDate y d
-
--- | Converts a Gregorian 'Year' and 'DayOfYear' to a 'Day'.
--- Returns 'Nothing' on invalid input.
---
--- @
--- 'fromOrdinalDateValid' y d = 'ordinalDateValid' ('OrdinalDate' y d)
--- @
-{-# INLINE fromOrdinalDateValid #-}
-fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day
-fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d)
-
--- | Converts a 'Day' to its /Sunday/-starting week date.
---
--- The first /Sunday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier
--- days in the same year are week @0@. This corresponds to @\"%U\"@ for
--- 'formatTime'.
---
--- /Sunday/ is @0 ∷ 'DayOfWeek'@, /Saturday/ is @6@. This corresponds to
--- @\"%w\"@ for 'formatTime'.
---
--- @
--- 'sundayStartWeek' ('view' 'sundayWeek' -> 'SundayWeek' y w d) = (y, w, d)
--- @
-{-# INLINE sundayStartWeek #-}
-sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)
-sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d)
-
--- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the
--- inverse of 'sundayStartWeek'.
--- Does not validate the input.
---
--- @
--- 'fromSundayStartWeek' y w d = 'sundayWeek' 'Control.Lens.#' 'SundayWeek' y w d
--- @
-{-# INLINE fromSundayStartWeek #-}
-fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day
-fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d
-
--- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the
--- inverse of 'sundayStartWeek'.
--- Returns 'Nothing' for invalid input.
---
--- @
--- 'fromSundayStartWeekValid' y w d = 'sundayWeekValid' ('SundayWeek' y w d)
--- @
-{-# INLINE fromSundayStartWeekValid #-}
-fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day
-fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d)
-
--- | Converts a 'Day' to its /Monday/-starting week date.
---
--- The first /Monday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier
--- days in the same year are week @0@. This corresponds to @\"%W\"@ for
--- 'formatTime'.
---
--- /Monday/ is @1 ∷ 'DayOfWeek'@, /Sunday/ is @7@. This corresponds to
--- @\"%u\"@ for 'formatTime'.
---
--- @
--- 'mondayStartWeek' ('view' 'mondayWeek' -> 'MondayWeek' y w d) = (y, w, d)
--- @
-{-# INLINE mondayStartWeek #-}
-mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)
-mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d)
-
--- | Converts a /Monday/-starting week date to the corresponding 'Day'; the
--- inverse of 'mondayStartWeek'.
--- Does not validate the input.
---
--- @
--- 'fromMondayStartWeek' y w d = 'mondayWeek' 'Control.Lens.#' 'MondayWeek' y w d
--- @
-{-# INLINE fromMondayStartWeek #-}
-fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day
-fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d
-
--- | Converts a /Monday/-starting week date to the corresponding 'Day'; the
--- inverse of 'mondayStartWeek'.
--- Returns 'Nothing' for invalid input.
---
--- @
--- 'fromMondayStartWeekValid' y w d = 'mondayWeekValid' ('MondayWeek' y w d)
--- @
-{-# INLINE fromMondayStartWeekValid #-}
-fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day
-fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d)
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++-- | ISO 8601 Ordinal Date format+module Data.Thyme.Calendar.OrdinalDate+    ( Year, isLeapYear+    , DayOfYear+    , OrdinalDate (..), _odYear, _odDay+    , ordinalDate+    , module Data.Thyme.Calendar.OrdinalDate+    ) where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.Lens+import Control.Monad+import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal+import System.Random+import Test.QuickCheck++instance Bounded OrdinalDate where+    minBound = minBound ^. ordinalDate+    maxBound = maxBound ^. ordinalDate++instance Random OrdinalDate where+    randomR = randomIsoR ordinalDate+    random = first (^. ordinalDate) . random++instance Arbitrary OrdinalDate where+    arbitrary = view ordinalDate <$> arbitrary+    shrink od = view ordinalDate <$> shrink (ordinalDate # od)++instance CoArbitrary OrdinalDate where+    coarbitrary (OrdinalDate y d) = coarbitrary y . coarbitrary d++-- | Convert an 'OrdinalDate' to a 'Day', or 'Nothing' for invalid input.+--+-- @+-- > 'ordinalDateValid' ('OrdinalDate' 2015 365)+-- 'Just' 2015-12-31+--+-- > 'ordinalDateValid' ('OrdinalDate' 2015 366)+-- 'Nothing'+--+-- > 'ordinalDateValid' ('OrdinalDate' 2016 366)+-- 'Just' 2016-12-31+-- @+{-# INLINE ordinalDateValid #-}+ordinalDateValid :: OrdinalDate -> Maybe Day+ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od+    <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365)++-- * Compatibility++{-# INLINE toOrdinalDate #-}+-- | Convert a 'Day' to its Gregorian 'Year' and 'DayOfYear'.+--+-- @+-- 'toOrdinalDate' ('view' 'ordinalDate' -> 'OrdinalDate' y d) = (y, d)+-- @+toOrdinalDate :: Day -> (Year, DayOfYear)+toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d)++-- | Convert a Gregorian 'Year' and 'DayOfYear' to a 'Day'.+-- Does not validate the input.+--+-- @+-- 'fromOrdinalDate' y d = 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' y d+-- @+{-# INLINE fromOrdinalDate #-}+fromOrdinalDate :: Year -> DayOfYear -> Day+fromOrdinalDate y d = ordinalDate # OrdinalDate y d++-- | Converts a Gregorian 'Year' and 'DayOfYear' to a 'Day'.+-- Returns 'Nothing' on invalid input.+--+-- @+-- 'fromOrdinalDateValid' y d = 'ordinalDateValid' ('OrdinalDate' y d)+-- @+{-# INLINE fromOrdinalDateValid #-}+fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day+fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d)++-- | Converts a 'Day' to its /Sunday/-starting week date.+--+-- The first /Sunday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier+-- days in the same year are week @0@. This corresponds to @\"%U\"@ for+-- 'formatTime'.+--+-- /Sunday/ is @0 ∷ 'DayOfWeek'@, /Saturday/ is @6@. This corresponds to+-- @\"%w\"@ for 'formatTime'.+--+-- @+-- 'sundayStartWeek' ('view' 'sundayWeek' -> 'SundayWeek' y w d) = (y, w, d)+-- @+{-# INLINE sundayStartWeek #-}+sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)+sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d)++-- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the+-- inverse of 'sundayStartWeek'.+-- Does not validate the input.+--+-- @+-- 'fromSundayStartWeek' y w d = 'sundayWeek' 'Control.Lens.#' 'SundayWeek' y w d+-- @+{-# INLINE fromSundayStartWeek #-}+fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day+fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d++-- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the+-- inverse of 'sundayStartWeek'.+-- Returns 'Nothing' for invalid input.+--+-- @+-- 'fromSundayStartWeekValid' y w d = 'sundayWeekValid' ('SundayWeek' y w d)+-- @+{-# INLINE fromSundayStartWeekValid #-}+fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day+fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d)++-- | Converts a 'Day' to its /Monday/-starting week date.+--+-- The first /Monday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier+-- days in the same year are week @0@. This corresponds to @\"%W\"@ for+-- 'formatTime'.+--+-- /Monday/ is @1 ∷ 'DayOfWeek'@, /Sunday/ is @7@. This corresponds to+-- @\"%u\"@ for 'formatTime'.+--+-- @+-- 'mondayStartWeek' ('view' 'mondayWeek' -> 'MondayWeek' y w d) = (y, w, d)+-- @+{-# INLINE mondayStartWeek #-}+mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)+mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d)++-- | Converts a /Monday/-starting week date to the corresponding 'Day'; the+-- inverse of 'mondayStartWeek'.+-- Does not validate the input.+--+-- @+-- 'fromMondayStartWeek' y w d = 'mondayWeek' 'Control.Lens.#' 'MondayWeek' y w d+-- @+{-# INLINE fromMondayStartWeek #-}+fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day+fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d++-- | Converts a /Monday/-starting week date to the corresponding 'Day'; the+-- inverse of 'mondayStartWeek'.+-- Returns 'Nothing' for invalid input.+--+-- @+-- 'fromMondayStartWeekValid' y w d = 'mondayWeekValid' ('MondayWeek' y w d)+-- @+{-# INLINE fromMondayStartWeekValid #-}+fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day+fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d)+

src/Data/Thyme/Calendar/WeekDate.hs view

@@ -1,123 +1,123 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-#if __GLASGOW_HASKELL__ == 706
-{-# OPTIONS_GHC -fsimpl-tick-factor=120 #-} -- 7.6.3 only, it seems; fixes #29
-#endif
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Various Week Date formats
-module Data.Thyme.Calendar.WeekDate
-    ( Year, WeekOfYear, DayOfWeek
-    -- * ISO 8601 Week Date
-    , WeekDate (..), _wdYear, _wdWeek, _wdDay
-    , weekDate, weekDateValid, showWeekDate
-
-    -- * Weeks starting Sunday
-    , SundayWeek (..), _swYear, _swWeek, _swDay
-    , sundayWeek, sundayWeekValid
-
-    -- * Weeks starting Monday
-    , MondayWeek (..), _mwYear, _mwWeek, _mwDay
-    , mondayWeek, mondayWeekValid
-
-    , module Data.Thyme.Calendar.WeekDate
-    ) where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.Lens
-import Data.Thyme.Calendar.OrdinalDate
-import Data.Thyme.Calendar.Internal
-import System.Random
-import Test.QuickCheck
-
-instance Bounded WeekDate where
-    minBound = minBound ^. weekDate
-    maxBound = maxBound ^. weekDate
-
-instance Bounded SundayWeek where
-    minBound = minBound ^. sundayWeek
-    maxBound = maxBound ^. sundayWeek
-
-instance Bounded MondayWeek where
-    minBound = minBound ^. mondayWeek
-    maxBound = maxBound ^. mondayWeek
-
-instance Random WeekDate where
-    randomR = randomIsoR weekDate
-    random = first (^. weekDate) . random
-
-instance Random SundayWeek where
-    randomR = randomIsoR sundayWeek
-    random = first (^. sundayWeek) . random
-
-instance Random MondayWeek where
-    randomR = randomIsoR mondayWeek
-    random = first (^. mondayWeek) . random
-
-instance Arbitrary WeekDate where
-    arbitrary = view weekDate <$> arbitrary
-    shrink wd = view weekDate <$> shrink (weekDate # wd)
-
-instance Arbitrary SundayWeek where
-    arbitrary = view sundayWeek <$> arbitrary
-    shrink sw = view sundayWeek <$> shrink (sundayWeek # sw)
-
-instance Arbitrary MondayWeek where
-    arbitrary = view mondayWeek <$> arbitrary
-    shrink mw = view mondayWeek <$> shrink (mondayWeek # mw)
-
-instance CoArbitrary WeekDate where
-    coarbitrary (WeekDate y w d)
-        = coarbitrary y . coarbitrary w . coarbitrary d
-
-instance CoArbitrary SundayWeek where
-    coarbitrary (SundayWeek y w d)
-        = coarbitrary y . coarbitrary w . coarbitrary d
-
-instance CoArbitrary MondayWeek where
-    coarbitrary (MondayWeek y w d)
-        = coarbitrary y . coarbitrary w . coarbitrary d
-
--- * Compatibility
-
--- | Converts a 'Day' to an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>.
---
--- @
--- 'toWeekDate' ('view' 'weekDate' -> 'WeekDate' y w d) = (y, w, d)
--- @
-{-# INLINE toWeekDate #-}
-toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek)
-toWeekDate (view weekDate -> WeekDate y w d) = (y, w, d)
-
--- | Converts an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>
--- to a 'Day'.
--- Does not validate the input.
---
--- @
--- 'fromWeekDate' y w d = 'weekDate' 'Control.Lens.#' 'WeekDate' y w d
--- @
-{-# INLINE fromWeekDate #-}
-fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day
-fromWeekDate y w d = weekDate # WeekDate y w d
-
--- | Converts an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>
--- to a 'Day'.
--- Returns 'Nothing' for invalid input.
---
--- @
--- 'fromWeekDateValid' y w d = 'weekDateValid' ('WeekDate' y w d)
--- @
-{-# INLINE fromWeekDateValid #-}
-fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day
-fromWeekDateValid y w d = weekDateValid (WeekDate y w d)
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ == 706+{-# OPTIONS_GHC -fsimpl-tick-factor=120 #-} -- 7.6.3 only, it seems; fixes #29+#endif++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++-- | Various Week Date formats+module Data.Thyme.Calendar.WeekDate+    ( Year, WeekOfYear, DayOfWeek+    -- * ISO 8601 Week Date+    , WeekDate (..), _wdYear, _wdWeek, _wdDay+    , weekDate, weekDateValid, showWeekDate++    -- * Weeks starting Sunday+    , SundayWeek (..), _swYear, _swWeek, _swDay+    , sundayWeek, sundayWeekValid++    -- * Weeks starting Monday+    , MondayWeek (..), _mwYear, _mwWeek, _mwDay+    , mondayWeek, mondayWeekValid++    , module Data.Thyme.Calendar.WeekDate+    ) where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.Lens+import Data.Thyme.Calendar.OrdinalDate+import Data.Thyme.Calendar.Internal+import System.Random+import Test.QuickCheck++instance Bounded WeekDate where+    minBound = minBound ^. weekDate+    maxBound = maxBound ^. weekDate++instance Bounded SundayWeek where+    minBound = minBound ^. sundayWeek+    maxBound = maxBound ^. sundayWeek++instance Bounded MondayWeek where+    minBound = minBound ^. mondayWeek+    maxBound = maxBound ^. mondayWeek++instance Random WeekDate where+    randomR = randomIsoR weekDate+    random = first (^. weekDate) . random++instance Random SundayWeek where+    randomR = randomIsoR sundayWeek+    random = first (^. sundayWeek) . random++instance Random MondayWeek where+    randomR = randomIsoR mondayWeek+    random = first (^. mondayWeek) . random++instance Arbitrary WeekDate where+    arbitrary = view weekDate <$> arbitrary+    shrink wd = view weekDate <$> shrink (weekDate # wd)++instance Arbitrary SundayWeek where+    arbitrary = view sundayWeek <$> arbitrary+    shrink sw = view sundayWeek <$> shrink (sundayWeek # sw)++instance Arbitrary MondayWeek where+    arbitrary = view mondayWeek <$> arbitrary+    shrink mw = view mondayWeek <$> shrink (mondayWeek # mw)++instance CoArbitrary WeekDate where+    coarbitrary (WeekDate y w d)+        = coarbitrary y . coarbitrary w . coarbitrary d++instance CoArbitrary SundayWeek where+    coarbitrary (SundayWeek y w d)+        = coarbitrary y . coarbitrary w . coarbitrary d++instance CoArbitrary MondayWeek where+    coarbitrary (MondayWeek y w d)+        = coarbitrary y . coarbitrary w . coarbitrary d++-- * Compatibility++-- | Converts a 'Day' to an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>.+--+-- @+-- 'toWeekDate' ('view' 'weekDate' -> 'WeekDate' y w d) = (y, w, d)+-- @+{-# INLINE toWeekDate #-}+toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek)+toWeekDate (view weekDate -> WeekDate y w d) = (y, w, d)++-- | Converts an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>+-- to a 'Day'.+-- Does not validate the input.+--+-- @+-- 'fromWeekDate' y w d = 'weekDate' 'Control.Lens.#' 'WeekDate' y w d+-- @+{-# INLINE fromWeekDate #-}+fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day+fromWeekDate y w d = weekDate # WeekDate y w d++-- | Converts an <https://en.wikipedia.org/wiki/ISO_week_date ISO week date>+-- to a 'Day'.+-- Returns 'Nothing' for invalid input.+--+-- @+-- 'fromWeekDateValid' y w d = 'weekDateValid' ('WeekDate' y w d)+-- @+{-# INLINE fromWeekDateValid #-}+fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day+fromWeekDateValid y w d = weekDateValid (WeekDate y w d)+

src/Data/Thyme/Calendar/WeekdayOfMonth.hs view

@@ -1,148 +1,148 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Calendar date reckoned by year, month-of-year, and n-th day-of-week.
-module Data.Thyme.Calendar.WeekdayOfMonth
-    ( Year, Month, DayOfWeek
-    , module Data.Thyme.Calendar.WeekdayOfMonth
-    ) where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.DeepSeq
-import Control.Lens
-import Control.Monad
-import Data.AffineSpace
-import Data.Bits
-import Data.Data
-import Data.Hashable
-import Data.Thyme.Calendar
-import Data.Thyme.Calendar.Internal
-#if __GLASGOW_HASKELL__ == 704
-import qualified Data.Vector.Generic
-import qualified Data.Vector.Generic.Mutable
-#endif
-import Data.Vector.Unboxed.Deriving
-import GHC.Generics (Generic)
-import System.Random
-import Test.QuickCheck hiding ((.&.))
-
--- | Calendar date with year, month-of-year, and n-th day-of-week.
-data WeekdayOfMonth = WeekdayOfMonth
-    { womYear :: {-# UNPACK #-}!Year
-        -- ^ Calendar year.
-    , womMonth :: {-# UNPACK #-}!Month
-        -- ^ Month of year.
-    , womNth :: {-# UNPACK #-}!Int
-        -- ^ /N/-th 'DayOfWeek'. Range /±1–5/; negative means the /N/-th
-        -- last 'DayOfWeek' of the month.
-    , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek
-        -- ^ Day of week. /1 = Monday, 7 = Sunday/, like ISO 8601 'WeekDate'.
-    } deriving (INSTANCES_USUAL, Show)
-
-LENS(WeekdayOfMonth,womYear,Year)
-LENS(WeekdayOfMonth,womMonth,Month)
-LENS(WeekdayOfMonth,womNth,Int)
-LENS(WeekdayOfMonth,womDayOfWeek,DayOfWeek)
-
-derivingUnbox "WeekdayOfMonth"
-    [t| WeekdayOfMonth -> Int |]
-    [| \ WeekdayOfMonth {..} -> shiftL womYear 11 .|. shiftL womMonth 7
-        .|. shiftL (womNth + 5) 3 .|. womDayOfWeek |]
-    [| \ n -> WeekdayOfMonth (shiftR n 11) (shiftR n 7 .&. 0xf)
-        (shiftR n 3 - 5) (n .&. 0x7) |]
-
-instance Hashable WeekdayOfMonth
-instance NFData WeekdayOfMonth
-
-instance Bounded WeekdayOfMonth where
-    minBound = minBound ^. weekdayOfMonth
-    maxBound = maxBound ^. weekdayOfMonth
-
-instance Random WeekdayOfMonth where
-    randomR = randomIsoR weekdayOfMonth
-    random = first (^. weekdayOfMonth) . random
-
-instance Arbitrary WeekdayOfMonth where
-    arbitrary = view weekdayOfMonth <$> arbitrary
-    shrink wom = view weekdayOfMonth <$> shrink (weekdayOfMonth # wom)
-
-instance CoArbitrary WeekdayOfMonth where
-    coarbitrary (WeekdayOfMonth y m n d)
-        = coarbitrary y . coarbitrary m
-        . coarbitrary n . coarbitrary d
-
--- | Conversion between a 'Day' and and 'WeekdayOfMonth'.
---
--- This is a proper 'Iso' if and only if all of the 'WeekdayOfMonth' fields
--- are valid and positive.
---
--- For example, the last /Monday/ in /January 2016/ is also the fourth
--- /Monday/:
---
--- @
--- > 'weekdayOfMonth' 'Control.Lens.#' 'WeekdayOfMonth' 2016 1 (-1) 1
--- 2016-01-25
--- > 'YearMonthDay' 2016 01 25 '^.' 'from' 'gregorian' '.' 'weekdayOfMonth'
--- 'WeekdayOfMonth' {'womYear' = 2016, 'womMonth' = 1, 'womNth' = 4, 'womDayOfWeek' = 1}
--- @
-{-# INLINE weekdayOfMonth #-}
-weekdayOfMonth :: Iso' Day WeekdayOfMonth
-weekdayOfMonth = iso toWeekday fromWeekday where
-
-    {-# INLINEABLE toWeekday #-}
-    toWeekday :: Day -> WeekdayOfMonth
-    toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where
-        YearMonthDay y m d = ord ^. yearMonthDay
-        WeekDate _ _ wd = toWeekOrdinal ord day
-        n = 1 + div (d - 1) 7
-
-    {-# INLINEABLE fromWeekday #-}
-    fromWeekday :: WeekdayOfMonth -> Day
-    fromWeekday (WeekdayOfMonth y m n wd) = refDay .+^ s * offset where
-        refOrd = yearMonthDay # YearMonthDay y m
-            (if n < 0 then monthLength (isLeapYear y) m else 1)
-        refDay = ordinalDate # refOrd
-        WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay
-        s = signum n
-        wo = s * (wd - wd1)
-        offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo
-
--- | Convert a 'WeekdayOfMonth' to a 'Day'.
--- Returns 'Nothing' for invalid input.
---
--- For example, the third /Sunday/ of /January 2016/ is /2016-01-27/, but
--- there is no fifth /Monday/ in /January 2016/.
---
--- @
--- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 3 7)
--- 'Just' 2016-01-17
--- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 5 1)
--- 'Nothing'
--- @
-{-# INLINEABLE weekdayOfMonthValid #-}
-weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day
-weekdayOfMonthValid (WeekdayOfMonth y m n wd) = (refDay .+^ s * offset)
-        <$ guard (n /= 0 && 1 <= wd && wd <= 7 && offset < len) where
-    len = monthLength (isLeapYear y) m
-    refOrd = yearMonthDay # YearMonthDay y m (if n < 0 then len else 1)
-    refDay = ordinalDate # refOrd
-    WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay
-    s = signum n
-    wo = s * (wd - wd1)
-    offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++-- | Calendar date reckoned by year, month-of-year, and n-th day-of-week.+module Data.Thyme.Calendar.WeekdayOfMonth+    ( Year, Month, DayOfWeek+    , module Data.Thyme.Calendar.WeekdayOfMonth+    ) where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.AffineSpace+import Data.Bits+import Data.Data+import Data.Hashable+import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal+#if __GLASGOW_HASKELL__ == 704+import qualified Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable+#endif+import Data.Vector.Unboxed.Deriving+import GHC.Generics (Generic)+import System.Random+import Test.QuickCheck hiding ((.&.))++-- | Calendar date with year, month-of-year, and n-th day-of-week.+data WeekdayOfMonth = WeekdayOfMonth+    { womYear :: {-# UNPACK #-}!Year+        -- ^ Calendar year.+    , womMonth :: {-# UNPACK #-}!Month+        -- ^ Month of year.+    , womNth :: {-# UNPACK #-}!Int+        -- ^ /N/-th 'DayOfWeek'. Range /±1–5/; negative means the /N/-th+        -- last 'DayOfWeek' of the month.+    , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek+        -- ^ Day of week. /1 = Monday, 7 = Sunday/, like ISO 8601 'WeekDate'.+    } deriving (INSTANCES_USUAL, Show)++LENS(WeekdayOfMonth,womYear,Year)+LENS(WeekdayOfMonth,womMonth,Month)+LENS(WeekdayOfMonth,womNth,Int)+LENS(WeekdayOfMonth,womDayOfWeek,DayOfWeek)++derivingUnbox "WeekdayOfMonth"+    [t| WeekdayOfMonth -> Int |]+    [| \ WeekdayOfMonth {..} -> shiftL womYear 11 .|. shiftL womMonth 7+        .|. shiftL (womNth + 5) 3 .|. womDayOfWeek |]+    [| \ n -> WeekdayOfMonth (shiftR n 11) (shiftR n 7 .&. 0xf)+        (shiftR n 3 - 5) (n .&. 0x7) |]++instance Hashable WeekdayOfMonth+instance NFData WeekdayOfMonth++instance Bounded WeekdayOfMonth where+    minBound = minBound ^. weekdayOfMonth+    maxBound = maxBound ^. weekdayOfMonth++instance Random WeekdayOfMonth where+    randomR = randomIsoR weekdayOfMonth+    random = first (^. weekdayOfMonth) . random++instance Arbitrary WeekdayOfMonth where+    arbitrary = view weekdayOfMonth <$> arbitrary+    shrink wom = view weekdayOfMonth <$> shrink (weekdayOfMonth # wom)++instance CoArbitrary WeekdayOfMonth where+    coarbitrary (WeekdayOfMonth y m n d)+        = coarbitrary y . coarbitrary m+        . coarbitrary n . coarbitrary d++-- | Conversion between a 'Day' and and 'WeekdayOfMonth'.+--+-- This is a proper 'Iso' if and only if all of the 'WeekdayOfMonth' fields+-- are valid and positive.+--+-- For example, the last /Monday/ in /January 2016/ is also the fourth+-- /Monday/:+--+-- @+-- > 'weekdayOfMonth' 'Control.Lens.#' 'WeekdayOfMonth' 2016 1 (-1) 1+-- 2016-01-25+-- > 'YearMonthDay' 2016 01 25 '^.' 'from' 'gregorian' '.' 'weekdayOfMonth'+-- 'WeekdayOfMonth' {'womYear' = 2016, 'womMonth' = 1, 'womNth' = 4, 'womDayOfWeek' = 1}+-- @+{-# INLINE weekdayOfMonth #-}+weekdayOfMonth :: Iso' Day WeekdayOfMonth+weekdayOfMonth = iso toWeekday fromWeekday where++    {-# INLINEABLE toWeekday #-}+    toWeekday :: Day -> WeekdayOfMonth+    toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where+        YearMonthDay y m d = ord ^. yearMonthDay+        WeekDate _ _ wd = toWeekOrdinal ord day+        n = 1 + div (d - 1) 7++    {-# INLINEABLE fromWeekday #-}+    fromWeekday :: WeekdayOfMonth -> Day+    fromWeekday (WeekdayOfMonth y m n wd) = refDay .+^ s * offset where+        refOrd = yearMonthDay # YearMonthDay y m+            (if n < 0 then monthLength (isLeapYear y) m else 1)+        refDay = ordinalDate # refOrd+        WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay+        s = signum n+        wo = s * (wd - wd1)+        offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo++-- | Convert a 'WeekdayOfMonth' to a 'Day'.+-- Returns 'Nothing' for invalid input.+--+-- For example, the third /Sunday/ of /January 2016/ is /2016-01-27/, but+-- there is no fifth /Monday/ in /January 2016/.+--+-- @+-- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 3 7)+-- 'Just' 2016-01-17+-- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 5 1)+-- 'Nothing'+-- @+{-# INLINEABLE weekdayOfMonthValid #-}+weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day+weekdayOfMonthValid (WeekdayOfMonth y m n wd) = (refDay .+^ s * offset)+        <$ guard (n /= 0 && 1 <= wd && wd <= 7 && offset < len) where+    len = monthLength (isLeapYear y) m+    refOrd = yearMonthDay # YearMonthDay y m (if n < 0 then len else 1)+    refDay = ordinalDate # refOrd+    WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay+    s = signum n+    wo = s * (wd - wd1)+    offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo+

src/Data/Thyme/Clock.hs view

@@ -1,203 +1,203 @@-{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ >= 708
-{-# LANGUAGE PatternSynonyms #-}
-#endif
-
-{-| Types and functions for
-<http://en.wikipedia.org/wiki/Coordinated_Universal_Time UTC> and
-<http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>.
-
-If you don't care about leap seconds, keep to 'UTCTime' and
-'NominalDiffTime' for your clock calculations, and you'll be fine.
-
-"Data.Thyme.Time" provides 'Num', 'Real', 'Fractional' and 'RealFrac'
-instances for 'DiffTime' and 'NominalDiffTime', but their use is
-discouraged. See "Data.Thyme.Docs#spaces" for details.
-
-Use 'fromSeconds' and 'toSeconds' to convert between 'DiffTime'
-/ 'NominalDiffTime' and other numeric types; use 'fromSeconds'' for
-literals to avoid type defaulting warnings.
-
--}
-
-module Data.Thyme.Clock (
-    -- * UTC
-      UTCTime
-    , utctDay, utctDayTime
-    , _utctDay, _utctDayTime
-#if __GLASGOW_HASKELL__ >= 708
-    , pattern UTCTime
-#endif
-    , mkUTCTime
-    , utcTime
-
-    , UTCView (..), _utcvDay, _utcvDayTime
-    , NominalDiffTime
-
-    , getCurrentTime
-
-    -- * Absolute intervals
-    , DiffTime
-
-    -- * Time interval conversion
-    , TimeDiff (..)
-    , toSeconds, fromSeconds
-    , toSeconds', fromSeconds'
-    , picoseconds
-
-    -- * Universal Time
-    , UniversalTime
-#if __GLASGOW_HASKELL__ >= 708
-    , pattern UniversalTime
-#endif
-    , modJulianDate
-
-    -- * Compatibility
-    , getModJulianDate
-    , mkModJulianDate
-    , secondsToDiffTime
-    , picosecondsToDiffTime
-    , unUTCTime
-    , addUTCTime
-    , diffUTCTime
-    , toMicroseconds
-    , fromMicroseconds
-    ) where
-
-import Prelude
-import Control.Lens
-import Data.AffineSpace
-import Data.Int
-import Data.Ratio ((%))
-import Data.Thyme.Clock.Internal
-import Data.Thyme.Clock.POSIX
-
--- | Get the current UTC date and time from the local system clock.
---
--- @
--- > 'Data.Thyme.Clock.getCurrentTime'
--- 2016-01-15 13:42:02.287688 UTC
--- @
---
--- See also: 'Data.Thyme.LocalTime.getZonedTime', 'getPOSIXTime'.
-getCurrentTime :: IO UTCTime
-getCurrentTime = fmap (review posixTime) getPOSIXTime
-
--- | Conversion between 'TimeDiff' and picoseconds. In the reverse
--- direction, picoseconds are 'round'ed to the nearest microsecond.
-{-# INLINE picoseconds #-}
-picoseconds :: (TimeDiff t) => Iso' t Integer
-picoseconds = microseconds . iso
-    ((*) 1000000 . toInteger) (\ ps -> round (ps % 1000000))
-
-------------------------------------------------------------------------
-
--- | Convert a 'UniversalTime' to the fractional number of days since the
--- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.
---
--- @
--- 'getModJulianDate' = 'view' 'modJulianDate'
--- @
-{-# INLINE getModJulianDate #-}
-getModJulianDate :: UniversalTime -> Rational
-getModJulianDate = view modJulianDate
-
--- | Construct a 'UniversalTime' from the fractional number of days since the
--- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.
---
--- @
--- 'mkModJulianDate' = 'review' 'modJulianDate'
--- @
-{-# INLINE mkModJulianDate #-}
-mkModJulianDate :: Rational -> UniversalTime
-mkModJulianDate = review modJulianDate
-
--- | Construct a 'DiffTime' from some number of seconds.
---
--- This is just 'fromSeconds' with a more constrained type.
---
--- @
--- 'secondsToDiffTime' = 'fromSeconds'
--- @
-{-# INLINE secondsToDiffTime #-}
-secondsToDiffTime :: Int64 -> DiffTime
-secondsToDiffTime = fromSeconds
-
--- | Construct a 'DiffTime' from some number of picoseconds.
--- The input will be rounded to the nearest microsecond.
---
--- @
--- 'picosecondsToDiffTime' a = 'microseconds' 'Control.Lens.#' 'quot' (a '+' 'signum' a '*' 500000) 1000000
--- @
-{-# INLINE picosecondsToDiffTime #-}
-picosecondsToDiffTime :: Integer -> DiffTime
-picosecondsToDiffTime = review picoseconds
-
--- | Decompose a 'UTCTime' into a 'UTCView'.
---
--- @
--- 'unUTCTime' = 'view' 'utcTime'
--- @
---
--- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g.
---
--- @
--- f :: 'UTCTime' -> ('Day', 'DiffTime')
--- f ('unUTCTime' -> 'UTCView' day dt) = (day, dt)
--- @
---
--- For GHC 7.8 or later, there is also the pattern synonym
--- @<Data-Thyme-Clock.html#v:UTCTime UTCTime>@.
-{-# INLINE unUTCTime #-}
-unUTCTime :: UTCTime -> UTCView
-unUTCTime = view utcTime
-
--- | Add a duration to a point in time.
---
--- @
--- 'addUTCTime' = 'flip' ('.+^')
--- 'addUTCTime' d t ≡ t '.+^' d
--- @
---
--- See also the 'AffineSpace' instance for 'UTCTime'.
-{-# INLINE addUTCTime #-}
-addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime
-addUTCTime = flip (.+^)
-
--- | The duration difference between two time points.
---
--- @
--- 'diffUTCTime' = ('.-.')
--- 'diffUTCTime' a b = a '.-.' b
--- @
---
--- See also the 'AffineSpace' instance for 'UTCTime'.
-{-# INLINE diffUTCTime #-}
-diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime
-diffUTCTime = (.-.)
-
--- | The number of microseconds in a 'DiffTime' or 'NominalDiffTime'.
---
--- @
--- 'toMicroseconds' :: 'DiffTime' -> 'Int64'
--- 'toMicroseconds' :: 'NominalDiffTime' -> 'Int64'
--- 'toMicroseconds' = 'view' 'microseconds'
--- 'toMicroseconds' d ≡ d '^.' 'microseconds'
--- @
-{-# INLINE toMicroseconds #-}
-toMicroseconds :: (TimeDiff t) => t -> Int64
-toMicroseconds = view microseconds
-
--- | Construct a 'DiffTime' or 'NominalDiffTime' from a number of
--- microseconds.
---
--- @
--- 'fromMicroseconds' :: 'Int64' -> 'DiffTime'
--- 'fromMicroseconds' :: 'Int64' -> 'NominalDiffTime'
--- 'fromMicroseconds' = 'review' 'microseconds'
--- 'fromMicroseconds' n ≡ 'microseconds' 'Control.Lens.#' n
--- @
-{-# INLINE fromMicroseconds #-}
-fromMicroseconds :: (TimeDiff t) => Int64 -> t
-fromMicroseconds = review microseconds
-
+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE PatternSynonyms #-}+#endif++{-| Types and functions for+<http://en.wikipedia.org/wiki/Coordinated_Universal_Time UTC> and+<http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>.++If you don't care about leap seconds, keep to 'UTCTime' and+'NominalDiffTime' for your clock calculations, and you'll be fine.++"Data.Thyme.Time" provides 'Num', 'Real', 'Fractional' and 'RealFrac'+instances for 'DiffTime' and 'NominalDiffTime', but their use is+discouraged. See "Data.Thyme.Docs#spaces" for details.++Use 'fromSeconds' and 'toSeconds' to convert between 'DiffTime'+/ 'NominalDiffTime' and other numeric types; use 'fromSeconds'' for+literals to avoid type defaulting warnings.++-}++module Data.Thyme.Clock (+    -- * UTC+      UTCTime+    , utctDay, utctDayTime+    , _utctDay, _utctDayTime+#if __GLASGOW_HASKELL__ >= 708+    , pattern UTCTime+#endif+    , mkUTCTime+    , utcTime++    , UTCView (..), _utcvDay, _utcvDayTime+    , NominalDiffTime++    , getCurrentTime++    -- * Absolute intervals+    , DiffTime++    -- * Time interval conversion+    , TimeDiff (..)+    , toSeconds, fromSeconds+    , toSeconds', fromSeconds'+    , picoseconds++    -- * Universal Time+    , UniversalTime+#if __GLASGOW_HASKELL__ >= 708+    , pattern UniversalTime+#endif+    , modJulianDate++    -- * Compatibility+    , getModJulianDate+    , mkModJulianDate+    , secondsToDiffTime+    , picosecondsToDiffTime+    , unUTCTime+    , addUTCTime+    , diffUTCTime+    , toMicroseconds+    , fromMicroseconds+    ) where++import Prelude+import Control.Lens+import Data.AffineSpace+import Data.Int+import Data.Ratio ((%))+import Data.Thyme.Clock.Internal+import Data.Thyme.Clock.POSIX++-- | Get the current UTC date and time from the local system clock.+--+-- @+-- > 'Data.Thyme.Clock.getCurrentTime'+-- 2016-01-15 13:42:02.287688 UTC+-- @+--+-- See also: 'Data.Thyme.LocalTime.getZonedTime', 'getPOSIXTime'.+getCurrentTime :: IO UTCTime+getCurrentTime = fmap (review posixTime) getPOSIXTime++-- | Conversion between 'TimeDiff' and picoseconds. In the reverse+-- direction, picoseconds are 'round'ed to the nearest microsecond.+{-# INLINE picoseconds #-}+picoseconds :: (TimeDiff t) => Iso' t Integer+picoseconds = microseconds . iso+    ((*) 1000000 . toInteger) (\ ps -> round (ps % 1000000))++------------------------------------------------------------------------++-- | Convert a 'UniversalTime' to the fractional number of days since the+-- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.+--+-- @+-- 'getModJulianDate' = 'view' 'modJulianDate'+-- @+{-# INLINE getModJulianDate #-}+getModJulianDate :: UniversalTime -> Rational+getModJulianDate = view modJulianDate++-- | Construct a 'UniversalTime' from the fractional number of days since the+-- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.+--+-- @+-- 'mkModJulianDate' = 'review' 'modJulianDate'+-- @+{-# INLINE mkModJulianDate #-}+mkModJulianDate :: Rational -> UniversalTime+mkModJulianDate = review modJulianDate++-- | Construct a 'DiffTime' from some number of seconds.+--+-- This is just 'fromSeconds' with a more constrained type.+--+-- @+-- 'secondsToDiffTime' = 'fromSeconds'+-- @+{-# INLINE secondsToDiffTime #-}+secondsToDiffTime :: Int64 -> DiffTime+secondsToDiffTime = fromSeconds++-- | Construct a 'DiffTime' from some number of picoseconds.+-- The input will be rounded to the nearest microsecond.+--+-- @+-- 'picosecondsToDiffTime' a = 'microseconds' 'Control.Lens.#' 'quot' (a '+' 'signum' a '*' 500000) 1000000+-- @+{-# INLINE picosecondsToDiffTime #-}+picosecondsToDiffTime :: Integer -> DiffTime+picosecondsToDiffTime = review picoseconds++-- | Decompose a 'UTCTime' into a 'UTCView'.+--+-- @+-- 'unUTCTime' = 'view' 'utcTime'+-- @+--+-- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g.+--+-- @+-- f :: 'UTCTime' -> ('Day', 'DiffTime')+-- f ('unUTCTime' -> 'UTCView' day dt) = (day, dt)+-- @+--+-- For GHC 7.8 or later, there is also the pattern synonym+-- @<Data-Thyme-Clock.html#v:UTCTime UTCTime>@.+{-# INLINE unUTCTime #-}+unUTCTime :: UTCTime -> UTCView+unUTCTime = view utcTime++-- | Add a duration to a point in time.+--+-- @+-- 'addUTCTime' = 'flip' ('.+^')+-- 'addUTCTime' d t ≡ t '.+^' d+-- @+--+-- See also the 'AffineSpace' instance for 'UTCTime'.+{-# INLINE addUTCTime #-}+addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime+addUTCTime = flip (.+^)++-- | The duration difference between two time points.+--+-- @+-- 'diffUTCTime' = ('.-.')+-- 'diffUTCTime' a b = a '.-.' b+-- @+--+-- See also the 'AffineSpace' instance for 'UTCTime'.+{-# INLINE diffUTCTime #-}+diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime+diffUTCTime = (.-.)++-- | The number of microseconds in a 'DiffTime' or 'NominalDiffTime'.+--+-- @+-- 'toMicroseconds' :: 'DiffTime' -> 'Int64'+-- 'toMicroseconds' :: 'NominalDiffTime' -> 'Int64'+-- 'toMicroseconds' = 'view' 'microseconds'+-- 'toMicroseconds' d ≡ d '^.' 'microseconds'+-- @+{-# INLINE toMicroseconds #-}+toMicroseconds :: (TimeDiff t) => t -> Int64+toMicroseconds = view microseconds++-- | Construct a 'DiffTime' or 'NominalDiffTime' from a number of+-- microseconds.+--+-- @+-- 'fromMicroseconds' :: 'Int64' -> 'DiffTime'+-- 'fromMicroseconds' :: 'Int64' -> 'NominalDiffTime'+-- 'fromMicroseconds' = 'review' 'microseconds'+-- 'fromMicroseconds' n ≡ 'microseconds' 'Control.Lens.#' n+-- @+{-# INLINE fromMicroseconds #-}+fromMicroseconds :: (TimeDiff t) => Int64 -> t+fromMicroseconds = review microseconds+

src/Data/Thyme/Clock/Internal.hs view

@@ -1,434 +1,434 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-} -- workaround
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-#if __GLASGOW_HASKELL__ >= 708
-{-# LANGUAGE PatternSynonyms #-}
-#endif
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-#include "thyme.h"
-
-module Data.Thyme.Clock.Internal where
-
-import Prelude
-import Control.DeepSeq
-import Control.Lens
-import Data.AdditiveGroup
-import Data.AffineSpace
-import Data.Basis
-import Data.Data
-import Data.Hashable
-import Data.Int
-import Data.Ix
-import Data.Thyme.Internal.Micro
-import Data.Thyme.Calendar.Internal
-#if __GLASGOW_HASKELL__ == 704
-import qualified Data.Vector.Generic
-import qualified Data.Vector.Generic.Mutable
-#endif
-import Data.Vector.Unboxed.Deriving
-import Data.VectorSpace
-import GHC.Generics (Generic)
-import System.Random
-import Test.QuickCheck
-
-#if !SHOW_INTERNAL
-import Control.Monad
-import Text.ParserCombinators.ReadPrec (lift)
-import Text.ParserCombinators.ReadP (char)
-import Text.Read (readPrec)
-#endif
-
--- | Hour time-of-day.
-type Hour = Int
--- | Minute time-of-day.
-type Minute = Int
-
--- | Time intervals, encompassing both 'DiffTime' and 'NominalDiffTime'.
---
--- ==== Notes
---
--- Still affected by <http://hackage.haskell.org/trac/ghc/ticket/7611>?
-class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where
-    -- | Conversion between 'TimeDiff' and 'Int64' microseconds.
-    --
-    -- @
-    -- > ('fromSeconds'' 3 :: 'DiffTime') '^.' 'microseconds'
-    -- 3000000
-    --
-    -- > 'microseconds' 'Control.Lens.#' 4000000 :: 'DiffTime'
-    -- 4s
-    -- @
-    microseconds :: Iso' t Int64
-
--- | Convert a time interval to some 'Fractional' type.
-{-# INLINE toSeconds #-}
-toSeconds :: (TimeDiff t, Fractional n) => t -> n
-toSeconds = (* recip 1000000) . fromIntegral . view microseconds
-
--- | Make a time interval from some 'Real' type.
---
--- Try to make sure @n@ is one of 'Float', 'Double', 'Int', 'Int64' or
--- 'Integer', for which rewrite @RULES@ have been provided.
-{-# INLINE[0] fromSeconds #-}
-fromSeconds :: (Real n, TimeDiff t) => n -> t
-fromSeconds = fromSeconds' . toRational
-
--- | Type-restricted 'toSeconds' to avoid constraint-defaulting warnings.
-{-# INLINE toSeconds' #-}
-toSeconds' :: (TimeDiff t) => t -> Rational
-toSeconds' = (`decompose'` ())
-
--- | Type-restricted 'fromSeconds' to avoid constraint-defaulting warnings.
-{-# INLINE fromSeconds' #-}
-fromSeconds' :: (TimeDiff t) => Rational -> t
-fromSeconds' = (*^ basisValue ())
-
-------------------------------------------------------------------------
--- not for public consumption
-
-{-# INLINE fromSecondsRealFrac #-}
-fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t
-fromSecondsRealFrac _ = review microseconds . round . (*) 1000000
-
-{-# INLINE fromSecondsIntegral #-}
-fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t
-fromSecondsIntegral _ = review microseconds . (*) 1000000 . fromIntegral
-
-{-# RULES
-
-"fromSeconds/Float"    [~0] fromSeconds = fromSecondsRealFrac (0 :: Float)
-"fromSeconds/Double"   [~0] fromSeconds = fromSecondsRealFrac (0 :: Double)
-"fromSeconds/Int"      [~0] fromSeconds = fromSecondsIntegral (0 :: Int)
-"fromSeconds/Int64"    [~0] fromSeconds = fromSecondsIntegral (0 :: Int64)
-"fromSeconds/Integer"  [~0] fromSeconds = fromSecondsIntegral (0 :: Integer)
-
-  #-}
-
-------------------------------------------------------------------------
-
--- | An interval or duration of time, as would be measured by a stopwatch.
---
--- 'DiffTime' is an instance of 'AdditiveGroup' as well as 'VectorSpace',
--- with 'Rational' as its 'Scalar'.
--- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances
--- here. See "Data.Thyme.Docs#spaces" for details.
---
--- @
--- > 'fromSeconds'' 100 :: 'DiffTime'
--- 100s
--- > 'fromSeconds'' 100 '^+^' 'fromSeconds'' 100 '^*' 4
--- 500s
--- > 'fromSeconds'' 100 '^-^' 'fromSeconds'' 100 '^/' 4
--- 75s
--- @
-newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)
-
-derivingUnbox "DiffTime" [t| DiffTime -> Micro |]
-    [| \ (DiffTime a) -> a |] [| DiffTime |]
-
-#if SHOW_INTERNAL
-deriving instance Show DiffTime
-deriving instance Read DiffTime
-#else
-instance Show DiffTime where
-    {-# INLINEABLE showsPrec #-}
-    showsPrec p (DiffTime a) = showsPrec p a . (:) 's'
-instance Read DiffTime where
-    {-# INLINEABLE readPrec #-}
-    readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's')
-#endif
-
-instance VectorSpace DiffTime where
-    type Scalar DiffTime = Rational
-    {-# INLINE (*^) #-}
-    (*^) = \ s (DiffTime t) -> DiffTime (s *^ t)
-
-instance HasBasis DiffTime where
-    type Basis DiffTime = ()
-    {-# INLINE basisValue #-}
-    basisValue = \ _ -> DiffTime (basisValue ())
-    {-# INLINE decompose #-}
-    decompose = \ (DiffTime a) -> decompose a
-    {-# INLINE decompose' #-}
-    decompose' = \ (DiffTime a) -> decompose' a
-
-instance TimeDiff DiffTime where
-    {-# INLINE microseconds #-}
-    microseconds = iso (\ (DiffTime (Micro u)) -> u) (DiffTime . Micro)
-
-------------------------------------------------------------------------
-
--- | The nominal interval between two 'UTCTime's, which does not take leap
--- seconds into account.
---
--- For example, the difference between /23:59:59/ and /00:00:01/ on the
--- following day is always 2 seconds of 'NominalDiffTime', regardless of
--- whether a leap-second took place.
---
--- 'NominalDiffTime' is an instance of 'AdditiveGroup' as well as
--- 'VectorSpace', with 'Rational' as its 'Scalar'.
--- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances
--- here. See "Data.Thyme.Docs#spaces" for details.
---
--- @
--- > let d = 'fromSeconds'' 2 :: 'NominalDiffTime'
--- > d
--- 2s
--- > d '^/' 3
--- 0.666667s
--- @
---
--- See also: 'UTCTime'.
-newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)
-
-derivingUnbox "NominalDiffTime" [t| NominalDiffTime -> Micro |]
-    [| \ (NominalDiffTime a) -> a |] [| NominalDiffTime |]
-
-#if SHOW_INTERNAL
-deriving instance Show NominalDiffTime
-deriving instance Read NominalDiffTime
-#else
-instance Show NominalDiffTime where
-    {-# INLINEABLE showsPrec #-}
-    showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)
-instance Read NominalDiffTime where
-    {-# INLINEABLE readPrec #-}
-    readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's')
-#endif
-
-instance VectorSpace NominalDiffTime where
-    type Scalar NominalDiffTime = Rational
-    {-# INLINE (*^) #-}
-    (*^) = \ s (NominalDiffTime t) -> NominalDiffTime (s *^ t)
-
-instance HasBasis NominalDiffTime where
-    type Basis NominalDiffTime = ()
-    {-# INLINE basisValue #-}
-    basisValue = \ _ -> NominalDiffTime (basisValue ())
-    {-# INLINE decompose #-}
-    decompose = \ (NominalDiffTime a) -> decompose a
-    {-# INLINE decompose' #-}
-    decompose' = \ (NominalDiffTime a) -> decompose' a
-
-instance TimeDiff NominalDiffTime where
-    {-# INLINE microseconds #-}
-    microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro)
-
--- | The nominal length of a POSIX day: /86400 SI seconds/.
-{-# INLINE posixDayLength #-}
-posixDayLength :: NominalDiffTime
-posixDayLength = microseconds # 86400000000
-
-------------------------------------------------------------------------
-
--- | The principal form of universal time, namely
--- <http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>.
---
--- UT1 is defined by the rotation of the Earth around its axis relative to
--- the Sun. The length of each UT1 day varies and is never exactly 86400 SI
--- seconds, unlike UTC or TAI.
---
--- The difference between UT1 and UTC is
--- <http://en.wikipedia.org/wiki/DUT1 DUT1>.
-newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO)
-
-derivingUnbox "UniversalTime" [t| UniversalTime -> NominalDiffTime |]
-    [| \ (UniversalRep a) -> a |] [| UniversalRep |]
-
--- | Convert between 'UniversalTime' and the fractional number of days since the
--- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.
-{-# INLINE modJulianDate #-}
-modJulianDate :: Iso' UniversalTime Rational
-modJulianDate = iso
-    (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength)
-    (UniversalRep . (*^ posixDayLength))
-
-#if __GLASGOW_HASKELL__ >= 710
-pattern UniversalTime :: Rational -> UniversalTime
-pattern UniversalTime mjd <- (view modJulianDate -> mjd) where
-    UniversalTime mjd = modJulianDate # mjd
-#elif __GLASGOW_HASKELL__ >= 708
-pattern UniversalTime mjd <- (view modJulianDate -> mjd)
-#endif
-
-------------------------------------------------------------------------
-
--- | <https://en.wikipedia.org/wiki/Coordinated_Universal_Time Coördinated universal time>
--- ('UTCTime') is the most commonly used standard for civil timekeeping. It
--- is synchronised with
--- <https://en.wikipedia.org/wiki/International_Atomic_Time TAI>
--- ('Data.Thyme.Clock.AbsoluteTime') and both tick in increments of SI
--- seconds, but UTC includes occasional leap-seconds to keep it close to
--- <https://en.wikipedia.org/wiki/Universal_Time#Versions UT1>
--- ('UniversalTime').
---
--- @
--- > 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78)
--- 2016-01-15 12:34:56.78 UTC
---
--- > 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78)
--- 2016-01-15 12:34:56.78 UTC
---
--- > 'mkUTCTime' 2016 1 15  12 34 56.78
--- 2016-01-15 12:34:56.78 UTC
--- @
---
--- 'UTCTime' is an 'AffineSpace' with 'NominalDiffTime' as its 'Diff'. See
--- "Data.Thyme.Docs#spaces" for details.
---
--- @
--- > let t0 = 'mkUTCTime' 2016 1 15  23 59 0
--- > let t1 = 'mkUTCTime' 2016 1 16  00  1 1
--- > let dt = t1 '.-.' t0
--- > dt
--- 121s :: 'NominalDiffTime'
---
--- > t1 '.+^' dt
--- 2016-01-16 00:03:02 UTC
---
--- > t1 '.+^' 3 '*^' dt
--- 2016-01-16 00:07:04 UTC
--- @
---
--- To decompose a 'UTCTime' into a separate 'Day' and time-of-day, use
--- 'utcTime'. To convert to a local time zone, see
--- 'Data.Thyme.LocalTime.zonedTime' or 'Data.Thyme.LocalTime.utcLocalTime'.
---
--- ==== Notes
---
--- Internally 'UTCTime' is just a 64-bit count of 'microseconds' since the
--- Modified Julian Day epoch, so @('.+^')@, @('.-.')@ et cetera ought to be
--- fast.
---
--- 'UTCTime' <https://github.com/liyang/thyme/issues/3 cannot represent leap seconds>.
--- If leap seconds matter, use 'Data.Thyme.Clock.TAI.AbsoluteTime' from
--- "Data.Thyme.Clock.TAI" instead, along with
--- 'Data.Thyme.Clock.TAI.absoluteTime'' and 'UTCView' for presentation.
-newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO)
-
-derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |]
-    [| \ (UTCRep a) -> a |] [| UTCRep |]
-
--- | Unpacked 'UTCTime', partly for compatibility with @time@.
---
--- As of GHC 7.10, you can also use the 'UTCTime' pattern synonym.
-data UTCView = UTCView
-    { utcvDay :: {-# UNPACK #-}!Day
-    -- ^ Calendar date.
-    , utcvDayTime :: {-# UNPACK #-}!DiffTime
-    -- ^ Time elapsed since midnight; /0/ ≤ 'utcvDayTime' < /86401s/.
-    } deriving (INSTANCES_USUAL, Show)
-
--- | 'Lens'' for the calendar 'Day' component of a 'UTCView'.
-LENS(UTCView,utcvDay,Day)
-
--- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCView'.
-LENS(UTCView,utcvDayTime,DiffTime)
-
-derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |]
-    [| \ UTCView {..} -> (utcvDay, utcvDayTime) |]
-    [| \ (utcvDay, utcvDayTime) -> UTCView {..} |]
-
-instance Hashable UTCView
-instance NFData UTCView
-
--- | 'Lens'' for the calendar 'Day' component of a 'UTCTime'.
-_utctDay :: Lens' UTCTime Day
-_utctDay = utcTime . lens utcvDay
-    (\ UTCView {..} d -> UTCView d utcvDayTime)
-
--- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCTime'.
-_utctDayTime :: Lens' UTCTime DiffTime
-_utctDayTime = utcTime . lens utcvDayTime
-    (\ UTCView {..} t -> UTCView utcvDay t)
-
--- | Accessor for the calendar 'Day' component of an 'UTCTime'.
---
--- @
--- 'utctDay' = 'view' '_utctDay'
--- @
-utctDay :: UTCTime -> Day
-utctDay = view _utctDay
-
--- | Accessor for the time-of-day 'DiffTime' component of an 'UTCTime'.
---
--- @
--- 'utctDayTime' = 'view' '_utctDayTime'
--- @
-utctDayTime :: UTCTime -> DiffTime
-utctDayTime = view _utctDayTime
-
-instance AffineSpace UTCTime where
-    type Diff UTCTime = NominalDiffTime
-    {-# INLINE (.-.) #-}
-    (.-.) = \ (UTCRep a) (UTCRep b) -> a ^-^ b
-    {-# INLINE (.+^) #-}
-    (.+^) = \ (UTCRep a) d -> UTCRep (a ^+^ d)
-
--- | View 'UTCTime' as an 'UTCView', comprising a 'Day' along with
--- a 'DiffTime' offset since midnight.
---
--- This is an improper lens: 'utcvDayTime' outside the range of
--- @['zeroV', 'posixDayLength')@ will carry over into 'utcvDay', with the
--- expected behaviour.
---
--- @
--- > 'view' 'utcTime' '<$>' 'Data.Thyme.Clock.getCurrentTime'
--- 'UTCView' {'utcvDay' = 2016-01-15, 'utcvDayTime' = 49322.287688s}
---
--- > 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78)
--- 2016-01-15 12:34:56.78 UTC
--- @
---
--- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g.
---
--- @
--- f :: 'UTCTime' -> ('Day', 'DiffTime')
--- f ('view' 'utcTime' -> 'UTCView' day dt) = (day, dt)
--- @
-{-# INLINE utcTime #-}
-utcTime :: Iso' UTCTime UTCView
-utcTime = iso toView fromView where
-    NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength
-
-    {-# INLINE toView #-}
-    toView :: UTCTime -> UTCView
-    toView (UTCRep (NominalDiffTime a)) = UTCView
-            (ModifiedJulianDay mjd) (DiffTime dt) where
-        (fromIntegral -> mjd, dt) = microDivMod a posixDay
-
-    {-# INLINE fromView #-}
-    fromView :: UTCView -> UTCTime
-    fromView (UTCView (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where
-        a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt)
-
-#if __GLASGOW_HASKELL__ >= 710
-pattern UTCTime :: Day -> DiffTime -> UTCTime
-pattern UTCTime d t <- (view utcTime -> UTCView d t) where
-    UTCTime d t = utcTime # UTCView d t
-#elif __GLASGOW_HASKELL__ >= 708
-pattern UTCTime d t <- (view utcTime -> UTCView d t)
-#endif
-
--- | Construct a 'UTCTime' from a 'gregorian' date and time-of-day.
---
--- @
--- 'mkUTCTime' yy mm dd h m s ≡ 'utcTime' 'Control.Lens.#' 'UTCView'
---     ('gregorian' 'Control.Lens.#' 'YearMonthDay' yy mm dd)
---     ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' h m ('fromSeconds' s))
--- @
-{-# INLINE mkUTCTime #-}
-mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime
-mkUTCTime yy mm dd h m s = utcTime # UTCView
-    (gregorian # YearMonthDay yy mm dd)
-    (fromSeconds (3600 * h + 60 * m) ^+^ fromSeconds s)
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} -- workaround+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE PatternSynonyms #-}+#endif+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}++#include "thyme.h"++module Data.Thyme.Clock.Internal where++import Prelude+import Control.DeepSeq+import Control.Lens+import Data.AdditiveGroup+import Data.AffineSpace+import Data.Basis+import Data.Data+import Data.Hashable+import Data.Int+import Data.Ix+import Data.Thyme.Internal.Micro+import Data.Thyme.Calendar.Internal+#if __GLASGOW_HASKELL__ == 704+import qualified Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable+#endif+import Data.Vector.Unboxed.Deriving+import Data.VectorSpace+import GHC.Generics (Generic)+import System.Random+import Test.QuickCheck++#if !SHOW_INTERNAL+import Control.Monad+import Text.ParserCombinators.ReadPrec (lift)+import Text.ParserCombinators.ReadP (char)+import Text.Read (readPrec)+#endif++-- | Hour time-of-day.+type Hour = Int+-- | Minute time-of-day.+type Minute = Int++-- | Time intervals, encompassing both 'DiffTime' and 'NominalDiffTime'.+--+-- ==== Notes+--+-- Still affected by <http://hackage.haskell.org/trac/ghc/ticket/7611>?+class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where+    -- | Conversion between 'TimeDiff' and 'Int64' microseconds.+    --+    -- @+    -- > ('fromSeconds'' 3 :: 'DiffTime') '^.' 'microseconds'+    -- 3000000+    --+    -- > 'microseconds' 'Control.Lens.#' 4000000 :: 'DiffTime'+    -- 4s+    -- @+    microseconds :: Iso' t Int64++-- | Convert a time interval to some 'Fractional' type.+{-# INLINE toSeconds #-}+toSeconds :: (TimeDiff t, Fractional n) => t -> n+toSeconds = (* recip 1000000) . fromIntegral . view microseconds++-- | Make a time interval from some 'Real' type.+--+-- Try to make sure @n@ is one of 'Float', 'Double', 'Int', 'Int64' or+-- 'Integer', for which rewrite @RULES@ have been provided.+{-# INLINE[0] fromSeconds #-}+fromSeconds :: (Real n, TimeDiff t) => n -> t+fromSeconds = fromSeconds' . toRational++-- | Type-restricted 'toSeconds' to avoid constraint-defaulting warnings.+{-# INLINE toSeconds' #-}+toSeconds' :: (TimeDiff t) => t -> Rational+toSeconds' = (`decompose'` ())++-- | Type-restricted 'fromSeconds' to avoid constraint-defaulting warnings.+{-# INLINE fromSeconds' #-}+fromSeconds' :: (TimeDiff t) => Rational -> t+fromSeconds' = (*^ basisValue ())++------------------------------------------------------------------------+-- not for public consumption++{-# INLINE fromSecondsRealFrac #-}+fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t+fromSecondsRealFrac _ = review microseconds . round . (*) 1000000++{-# INLINE fromSecondsIntegral #-}+fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t+fromSecondsIntegral _ = review microseconds . (*) 1000000 . fromIntegral++{-# RULES++"fromSeconds/Float"    [~0] fromSeconds = fromSecondsRealFrac (0 :: Float)+"fromSeconds/Double"   [~0] fromSeconds = fromSecondsRealFrac (0 :: Double)+"fromSeconds/Int"      [~0] fromSeconds = fromSecondsIntegral (0 :: Int)+"fromSeconds/Int64"    [~0] fromSeconds = fromSecondsIntegral (0 :: Int64)+"fromSeconds/Integer"  [~0] fromSeconds = fromSecondsIntegral (0 :: Integer)++  #-}++------------------------------------------------------------------------++-- | An interval or duration of time, as would be measured by a stopwatch.+--+-- 'DiffTime' is an instance of 'AdditiveGroup' as well as 'VectorSpace',+-- with 'Rational' as its 'Scalar'.+-- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances+-- here. See "Data.Thyme.Docs#spaces" for details.+--+-- @+-- > 'fromSeconds'' 100 :: 'DiffTime'+-- 100s+-- > 'fromSeconds'' 100 '^+^' 'fromSeconds'' 100 '^*' 4+-- 500s+-- > 'fromSeconds'' 100 '^-^' 'fromSeconds'' 100 '^/' 4+-- 75s+-- @+newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)++derivingUnbox "DiffTime" [t| DiffTime -> Micro |]+    [| \ (DiffTime a) -> a |] [| DiffTime |]++#if SHOW_INTERNAL+deriving instance Show DiffTime+deriving instance Read DiffTime+#else+instance Show DiffTime where+    {-# INLINEABLE showsPrec #-}+    showsPrec p (DiffTime a) = showsPrec p a . (:) 's'+instance Read DiffTime where+    {-# INLINEABLE readPrec #-}+    readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's')+#endif++instance VectorSpace DiffTime where+    type Scalar DiffTime = Rational+    {-# INLINE (*^) #-}+    (*^) = \ s (DiffTime t) -> DiffTime (s *^ t)++instance HasBasis DiffTime where+    type Basis DiffTime = ()+    {-# INLINE basisValue #-}+    basisValue = \ _ -> DiffTime (basisValue ())+    {-# INLINE decompose #-}+    decompose = \ (DiffTime a) -> decompose a+    {-# INLINE decompose' #-}+    decompose' = \ (DiffTime a) -> decompose' a++instance TimeDiff DiffTime where+    {-# INLINE microseconds #-}+    microseconds = iso (\ (DiffTime (Micro u)) -> u) (DiffTime . Micro)++------------------------------------------------------------------------++-- | The nominal interval between two 'UTCTime's, which does not take leap+-- seconds into account.+--+-- For example, the difference between /23:59:59/ and /00:00:01/ on the+-- following day is always 2 seconds of 'NominalDiffTime', regardless of+-- whether a leap-second took place.+--+-- 'NominalDiffTime' is an instance of 'AdditiveGroup' as well as+-- 'VectorSpace', with 'Rational' as its 'Scalar'.+-- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances+-- here. See "Data.Thyme.Docs#spaces" for details.+--+-- @+-- > let d = 'fromSeconds'' 2 :: 'NominalDiffTime'+-- > d+-- 2s+-- > d '^/' 3+-- 0.666667s+-- @+--+-- See also: 'UTCTime'.+newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)++derivingUnbox "NominalDiffTime" [t| NominalDiffTime -> Micro |]+    [| \ (NominalDiffTime a) -> a |] [| NominalDiffTime |]++#if SHOW_INTERNAL+deriving instance Show NominalDiffTime+deriving instance Read NominalDiffTime+#else+instance Show NominalDiffTime where+    {-# INLINEABLE showsPrec #-}+    showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)+instance Read NominalDiffTime where+    {-# INLINEABLE readPrec #-}+    readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's')+#endif++instance VectorSpace NominalDiffTime where+    type Scalar NominalDiffTime = Rational+    {-# INLINE (*^) #-}+    (*^) = \ s (NominalDiffTime t) -> NominalDiffTime (s *^ t)++instance HasBasis NominalDiffTime where+    type Basis NominalDiffTime = ()+    {-# INLINE basisValue #-}+    basisValue = \ _ -> NominalDiffTime (basisValue ())+    {-# INLINE decompose #-}+    decompose = \ (NominalDiffTime a) -> decompose a+    {-# INLINE decompose' #-}+    decompose' = \ (NominalDiffTime a) -> decompose' a++instance TimeDiff NominalDiffTime where+    {-# INLINE microseconds #-}+    microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro)++-- | The nominal length of a POSIX day: /86400 SI seconds/.+{-# INLINE posixDayLength #-}+posixDayLength :: NominalDiffTime+posixDayLength = microseconds # 86400000000++------------------------------------------------------------------------++-- | The principal form of universal time, namely+-- <http://en.wikipedia.org/wiki/Universal_Time#Versions UT1>.+--+-- UT1 is defined by the rotation of the Earth around its axis relative to+-- the Sun. The length of each UT1 day varies and is never exactly 86400 SI+-- seconds, unlike UTC or TAI.+--+-- The difference between UT1 and UTC is+-- <http://en.wikipedia.org/wiki/DUT1 DUT1>.+newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO)++derivingUnbox "UniversalTime" [t| UniversalTime -> NominalDiffTime |]+    [| \ (UniversalRep a) -> a |] [| UniversalRep |]++-- | Convert between 'UniversalTime' and the fractional number of days since the+-- <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Date epoch>.+{-# INLINE modJulianDate #-}+modJulianDate :: Iso' UniversalTime Rational+modJulianDate = iso+    (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength)+    (UniversalRep . (*^ posixDayLength))++#if __GLASGOW_HASKELL__ >= 710+pattern UniversalTime :: Rational -> UniversalTime+pattern UniversalTime mjd <- (view modJulianDate -> mjd) where+    UniversalTime mjd = modJulianDate # mjd+#elif __GLASGOW_HASKELL__ >= 708+pattern UniversalTime mjd <- (view modJulianDate -> mjd)+#endif++------------------------------------------------------------------------++-- | <https://en.wikipedia.org/wiki/Coordinated_Universal_Time Coördinated universal time>+-- ('UTCTime') is the most commonly used standard for civil timekeeping. It+-- is synchronised with+-- <https://en.wikipedia.org/wiki/International_Atomic_Time TAI>+-- ('Data.Thyme.Clock.AbsoluteTime') and both tick in increments of SI+-- seconds, but UTC includes occasional leap-seconds to keep it close to+-- <https://en.wikipedia.org/wiki/Universal_Time#Versions UT1>+-- ('UniversalTime').+--+-- @+-- > 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78)+-- 2016-01-15 12:34:56.78 UTC+--+-- > 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78)+-- 2016-01-15 12:34:56.78 UTC+--+-- > 'mkUTCTime' 2016 1 15  12 34 56.78+-- 2016-01-15 12:34:56.78 UTC+-- @+--+-- 'UTCTime' is an 'AffineSpace' with 'NominalDiffTime' as its 'Diff'. See+-- "Data.Thyme.Docs#spaces" for details.+--+-- @+-- > let t0 = 'mkUTCTime' 2016 1 15  23 59 0+-- > let t1 = 'mkUTCTime' 2016 1 16  00  1 1+-- > let dt = t1 '.-.' t0+-- > dt+-- 121s :: 'NominalDiffTime'+--+-- > t1 '.+^' dt+-- 2016-01-16 00:03:02 UTC+--+-- > t1 '.+^' 3 '*^' dt+-- 2016-01-16 00:07:04 UTC+-- @+--+-- To decompose a 'UTCTime' into a separate 'Day' and time-of-day, use+-- 'utcTime'. To convert to a local time zone, see+-- 'Data.Thyme.LocalTime.zonedTime' or 'Data.Thyme.LocalTime.utcLocalTime'.+--+-- ==== Notes+--+-- Internally 'UTCTime' is just a 64-bit count of 'microseconds' since the+-- Modified Julian Day epoch, so @('.+^')@, @('.-.')@ et cetera ought to be+-- fast.+--+-- 'UTCTime' <https://github.com/liyang/thyme/issues/3 cannot represent leap seconds>.+-- If leap seconds matter, use 'Data.Thyme.Clock.TAI.AbsoluteTime' from+-- "Data.Thyme.Clock.TAI" instead, along with+-- 'Data.Thyme.Clock.TAI.absoluteTime'' and 'UTCView' for presentation.+newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO)++derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |]+    [| \ (UTCRep a) -> a |] [| UTCRep |]++-- | Unpacked 'UTCTime', partly for compatibility with @time@.+--+-- As of GHC 7.10, you can also use the 'UTCTime' pattern synonym.+data UTCView = UTCView+    { utcvDay :: {-# UNPACK #-}!Day+    -- ^ Calendar date.+    , utcvDayTime :: {-# UNPACK #-}!DiffTime+    -- ^ Time elapsed since midnight; /0/ ≤ 'utcvDayTime' < /86401s/.+    } deriving (INSTANCES_USUAL, Show)++-- | 'Lens'' for the calendar 'Day' component of a 'UTCView'.+LENS(UTCView,utcvDay,Day)++-- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCView'.+LENS(UTCView,utcvDayTime,DiffTime)++derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |]+    [| \ UTCView {..} -> (utcvDay, utcvDayTime) |]+    [| \ (utcvDay, utcvDayTime) -> UTCView {..} |]++instance Hashable UTCView+instance NFData UTCView++-- | 'Lens'' for the calendar 'Day' component of a 'UTCTime'.+_utctDay :: Lens' UTCTime Day+_utctDay = utcTime . lens utcvDay+    (\ UTCView {..} d -> UTCView d utcvDayTime)++-- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCTime'.+_utctDayTime :: Lens' UTCTime DiffTime+_utctDayTime = utcTime . lens utcvDayTime+    (\ UTCView {..} t -> UTCView utcvDay t)++-- | Accessor for the calendar 'Day' component of an 'UTCTime'.+--+-- @+-- 'utctDay' = 'view' '_utctDay'+-- @+utctDay :: UTCTime -> Day+utctDay = view _utctDay++-- | Accessor for the time-of-day 'DiffTime' component of an 'UTCTime'.+--+-- @+-- 'utctDayTime' = 'view' '_utctDayTime'+-- @+utctDayTime :: UTCTime -> DiffTime+utctDayTime = view _utctDayTime++instance AffineSpace UTCTime where+    type Diff UTCTime = NominalDiffTime+    {-# INLINE (.-.) #-}+    (.-.) = \ (UTCRep a) (UTCRep b) -> a ^-^ b+    {-# INLINE (.+^) #-}+    (.+^) = \ (UTCRep a) d -> UTCRep (a ^+^ d)++-- | View 'UTCTime' as an 'UTCView', comprising a 'Day' along with+-- a 'DiffTime' offset since midnight.+--+-- This is an improper lens: 'utcvDayTime' outside the range of+-- @['zeroV', 'posixDayLength')@ will carry over into 'utcvDay', with the+-- expected behaviour.+--+-- @+-- > 'view' 'utcTime' '<$>' 'Data.Thyme.Clock.getCurrentTime'+-- 'UTCView' {'utcvDay' = 2016-01-15, 'utcvDayTime' = 49322.287688s}+--+-- > 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78)+-- 2016-01-15 12:34:56.78 UTC+-- @+--+-- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g.+--+-- @+-- f :: 'UTCTime' -> ('Day', 'DiffTime')+-- f ('view' 'utcTime' -> 'UTCView' day dt) = (day, dt)+-- @+{-# INLINE utcTime #-}+utcTime :: Iso' UTCTime UTCView+utcTime = iso toView fromView where+    NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength++    {-# INLINE toView #-}+    toView :: UTCTime -> UTCView+    toView (UTCRep (NominalDiffTime a)) = UTCView+            (ModifiedJulianDay mjd) (DiffTime dt) where+        (fromIntegral -> mjd, dt) = microDivMod a posixDay++    {-# INLINE fromView #-}+    fromView :: UTCView -> UTCTime+    fromView (UTCView (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where+        a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt)++#if __GLASGOW_HASKELL__ >= 710+pattern UTCTime :: Day -> DiffTime -> UTCTime+pattern UTCTime d t <- (view utcTime -> UTCView d t) where+    UTCTime d t = utcTime # UTCView d t+#elif __GLASGOW_HASKELL__ >= 708+pattern UTCTime d t <- (view utcTime -> UTCView d t)+#endif++-- | Construct a 'UTCTime' from a 'gregorian' date and time-of-day.+--+-- @+-- 'mkUTCTime' yy mm dd h m s ≡ 'utcTime' 'Control.Lens.#' 'UTCView'+--     ('gregorian' 'Control.Lens.#' 'YearMonthDay' yy mm dd)+--     ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' h m ('fromSeconds' s))+-- @+{-# INLINE mkUTCTime #-}+mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime+mkUTCTime yy mm dd h m s = utcTime # UTCView+    (gregorian # YearMonthDay yy mm dd)+    (fromSeconds (3600 * h + 60 * m) ^+^ fromSeconds s)+

src/Data/Thyme/Clock/POSIX.hsc view

@@ -1,108 +1,108 @@-{-# LANGUAGE ForeignFunctionInterface #-}
-
-#ifndef mingw32_HOST_OS
-#include <sys/time.h>
-#endif
-
--- | <https://en.wikipedia.org/wiki/Unix_time POSIX time>
-module Data.Thyme.Clock.POSIX
-    ( posixDayLength
-    , POSIXTime
-    , posixTime
-    , getPOSIXTime
-
-    -- * Compatibility
-    , posixSecondsToUTCTime
-    , utcTimeToPOSIXSeconds
-    ) where
-
-import Prelude
-import Control.Lens
-import Data.AdditiveGroup
-import Data.Thyme.Internal.Micro
-import Data.Thyme.Clock.Internal
-
-#ifdef mingw32_HOST_OS
-import System.Win32.Time
-#else
-import Foreign.C.Error (throwErrnoIfMinus1_)
-import Foreign.C.Types
-import Foreign.Marshal.Alloc (allocaBytes)
-import Foreign.Ptr (Ptr, nullPtr)
-import Foreign.Storable
-#endif
-
--- | The nominal (ignoring leap seconds) time difference since midnight
--- 1970-01-01, the Unix epoch. Equvialent to a normalised
--- @<http://www.gnu.org/software/libc/manual/html_node/Elapsed-Time.html struct timeval>@.
-type POSIXTime = NominalDiffTime
-
--- | "Control.Lens.Iso" between 'UTCTime' and 'POSIXTime'.
---
--- @
--- > 'getPOSIXTime'
--- 1459515013.527711s
--- > 'review' 'posixTime' '<$>' 'getPOSIXTime'
--- 2016-01-01 12:50:45.588729 UTC
--- @
-{-# INLINE posixTime #-}
-posixTime :: Iso' UTCTime POSIXTime
-posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch)
-        (UTCRep . (^+^) unixEpoch) where
-    unixEpoch = review microseconds $
-        {-ModifiedJulianDay-}40587 * {-posixDayLength-}86400000000
-
--- | Return the current system POSIX time via
--- @<http://www.gnu.org/software/libc/manual/html_node/High_002dResolution-Calendar.html gettimeofday>@,
--- or @getSystemTimeAsFileTime@ on Windows.
--- 
--- See also 'Data.Thyme.Clock.getCurrentTime', 'Data.Thyme.LocalTime.getZonedTime'.
-{-# INLINE getPOSIXTime #-}
-getPOSIXTime :: IO POSIXTime
-#ifdef mingw32_HOST_OS
-
--- On Windows, the equlvalent of POSIX time is ‘file time’, defined as
--- the number of 100-nanosecond intervals that have elapsed since
--- 12:00 AM January 1, 1601 (UTC). We can convert this into a POSIX
--- time by adjusting the offset to be relative to the POSIX epoch.
-getPOSIXTime = do
-    FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime
-    return . NominalDiffTime . Micro . fromIntegral $
-        quot ft 10 - 11644473600000000{-ftEpoch ^. microseconds-}
---  ftEpoch = utcTime # UTCTime (gregorian # YearMonthDay 1601 1 1) zeroV
-
-#else
-
-getPOSIXTime = allocaBytes #{size struct timeval} $ \ ptv -> do
-    throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptv nullPtr
-    CTime sec <- #{peek struct timeval, tv_sec} ptv
-    CSUSeconds usec <- #{peek struct timeval, tv_usec} ptv
-    return . NominalDiffTime . Micro $
-        1000000 * fromIntegral sec + fromIntegral usec
-
-foreign import ccall unsafe "time.h gettimeofday"
-    gettimeofday :: Ptr () -> Ptr () -> IO CInt
-
-#endif
-
-------------------------------------------------------------------------
-
--- | Construct a 'UTCTime' from a 'POSIXTime'.
---
--- @
--- 'posixSecondsToUTCTime' = 'review' 'posixTime'
--- 'posixSecondsToUTCTime' t ≡ 'posixTime' 'Control.Lens.#' t
--- @
-{-# INLINE posixSecondsToUTCTime #-}
-posixSecondsToUTCTime :: POSIXTime -> UTCTime
-posixSecondsToUTCTime = review posixTime
-
--- | Convert a 'UTCTime' to a 'POSIXTime'.
---
--- @
--- 'utcTimeToPOSIXSeconds' = 'view' 'posixTime'
--- @
-{-# INLINE utcTimeToPOSIXSeconds #-}
-utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime
-utcTimeToPOSIXSeconds = view posixTime
-
+{-# LANGUAGE ForeignFunctionInterface #-}++#ifndef mingw32_HOST_OS+#include <sys/time.h>+#endif++-- | <https://en.wikipedia.org/wiki/Unix_time POSIX time>+module Data.Thyme.Clock.POSIX+    ( posixDayLength+    , POSIXTime+    , posixTime+    , getPOSIXTime++    -- * Compatibility+    , posixSecondsToUTCTime+    , utcTimeToPOSIXSeconds+    ) where++import Prelude+import Control.Lens+import Data.AdditiveGroup+import Data.Thyme.Internal.Micro+import Data.Thyme.Clock.Internal++#ifdef mingw32_HOST_OS+import System.Win32.Time+#else+import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable+#endif++-- | The nominal (ignoring leap seconds) time difference since midnight+-- 1970-01-01, the Unix epoch. Equvialent to a normalised+-- @<http://www.gnu.org/software/libc/manual/html_node/Elapsed-Time.html struct timeval>@.+type POSIXTime = NominalDiffTime++-- | "Control.Lens.Iso" between 'UTCTime' and 'POSIXTime'.+--+-- @+-- > 'getPOSIXTime'+-- 1459515013.527711s+-- > 'review' 'posixTime' '<$>' 'getPOSIXTime'+-- 2016-01-01 12:50:45.588729 UTC+-- @+{-# INLINE posixTime #-}+posixTime :: Iso' UTCTime POSIXTime+posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch)+        (UTCRep . (^+^) unixEpoch) where+    unixEpoch = review microseconds $+        {-ModifiedJulianDay-}40587 * {-posixDayLength-}86400000000++-- | Return the current system POSIX time via+-- @<http://www.gnu.org/software/libc/manual/html_node/High_002dResolution-Calendar.html gettimeofday>@,+-- or @getSystemTimeAsFileTime@ on Windows.+-- +-- See also 'Data.Thyme.Clock.getCurrentTime', 'Data.Thyme.LocalTime.getZonedTime'.+{-# INLINE getPOSIXTime #-}+getPOSIXTime :: IO POSIXTime+#ifdef mingw32_HOST_OS++-- On Windows, the equlvalent of POSIX time is ‘file time’, defined as+-- the number of 100-nanosecond intervals that have elapsed since+-- 12:00 AM January 1, 1601 (UTC). We can convert this into a POSIX+-- time by adjusting the offset to be relative to the POSIX epoch.+getPOSIXTime = do+    FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime+    return . NominalDiffTime . Micro . fromIntegral $+        quot ft 10 - 11644473600000000{-ftEpoch ^. microseconds-}+--  ftEpoch = utcTime # UTCTime (gregorian # YearMonthDay 1601 1 1) zeroV++#else++getPOSIXTime = allocaBytes #{size struct timeval} $ \ ptv -> do+    throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptv nullPtr+    CTime sec <- #{peek struct timeval, tv_sec} ptv+    CSUSeconds usec <- #{peek struct timeval, tv_usec} ptv+    return . NominalDiffTime . Micro $+        1000000 * fromIntegral sec + fromIntegral usec++foreign import ccall unsafe "time.h gettimeofday"+    gettimeofday :: Ptr () -> Ptr () -> IO CInt++#endif++------------------------------------------------------------------------++-- | Construct a 'UTCTime' from a 'POSIXTime'.+--+-- @+-- 'posixSecondsToUTCTime' = 'review' 'posixTime'+-- 'posixSecondsToUTCTime' t ≡ 'posixTime' 'Control.Lens.#' t+-- @+{-# INLINE posixSecondsToUTCTime #-}+posixSecondsToUTCTime :: POSIXTime -> UTCTime+posixSecondsToUTCTime = review posixTime++-- | Convert a 'UTCTime' to a 'POSIXTime'.+--+-- @+-- 'utcTimeToPOSIXSeconds' = 'view' 'posixTime'+-- @+{-# INLINE utcTimeToPOSIXSeconds #-}+utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime+utcTimeToPOSIXSeconds = view posixTime+

src/Data/Thyme/Clock/TAI.hs view

@@ -1,357 +1,357 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
-#define TAIUTCDAT @<http://maia.usno.navy.mil/ser7/tai-utc.dat tai-utc.dat>@
-
--- | <https://en.wikipedia.org/wiki/International_Atomic_Time International Atomic Time>
--- (TAI) and conversion to/from UTC, accounting for leap seconds.
-module Data.Thyme.Clock.TAI
-    ( AbsoluteTime
-    , taiEpoch
-    , TAIUTCMap (..)
-    , TAIUTCRow (..)
-    , absoluteTime
-    , absoluteTime'
-    , utcDayLength
-    , parseTAIUTCRow
-    , makeTAIUTCMap
-    , parseTAIUTCDAT
-
-    -- * Compatibility
-    , addAbsoluteTime
-    , diffAbsoluteTime
-    , utcToTAITime
-    , taiToUTCTime
-    ) where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.DeepSeq
-import Control.Lens
-import Control.Monad
-import Data.AffineSpace
-import Data.Attoparsec.ByteString.Char8 ((<?>))
-import qualified Data.Attoparsec.ByteString.Char8 as P
-import qualified Data.ByteString as S
-import Data.Data
-import Data.Hashable
-import Data.Ix
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Thyme.Calendar
-import Data.Thyme.Clock.Internal
-import Data.Thyme.Format.Internal (indexOf)
-import Data.Thyme.Internal.Micro
-import Data.Thyme.LocalTime
-#if __GLASGOW_HASKELL__ == 704
-import qualified Data.Vector.Generic
-import qualified Data.Vector.Generic.Mutable
-#endif
-import Data.Vector.Unboxed.Deriving
-import Data.VectorSpace
-import GHC.Generics (Generic)
-import System.Random (Random)
-import Test.QuickCheck
-
--- | <https://en.wikipedia.org/wiki/International_Atomic_Time Temps Atomique International>
--- (TAI). Note that for most applications 'UTCTime' is perfectly sufficient,
--- and much more convenient to use.
---
--- Internally this is the number of seconds since 'taiEpoch'. TAI days are
--- exactly 86400 SI seconds long.
-newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO)
-
-derivingUnbox "AbsoluteTime" [t| AbsoluteTime -> DiffTime |]
-    [| \ (AbsoluteTime a) -> a |] [| AbsoluteTime |]
-
-instance Show AbsoluteTime where
-    {-# INLINEABLE showsPrec #-}
-    showsPrec p tai = showsPrec p lt . (++) " TAI" where
-        lt = tai ^. from (absoluteTime $ TAIUTCMap mempty mempty) . utcLocalTime utc
-
--- | The <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day>
--- epoch, which is /1858-11-17 00:00:00 TAI/.
-{-# INLINE taiEpoch #-}
-taiEpoch :: AbsoluteTime
-taiEpoch = AbsoluteTime zeroV
-
-instance AffineSpace AbsoluteTime where
-    type Diff AbsoluteTime = DiffTime
-    {-# INLINE (.-.) #-}
-    (.-.) = \ (AbsoluteTime a) (AbsoluteTime b) -> a ^-^ b
-    {-# INLINE (.+^) #-}
-    (.+^) = \ (AbsoluteTime a) d -> AbsoluteTime (a ^+^ d)
-
--- | A table of 'TAIUTCRow's for converting between TAI and UTC.
---
--- The two 'Map's are keyed on the corresponding instants in UTC and TAI
--- from which the 'TAIUTCRow' becomes applicable. The 'UTCTime' key of the
--- first 'Map' is always at midnight.
---
--- No table is provided here because leap seconds are unpredictable, and any
--- program shipped with such a table could become out-of-date in as little
--- as 6 months. See 'parseTAIUTCDAT' for details.
-data TAIUTCMap = TAIUTCMap (Map UTCTime TAIUTCRow) (Map AbsoluteTime TAIUTCRow)
-    deriving (INSTANCES_USUAL, Show)
-
--- | Each line of TAIUTCDAT (see 'parseTAIUTCDAT') specifies the difference
--- between TAI and UTC for a particular period. For example:
---
--- @
--- 1968 FEB  1 =JD 2439887.5  TAI-UTC=   4.2131700 S + (MJD - 39126.) X 0.002592 S
--- @
---
--- says that from 1968-02-01 00:00:00 (Julian Date 2439887.5; or Modified
--- Julian Date 39887.0), the difference between TAI and UTC is @4.2131700s@
--- (the /additive/ part) plus a scaled component that increases for each day
--- beyond MJD 39126 (the /base/) by 0.002592s (the /coefficient/). In
--- general, the latter half of each line is of the form:
---
--- @
--- TAI-UTC= /additive/ S + (MJD - /base/) X /coefficient/ S
--- @
---
--- @'TAIUTCRow' a b c@ is a normalised version of the above, with the /base/
--- multiplied by 86400s, and the /coefficient/ divided by the same. This
--- allows us to use the internal representation of 'UTCTime'—seconds since
--- the MJD epoch—as the @MJD@ term without further rescaling.
---
--- Note that between 1961-01-01 and 1972-01-01, each UTC second was actually
--- slightly longer than one TAI (or SI) second. For the first year this was
--- at the rate of exactly 1.000000015 TAI (or SI) seconds per UTC second,
--- but was subject to irregular updates. Since leap seconds came into effect
--- on 1972-01-01, the /additive/ part has always been an intergral number of
--- seconds, and the /coefficient/ has always been zero.
---
--- To convert between TAI and UTC, we refer to the definition:
---
--- @
--- TAI - UTC = a + (MJD - b) * c
--- @
---
--- Using UTC for MJD (with 'b' and 'c' scaled as described above):
---
--- @
--- TAI = UTC + a + (UTC - b) * c
--- TAI - a + b * c = UTC + UTC * c
--- (TAI - a + b * c) / (1 + c) = UTC
--- @
---
--- This is implemented by 'absoluteTime' and 'absoluteTime''.
---
--- Further reading:
---
--- * https://en.wikipedia.org/wiki/Coordinated_Universal_Time
--- * https://en.wikipedia.org/wiki/International_Atomic_Time
-data TAIUTCRow = TAIUTCRow !DiffTime !UTCTime !Rational
-    -- ^ Each row comprises of an /additive/ component, the /base/ of the
-    -- scaled component, and the /coefficient/ of the scaled component.
-    deriving (INSTANCES_USUAL, Show)
-
-{-# INLINE lookupLE #-}
-lookupLE :: (Ord k) => k -> Map k TAIUTCRow -> TAIUTCRow
-lookupLE k = maybe (TAIUTCRow zeroV (UTCRep zeroV) 0) snd . Map.lookupLE k
-
-{-# INLINE unwrap #-}
-unwrap :: TAIUTCRow -> (Micro, Micro, Rational)
-unwrap (TAIUTCRow (DiffTime a) (UTCRep (NominalDiffTime b)) c) = (a, b, c)
-
--- | Convert between 'UTCTime' and 'AbsoluteTime' using a 'TAIUTCMap'.
---
--- Since 'UTCTime' cannot represent a time-of-day of 86400s or more, any
--- conversion from 'AbsoluteTime' that happens to be during a leap second
--- will overflow into the next day.
---
--- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.
---
--- @
--- > let jul1 = 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV'
--- > jul1 '&' 'absoluteTime' tum '%~' ('.-^' 'fromSeconds' 1.1)
--- 2015-06-30 23:59:59.9 UTC
--- @
-{-# INLINE absoluteTime #-}
-absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime
-absoluteTime (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where
-    {-# INLINEABLE toTAI #-}
-    toTAI :: UTCTime -> AbsoluteTime
-    toTAI utime@(UTCRep (NominalDiffTime uts)) = AbsoluteTime . DiffTime $
-            uts ^+^ a ^+^ (uts ^-^ b) ^* c where
-        (a, b, c) = unwrap $ lookupLE utime utcMap
-
-    {-# INLINEABLE toUTC #-}
-    toUTC :: AbsoluteTime -> UTCTime
-    toUTC atime@(AbsoluteTime (DiffTime ats)) = UTCRep . NominalDiffTime $
-            (ats ^-^ a ^+^ b ^* c) ^/ (1 + c) where
-        (a, b, c) = unwrap $ lookupLE atime taiMap
-
--- | Convert between 'UTCView' and TAI 'AbsoluteTime' using a 'TAIUTCMap'.
---
--- Unlike 'absoluteTime', 'UTCView' /can/ represent a time-of-day greater
--- than 86400s, and this gives the correct results during a leap second.
---
--- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.
---
--- @
--- > let jul1 = 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV'
--- > jul1 '&' 'absoluteTime'' tum '%~' ('.-^' 'fromSeconds' 0.1)
--- 'UTCView' {'utcvDay' = 2015-06-30, 'utcvDayTime' = 86400.9s}
--- @
---
--- However keep in mind that currently there is no standard way to get the
--- TAI on most platforms. Simply converting the result of
--- 'Data.Thyme.Clock.getCurrentTime' (which calls @gettimeofday(2)@) to
--- 'AbsoluteTime' during a leap second will still give non-monotonic times.
-{-# INLINE absoluteTime' #-}
-absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime
-absoluteTime' (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where
-    {-# INLINEABLE toTAI #-}
-    toTAI :: UTCView -> AbsoluteTime
-    toTAI uview@(UTCView day _) = AbsoluteTime . DiffTime $
-            uts ^+^ a ^+^ (uts ^-^ b) ^* c where
-        (a, b, c) = unwrap $ lookupLE (utcTime # UTCView day zeroV) utcMap
-        UTCRep (NominalDiffTime uts) = utcTime # uview
-
-    {-# INLINEABLE toUTC #-}
-    toUTC :: AbsoluteTime -> UTCView
-    toUTC atime@(AbsoluteTime (DiffTime ats)) = fixup (utime ^. utcTime) where
-        row@(unwrap -> (a, b, c)) = lookupLE atime taiMap
-        utime = UTCRep . NominalDiffTime $ (ats ^-^ a ^+^ b ^* c) ^/ (1 + c)
-        -- 'lookupLE' of the same instant in 'utcMap' and 'taiMap' should
-        -- give the same 'TAIUTCRow'. If it doesn't, then @utime@ must have
-        -- overflown into the next 'Day'.
-        fixup uview@(UTCView day dt) = if lookupLE utime utcMap == row
-            then uview else UTCView (day .-^ 1) (fromSeconds' 86400 ^+^ dt)
-
--- TODO: Linux >= 3.10 has @CLOCK_TAI@ for @clock_gettime(2)@.
-
--- | Using a 'TAIUTCMap', lookup the 'DiffTime' length of the UTC 'Day'.
---
--- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.
---
--- @
--- > 'utcDayLength' tum '.' 'view' '_utctDay' '<$>' 'getCurrentTime'
--- 86400s
--- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30
--- 86401s
--- @
-utcDayLength :: TAIUTCMap -> Day -> DiffTime
-utcDayLength tum day = diff (day .+^ 1) .-. diff day where
-    diff d = UTCView d zeroV ^. from utcTime . absoluteTime tum
-
--- | @attoparsec@ 'P.Parser' for a single line of TAIUTCDAT.
---
--- Returns the starting 'UTCTime' and the normalised 'TAIUTCRow'.
-parseTAIUTCRow :: P.Parser (UTCTime, TAIUTCRow)
-parseTAIUTCRow = do
-    y <- P.skipSpace *> P.decimal <?> "Year"
-    let months = [ "JAN", "FEB", "MAR", "APR", "MAY", "JUN"
-            , "JUL", "AUG", "SEP", "OCT", "NOV", "DEC" ]
-    m <- (+) 1 <$ P.skipSpace <*> indexOf months <?> "Month"
-    d <- P.skipSpace *> P.decimal <?> "DayOfMonth"
-
-    tokens ["=", "JD"]
-    -- TAI-UTC changes always happen at midnight UTC, so just ignore ".5".
-    since <- subtract 2400000{-.5-} <$> P.decimal
-        <* P.string ".5" <?> "Julian Date .5"
-    let ymd = YearMonthDay y m d
-    unless (gregorian # ymd == ModifiedJulianDay since) $ do
-        fail $ show ymd ++ " ≠ MJD " ++ show since
-            ++ " ≡ " ++ show (ModifiedJulianDay since)
-
-    tokens ["TAI", "-", "UTC", "="]
-    a <- P.rational <?> "Additive"
-    tokens ["S", "+", "(", "MJD", "-"]
-    b <- P.decimal <* P.char '.' <?> "Base" -- also always midnight UTC
-    tokens [")", "X"]
-    c <- (/ toSeconds' posixDayLength) <$> P.rational
-        <* P.skipSpace <* P.string "S" <?> "Coefficient"
-
-    return (mjdToUTC since, TAIUTCRow (fromSeconds' a) (mjdToUTC b) c)
-  where
-    tokens ts = foldr (\ tok a -> P.skipSpace >> P.string tok >> a)
-        P.skipSpace ts <?> ("tokens " ++ show ts)
-    mjdToUTC mjd = utcTime # UTCView (ModifiedJulianDay mjd) zeroV
-
--- | Build a 'TAIUTCMap' from the result of 'parseTAIUTCRow'.
-makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap
-makeTAIUTCMap rows = TAIUTCMap (Map.fromList rows)
-        (Map.fromList $ invert <$> rows) where
-    invert (since, entry) = (since ^. absoluteTime single, entry) where
-        single = TAIUTCMap (Map.singleton since entry) mempty
-
--- | Parse the contents of TAIUTCDAT into a 'TAIUTCMap' for conversion
--- between TAI and UTC.
---
--- @
--- $ curl -O \"http:\/\/maia.usno.navy.mil\/ser7\/tai-utc.dat\"
--- $ ghci --package thyme
--- > import "Data.Thyme"
--- > import "Data.Thyme.Clock.TAI"
--- > import "Data.ByteString" ('S.readFile')
--- > Right tum \<- 'parseTAIUTCDAT' '<$>' 'S.readFile' \"tai-utc.dat\"
--- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30
--- 86401s
--- @
-parseTAIUTCDAT :: S.ByteString -> Either String TAIUTCMap
-parseTAIUTCDAT = P.parseOnly $ makeTAIUTCMap <$> P.manyTill
-    (parseTAIUTCRow <* P.endOfLine) P.endOfInput
-
-------------------------------------------------------------------------
-
--- | Add a duration to an 'AbsoluteTime'.
---
--- @
--- 'addAbsoluteTime' = 'flip' ('.+^')
--- 'addAbsoluteTime' d t ≡ t '.+^' d
--- @
---
--- See also the 'AffineSpace' instance for 'AbsoluteTime'.
-{-# INLINE addAbsoluteTime #-}
-addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
-addAbsoluteTime = flip (.+^)
-
--- | The duration difference between two 'AbsoluteTime's.
---
--- @
--- 'diffAbsoluteTime' = ('.-.')
--- 'diffAbsoluteTime' a b ≡ a '.-.' b
--- @
---
--- See also the 'AffineSpace' instance for 'AbsoluteTime'.
-{-# INLINE diffAbsoluteTime #-}
-diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
-diffAbsoluteTime = (.-.)
-
--- | Using a 'TAIUTCMap', convert a 'UTCTime' to 'AbsoluteTime'.
---
--- @
--- 'utcToTAITime' = 'view' '.' 'absoluteTime'
--- @
-{-# INLINE utcToTAITime #-}
-utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime
-utcToTAITime m = view (absoluteTime m)
-
--- | Using a 'TAIUTCMap', convert a 'AbsoluteTime' to 'UTCTime'.
---
--- @
--- 'taiToUTCTime' = 'review' '.' 'absoluteTime'
--- @
-{-# INLINE taiToUTCTime #-}
-taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime
-taiToUTCTime m = review (absoluteTime m)
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++#define TAIUTCDAT @<http://maia.usno.navy.mil/ser7/tai-utc.dat tai-utc.dat>@++-- | <https://en.wikipedia.org/wiki/International_Atomic_Time International Atomic Time>+-- (TAI) and conversion to/from UTC, accounting for leap seconds.+module Data.Thyme.Clock.TAI+    ( AbsoluteTime+    , taiEpoch+    , TAIUTCMap (..)+    , TAIUTCRow (..)+    , absoluteTime+    , absoluteTime'+    , utcDayLength+    , parseTAIUTCRow+    , makeTAIUTCMap+    , parseTAIUTCDAT++    -- * Compatibility+    , addAbsoluteTime+    , diffAbsoluteTime+    , utcToTAITime+    , taiToUTCTime+    ) where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.AffineSpace+import Data.Attoparsec.ByteString.Char8 ((<?>))+import qualified Data.Attoparsec.ByteString.Char8 as P+import qualified Data.ByteString as S+import Data.Data+import Data.Hashable+import Data.Ix+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Thyme.Calendar+import Data.Thyme.Clock.Internal+import Data.Thyme.Format.Internal (indexOf)+import Data.Thyme.Internal.Micro+import Data.Thyme.LocalTime+#if __GLASGOW_HASKELL__ == 704+import qualified Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable+#endif+import Data.Vector.Unboxed.Deriving+import Data.VectorSpace+import GHC.Generics (Generic)+import System.Random (Random)+import Test.QuickCheck++-- | <https://en.wikipedia.org/wiki/International_Atomic_Time Temps Atomique International>+-- (TAI). Note that for most applications 'UTCTime' is perfectly sufficient,+-- and much more convenient to use.+--+-- Internally this is the number of seconds since 'taiEpoch'. TAI days are+-- exactly 86400 SI seconds long.+newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO)++derivingUnbox "AbsoluteTime" [t| AbsoluteTime -> DiffTime |]+    [| \ (AbsoluteTime a) -> a |] [| AbsoluteTime |]++instance Show AbsoluteTime where+    {-# INLINEABLE showsPrec #-}+    showsPrec p tai = showsPrec p lt . (++) " TAI" where+        lt = tai ^. from (absoluteTime $ TAIUTCMap mempty mempty) . utcLocalTime utc++-- | The <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day>+-- epoch, which is /1858-11-17 00:00:00 TAI/.+{-# INLINE taiEpoch #-}+taiEpoch :: AbsoluteTime+taiEpoch = AbsoluteTime zeroV++instance AffineSpace AbsoluteTime where+    type Diff AbsoluteTime = DiffTime+    {-# INLINE (.-.) #-}+    (.-.) = \ (AbsoluteTime a) (AbsoluteTime b) -> a ^-^ b+    {-# INLINE (.+^) #-}+    (.+^) = \ (AbsoluteTime a) d -> AbsoluteTime (a ^+^ d)++-- | A table of 'TAIUTCRow's for converting between TAI and UTC.+--+-- The two 'Map's are keyed on the corresponding instants in UTC and TAI+-- from which the 'TAIUTCRow' becomes applicable. The 'UTCTime' key of the+-- first 'Map' is always at midnight.+--+-- No table is provided here because leap seconds are unpredictable, and any+-- program shipped with such a table could become out-of-date in as little+-- as 6 months. See 'parseTAIUTCDAT' for details.+data TAIUTCMap = TAIUTCMap (Map UTCTime TAIUTCRow) (Map AbsoluteTime TAIUTCRow)+    deriving (INSTANCES_USUAL, Show)++-- | Each line of TAIUTCDAT (see 'parseTAIUTCDAT') specifies the difference+-- between TAI and UTC for a particular period. For example:+--+-- @+-- 1968 FEB  1 =JD 2439887.5  TAI-UTC=   4.2131700 S + (MJD - 39126.) X 0.002592 S+-- @+--+-- says that from 1968-02-01 00:00:00 (Julian Date 2439887.5; or Modified+-- Julian Date 39887.0), the difference between TAI and UTC is @4.2131700s@+-- (the /additive/ part) plus a scaled component that increases for each day+-- beyond MJD 39126 (the /base/) by 0.002592s (the /coefficient/). In+-- general, the latter half of each line is of the form:+--+-- @+-- TAI-UTC= /additive/ S + (MJD - /base/) X /coefficient/ S+-- @+--+-- @'TAIUTCRow' a b c@ is a normalised version of the above, with the /base/+-- multiplied by 86400s, and the /coefficient/ divided by the same. This+-- allows us to use the internal representation of 'UTCTime'—seconds since+-- the MJD epoch—as the @MJD@ term without further rescaling.+--+-- Note that between 1961-01-01 and 1972-01-01, each UTC second was actually+-- slightly longer than one TAI (or SI) second. For the first year this was+-- at the rate of exactly 1.000000015 TAI (or SI) seconds per UTC second,+-- but was subject to irregular updates. Since leap seconds came into effect+-- on 1972-01-01, the /additive/ part has always been an intergral number of+-- seconds, and the /coefficient/ has always been zero.+--+-- To convert between TAI and UTC, we refer to the definition:+--+-- @+-- TAI - UTC = a + (MJD - b) * c+-- @+--+-- Using UTC for MJD (with 'b' and 'c' scaled as described above):+--+-- @+-- TAI = UTC + a + (UTC - b) * c+-- TAI - a + b * c = UTC + UTC * c+-- (TAI - a + b * c) / (1 + c) = UTC+-- @+--+-- This is implemented by 'absoluteTime' and 'absoluteTime''.+--+-- Further reading:+--+-- * https://en.wikipedia.org/wiki/Coordinated_Universal_Time+-- * https://en.wikipedia.org/wiki/International_Atomic_Time+data TAIUTCRow = TAIUTCRow !DiffTime !UTCTime !Rational+    -- ^ Each row comprises of an /additive/ component, the /base/ of the+    -- scaled component, and the /coefficient/ of the scaled component.+    deriving (INSTANCES_USUAL, Show)++{-# INLINE lookupLE #-}+lookupLE :: (Ord k) => k -> Map k TAIUTCRow -> TAIUTCRow+lookupLE k = maybe (TAIUTCRow zeroV (UTCRep zeroV) 0) snd . Map.lookupLE k++{-# INLINE unwrap #-}+unwrap :: TAIUTCRow -> (Micro, Micro, Rational)+unwrap (TAIUTCRow (DiffTime a) (UTCRep (NominalDiffTime b)) c) = (a, b, c)++-- | Convert between 'UTCTime' and 'AbsoluteTime' using a 'TAIUTCMap'.+--+-- Since 'UTCTime' cannot represent a time-of-day of 86400s or more, any+-- conversion from 'AbsoluteTime' that happens to be during a leap second+-- will overflow into the next day.+--+-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.+--+-- @+-- > let jul1 = 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV'+-- > jul1 '&' 'absoluteTime' tum '%~' ('.-^' 'fromSeconds' 1.1)+-- 2015-06-30 23:59:59.9 UTC+-- @+{-# INLINE absoluteTime #-}+absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime+absoluteTime (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where+    {-# INLINEABLE toTAI #-}+    toTAI :: UTCTime -> AbsoluteTime+    toTAI utime@(UTCRep (NominalDiffTime uts)) = AbsoluteTime . DiffTime $+            uts ^+^ a ^+^ (uts ^-^ b) ^* c where+        (a, b, c) = unwrap $ lookupLE utime utcMap++    {-# INLINEABLE toUTC #-}+    toUTC :: AbsoluteTime -> UTCTime+    toUTC atime@(AbsoluteTime (DiffTime ats)) = UTCRep . NominalDiffTime $+            (ats ^-^ a ^+^ b ^* c) ^/ (1 + c) where+        (a, b, c) = unwrap $ lookupLE atime taiMap++-- | Convert between 'UTCView' and TAI 'AbsoluteTime' using a 'TAIUTCMap'.+--+-- Unlike 'absoluteTime', 'UTCView' /can/ represent a time-of-day greater+-- than 86400s, and this gives the correct results during a leap second.+--+-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.+--+-- @+-- > let jul1 = 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV'+-- > jul1 '&' 'absoluteTime'' tum '%~' ('.-^' 'fromSeconds' 0.1)+-- 'UTCView' {'utcvDay' = 2015-06-30, 'utcvDayTime' = 86400.9s}+-- @+--+-- However keep in mind that currently there is no standard way to get the+-- TAI on most platforms. Simply converting the result of+-- 'Data.Thyme.Clock.getCurrentTime' (which calls @gettimeofday(2)@) to+-- 'AbsoluteTime' during a leap second will still give non-monotonic times.+{-# INLINE absoluteTime' #-}+absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime+absoluteTime' (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where+    {-# INLINEABLE toTAI #-}+    toTAI :: UTCView -> AbsoluteTime+    toTAI uview@(UTCView day _) = AbsoluteTime . DiffTime $+            uts ^+^ a ^+^ (uts ^-^ b) ^* c where+        (a, b, c) = unwrap $ lookupLE (utcTime # UTCView day zeroV) utcMap+        UTCRep (NominalDiffTime uts) = utcTime # uview++    {-# INLINEABLE toUTC #-}+    toUTC :: AbsoluteTime -> UTCView+    toUTC atime@(AbsoluteTime (DiffTime ats)) = fixup (utime ^. utcTime) where+        row@(unwrap -> (a, b, c)) = lookupLE atime taiMap+        utime = UTCRep . NominalDiffTime $ (ats ^-^ a ^+^ b ^* c) ^/ (1 + c)+        -- 'lookupLE' of the same instant in 'utcMap' and 'taiMap' should+        -- give the same 'TAIUTCRow'. If it doesn't, then @utime@ must have+        -- overflown into the next 'Day'.+        fixup uview@(UTCView day dt) = if lookupLE utime utcMap == row+            then uview else UTCView (day .-^ 1) (fromSeconds' 86400 ^+^ dt)++-- TODO: Linux >= 3.10 has @CLOCK_TAI@ for @clock_gettime(2)@.++-- | Using a 'TAIUTCMap', lookup the 'DiffTime' length of the UTC 'Day'.+--+-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.+--+-- @+-- > 'utcDayLength' tum '.' 'view' '_utctDay' '<$>' 'getCurrentTime'+-- 86400s+-- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30+-- 86401s+-- @+utcDayLength :: TAIUTCMap -> Day -> DiffTime+utcDayLength tum day = diff (day .+^ 1) .-. diff day where+    diff d = UTCView d zeroV ^. from utcTime . absoluteTime tum++-- | @attoparsec@ 'P.Parser' for a single line of TAIUTCDAT.+--+-- Returns the starting 'UTCTime' and the normalised 'TAIUTCRow'.+parseTAIUTCRow :: P.Parser (UTCTime, TAIUTCRow)+parseTAIUTCRow = do+    y <- P.skipSpace *> P.decimal <?> "Year"+    let months = [ "JAN", "FEB", "MAR", "APR", "MAY", "JUN"+            , "JUL", "AUG", "SEP", "OCT", "NOV", "DEC" ]+    m <- (+) 1 <$ P.skipSpace <*> indexOf months <?> "Month"+    d <- P.skipSpace *> P.decimal <?> "DayOfMonth"++    tokens ["=", "JD"]+    -- TAI-UTC changes always happen at midnight UTC, so just ignore ".5".+    since <- subtract 2400000{-.5-} <$> P.decimal+        <* P.string ".5" <?> "Julian Date .5"+    let ymd = YearMonthDay y m d+    unless (gregorian # ymd == ModifiedJulianDay since) $ do+        fail $ show ymd ++ " ≠ MJD " ++ show since+            ++ " ≡ " ++ show (ModifiedJulianDay since)++    tokens ["TAI", "-", "UTC", "="]+    a <- P.rational <?> "Additive"+    tokens ["S", "+", "(", "MJD", "-"]+    b <- P.decimal <* P.char '.' <?> "Base" -- also always midnight UTC+    tokens [")", "X"]+    c <- (/ toSeconds' posixDayLength) <$> P.rational+        <* P.skipSpace <* P.string "S" <?> "Coefficient"++    return (mjdToUTC since, TAIUTCRow (fromSeconds' a) (mjdToUTC b) c)+  where+    tokens ts = foldr (\ tok a -> P.skipSpace >> P.string tok >> a)+        P.skipSpace ts <?> ("tokens " ++ show ts)+    mjdToUTC mjd = utcTime # UTCView (ModifiedJulianDay mjd) zeroV++-- | Build a 'TAIUTCMap' from the result of 'parseTAIUTCRow'.+makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap+makeTAIUTCMap rows = TAIUTCMap (Map.fromList rows)+        (Map.fromList $ invert <$> rows) where+    invert (since, entry) = (since ^. absoluteTime single, entry) where+        single = TAIUTCMap (Map.singleton since entry) mempty++-- | Parse the contents of TAIUTCDAT into a 'TAIUTCMap' for conversion+-- between TAI and UTC.+--+-- @+-- $ curl -O \"http:\/\/maia.usno.navy.mil\/ser7\/tai-utc.dat\"+-- $ ghci --package thyme+-- > import "Data.Thyme"+-- > import "Data.Thyme.Clock.TAI"+-- > import "Data.ByteString" ('S.readFile')+-- > Right tum \<- 'parseTAIUTCDAT' '<$>' 'S.readFile' \"tai-utc.dat\"+-- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30+-- 86401s+-- @+parseTAIUTCDAT :: S.ByteString -> Either String TAIUTCMap+parseTAIUTCDAT = P.parseOnly $ makeTAIUTCMap <$> P.manyTill+    (parseTAIUTCRow <* P.endOfLine) P.endOfInput++------------------------------------------------------------------------++-- | Add a duration to an 'AbsoluteTime'.+--+-- @+-- 'addAbsoluteTime' = 'flip' ('.+^')+-- 'addAbsoluteTime' d t ≡ t '.+^' d+-- @+--+-- See also the 'AffineSpace' instance for 'AbsoluteTime'.+{-# INLINE addAbsoluteTime #-}+addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime+addAbsoluteTime = flip (.+^)++-- | The duration difference between two 'AbsoluteTime's.+--+-- @+-- 'diffAbsoluteTime' = ('.-.')+-- 'diffAbsoluteTime' a b ≡ a '.-.' b+-- @+--+-- See also the 'AffineSpace' instance for 'AbsoluteTime'.+{-# INLINE diffAbsoluteTime #-}+diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime+diffAbsoluteTime = (.-.)++-- | Using a 'TAIUTCMap', convert a 'UTCTime' to 'AbsoluteTime'.+--+-- @+-- 'utcToTAITime' = 'view' '.' 'absoluteTime'+-- @+{-# INLINE utcToTAITime #-}+utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime+utcToTAITime m = view (absoluteTime m)++-- | Using a 'TAIUTCMap', convert a 'AbsoluteTime' to 'UTCTime'.+--+-- @+-- 'taiToUTCTime' = 'review' '.' 'absoluteTime'+-- @+{-# INLINE taiToUTCTime #-}+taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime+taiToUTCTime m = review (absoluteTime m)+

src/Data/Thyme/Docs.hs view

@@ -1,357 +1,357 @@-{-# LANGUAGE MagicHash #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-
-module Data.Thyme.Docs
-    (
-    -- * #api#API
-    -- $api
-
-    -- ** #compat#Compatibility with @time@
-    -- $compat
-
-    -- ** #spaces#VectorSpace and AffineSpace
-    -- $spaces
-
-    -- ** #lenses#Isomorphisms and Lenses
-    -- $lenses
-
-    -- * #tutorial#Tutorial
-    -- $tutorial
-
-    -- * #impl#Implementation
-    -- $impl
-
-    -- ** #range#Range
-    -- $range
-
-    -- ** #prec#Precision
-    -- $prec
-
-    -- ** #perf#Performance
-    -- $perf
-    ) where
-
-import Control.Lens
-import Data.AffineSpace
-import Data.Int
-import Data.IntMap (Key, IntMap)
-import Data.Map.Strict (Map)
-import Data.Thyme
-import Data.Thyme.Calendar.WeekDate
-import Data.Thyme.Clock.TAI
-import Data.Thyme.Format.Human
-import Data.Thyme.Time.Core
-import qualified Data.Time as T
-import Data.VectorSpace
-
--- Note: {{{ and }}} below are fold markers for Vim. Please ignore.
-
-{- {{{ api -}
-{- $api
-
-In general stick to 'UTCTime' and 'NominalDiffTime' for time calculations,
-converting from/to 'LocalTime', or 'ZonedTime' et cetera only for
-input/output.
-
-Synonyms for 'Int'—such as 'Year', 'Month', and 'DayOfMonth'—are provided
-for more descriptive type signatures. There are records (with strict and
-unpacked fields) for some common tuples, e.g. 'YearMonthDay', instead of
-@('Integer', 'Int', 'Int')@.
-
-On platforms where the native 'Int' is 64-bits wide, types with an 'Enum'
-instance such as 'Day' can be used as 'Key's for 'IntMap', preferably via an
-@<http://hackage.haskell.org/package/enummapset-th EnumMap>@ wrapper. In any
-case the 'Ord' instances are much faster, if you must use 'Map'.
-
--}{- }}} -}
-
-{- {{{ compat -}
-{- $compat
-
-@thyme@ tries to maintain API compatibility with @time@ and each module
-exports the same functions as corresponding one in @time@. There are however
-some differences to keep in mind:
-
-* 'UTCTime' is an opaque type and there is no @UTCTime@ constructor. Since
-  GHC 7.8 you can use the @<Data-Thyme-Clock.html#v:UTCTime UTCTime>@
-  pattern synonym. In any case, 'utcTime' can convert it to a 'UTCView'.
-
-* 'UniversalTime' similarly has the
-  @<Data-Thyme-Clock.html#v:ModJulianDate ModJulianDate>@ pattern synonym,
-  along with 'modJulianDate'.
-
-* 'Year's are 'Int's, not 'Integer's: you may need 'fromIntegral'.
-
-* If you'd rather not use @lens@ or @vector-space@ directly, most modules
-  list functions under a ‘Compatibility’ section that mimics the @time@ API.
-
-* Where a third party library uses @time@, you can use 'toThyme' and
-  'fromThyme' from "Data.Thyme.Time.Core" to convert between the
-  corresponding types.
-
-* "Data.Thyme.Time" provides 'Num', 'Real', 'Fractional', and 'RealFrac'
-  instances for 'DiffTime' and 'NominalDiffTime'. Avoid using this in new
-  code, <#spaces because of reasons>.
-
-Any other differences not covered here may be unintentional. Please check
-<https://github.com/liyang/thyme/issues?q= the list of issues> on GitHub and
-file a new one if necessary.
-
--}{- }}} -}
-
-{- {{{ spaces -}
-{- $spaces
-
-One of the issues arising from 'Num', 'Real', 'Fractional', and 'RealFrac'
-instances for e.g. 'NominalDiffTime' is that we must also supply nonsensical
-operations such as @('*')@: multiplying two quantities of
-<https://en.wikipedia.org/wiki/Dimensional_analysis#Definition dimension T>
-gives something of dimension /T²/, yet according to the type of @('*')@ the
-result is another 'NominalDiffTime' of dimension /T/.
-
-A more principled approach is to invoke our geometric intuition and think of
-instants in time as points in a one-dimensional affine space—that is, a line
-without an origin per se; a time-line, if you will. Taking the distance
-(displacement) between two points in this space amounts to finding the
-(signed) duration between two instants in time. These durations are akin to
-vectors in the geometric sense, and as such we can add, subtract, or scaled
-them by some factor to obtain another duration. Conversely a point plus (or
-minus) a vector results in another point, and likewise an instant in time
-plus (or minus) a duration takes us to another instant in time.
-
-The 'AffineSpace' and 'VectorSpace' classes from
-<http://hackage.haskell.org/package/vector-space vector-space> allows us to
-express exactly this idea: 'UTCTime' correspond to points on the time-line,
-and is therefore an instance of 'AffineSpace' with the associated
-
-@
-type 'Diff' 'UTCTime' = 'NominalDiffTime'
-@
-
-as the type of durations between instants. It may help to think of the
-provided operations as having these restricted types:
-
-@
-('.-.') :: 'UTCTime' -> 'UTCTime' -> 'NominalDiffTime'
-('.+^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime'
-('.-^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime'
-@
-
-In turn 'NominalDiffTime' is an instance of 'VectorSpace' (and also
-'AdditiveGroup') which comes with the following operations:
-
-@
-('^+^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime'
-('^-^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime'
-@
-
-Said instance also defines @type 'Scalar' 'NominalDiffTime' = 'Rational'@,
-so we can scale 'NominalDiffTime's thusly:
-
-@
-('*^') :: 'Rational' -> 'NominalDiffTime' -> 'NominalDiffTime'
-('^*') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime'
-('^/') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime'
-@
-
-On operator naming: remember that @.@ are points, and @^@ are vectors.
-Thus @('.+^')@ corresponds to the operation /point plus vector/, and
-@('^-^')@ means /vector minus vector/, and so on.
-
-Similarly, 'AbsoluteTime' is an 'AffineSpace', and 'DiffTime' is
-a 'VectorSpace', with
-
-@
-type 'Diff' 'AbsoluteTime' = 'DiffTime'
-type 'Scalar' 'DiffTime' = 'Rational'
-@
-
-If you must have 'Num', 'Real', 'Fractional', and 'RealFrac' for 'DiffTime'
-and 'NominalDiffTime', they are provided as orhpan instances in the
-"Data.Thyme.Time" module.
-
--}{- }}} -}
-
-{- {{{ lenses -}
-{- $lenses
-
-Since a large part of @thyme@'s functionality is involved in converting back
-and forth between various representations of time, it's convenient to expose
-these as "Control.Lens.Iso"s from the
-@<http://hackage.haskell.org/package/lens lens>@ package, and field
-accessors as "Control.Lens.Lens"es.
-
-A full @lens@ <https://www.google.com/search?q=haskell+lens+tutorial tutorial>
-is however beyond the scope of this documentation. As far as /using/ @thyme@
-is concerned, it's sufficient to restrict ourselves to a subset of the
-@lens@ API:
-
-@
-'view'   :: 'Lens'' s a -> s -> a
-'review' :: 'Iso''  s a -> a -> s
-'over'   :: 'Lens'' s a -> (a -> a) -> s -> s
-@
-
-There are infix versions of the above:
-
-@
-('^.') = 'flip' 'view'
-('Control.Lens.#')  = 'review'
-('%~') = 'over'
-@
-
-An 'Iso'' can be used wherever a 'Lens'' is required, so it is helpful to
-think of 'view' and 'over' as also having the following types:
-
-@
-'view'   :: 'Iso'' s a -> s -> a
-'over'   :: 'Iso'' s a -> (a -> a) -> s -> s
-@
-
-You can use a @'Lens'' s a@ to extract an @a@ out of an @s@ with 'view'. An
-'Iso' s a' means you can also construct an @s@ from an @a@ with 'review'.
-Furthermore 'Lens''s and 'Iso''s can be chained with the standard @('.')@
-function composition.
-
-@
-('.') :: 'Lens'' s u -> 'Lens'' u a -> 'Lens'' s a
-('.') :: 'Iso''  s u -> 'Iso''  u a -> 'Iso''  s a
-@
-
-Composing an 'Iso'' with a 'Lens'' however ‘downgrades’ the result to
-a 'Lens''.
-
-The <#tutorial tutorial below> has some examples.
-
--}{- }}} -}
-
-{- {{{ tutorial -}
-{- $tutorial
-
-Start @ghci@ with the @lens@ and @vector-space@ packages, along with some
-preliminary imports:
-
-@
-$ ghci -package thyme -package lens -package vector-space
-> import "Control.Lens"
-> import "Data.AffineSpace"
-> import "Data.Thyme"
-> import "Data.VectorSpace"
-@
-
-Let's begin by getting the current UTC date and time from the local system
-clock:
-
-@
-> now <- 'getCurrentTime'
-> now
-2016-04-06 03:50:11.159991 UTC
-@
-
-What date and time is it in my local time zone, formatted using the default
-locale?
-
-@
-> zone <- 'getCurrentTimeZone'
-> 'formatTime' 'defaultTimeLocale' \"%c\" $ (zone, now) '^.' 'zonedTime'
-"Wed Apr  6 12:50:11 JST 2016"
-@
-
-See also: 'getZonedTime'.
-
-What will be the local time-of-day be /1000/ seconds from now?
-
-@
-> (now '.+^' 'fromSeconds'' 1000) '^.' 'utcLocalTime' zone '.' '_localTimeOfDay'
-12:50:11.159991
-@
-
-Approximately how long has it been since the Unix epoch at midnight
-/1970-01-01/?
-
-@
-> import "Data.Thyme.Format.Human"
-> let posixEpoch = 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 1970 1 1) 'zeroV'
-> 'humanTimeDiff' (now '.-.' posixEpoch)
-"5 decades"
-@
-
-Two months from today, what day of the week will it be?
-
-@
-> import "Data.Thyme.Calendar.WeekDate"
-> let later = now '&' '_utctDay' '.' 'gregorian' '%~' 'gregorianMonthsClip' 2
-> later
-2016-06-06 03:50:11.159991 UTC
-> later '^.' '_utctDay' '.' 'weekDate'
-'WeekDate' {'wdYear' = 2016, 'wdWeek' = 23, 'wdDay' = 1}
-> 'formatTime' 'defaultTimeLocale' \"%A\" later
-"Monday"
-@
-
--}{- }}} -}
-
-{- {{{ impl -}
-{- $impl
-
-The performance improvement of "Data.Thyme" comes chiefly from representing
-times internally as a single @newtype@d 'Int64's instead of multiple
-'GHC.Integer.GMP.Internals.Integer's, as is the case with
-"Data.Time.Clock"@.@'T.UTCTime'. The trade-offs are summarised below.
-
--}{- }}} -}
-
-{- {{{ range -}
-{- $range
-
-'T.UTCTime' from "Data.Time.Clock" has unbounded range, whereas 'UTCTime'
-from "Data.Thyme.Clock" has a usable range just under 600,000 years, between
-the following times inclusive:
-
-@
--290419-11-07 19:59:05.224192 UTC
- 294135-11-26 04:00:54.775807 UTC
-@
-
-@thyme@ is therefore not Y294K-compliant.
-
--}{- }}} -}
-
-{- {{{ prec -}
-{- $prec
-
-'UTCTime', 'NominalDiffTime', 'DiffTime', and so on from "Data.Thyme.Clock"
-have resolutions of /1 μs/ = /10^-6 s/, while those from "Data.Time.Clock"
-have resolutions of /1 ps/ = /10^-12 s/.
-
-However keep in mind that a call to @gettimeofday(3)@ or @clock_gettime(3)@
-takes on the order of ~0.4μs on a relatively recent (circa 2016) desktop, so
-the coarser resolution is not really an issue in almost all applications.
-
--}{- }}} -}
-
-{- {{{ perf -}
-{- $perf
-
-"Data.Thyme.Clock"@.@'UTCTime' is implemented as @newtype@ wrappers around
-a single 'Int64', so that 'addUTCTime' and 'diffUTCTime' both compile down
-to a single arithmetic operation. Likewise "Data.Thyme.Clock"@.@'DiffTime'
-(and 'NominalDiffTime') are also @newtype@s over 'Int64's.
-
-"Data.Time.Clock"@.@'T.UTCTime' on the other hand comprises of two
-'Integer's internally: one for the 'T.Day' and another for the 'T.DiffTime'
-time-of-day. Here 'T.diffUTCTime' has to account for the difference in
-'T.Day's, while 'T.addUTCTime' must normalise its result to ensure
-'T.utctDayTime' stays within 'T.posixDayLength'.
-
-Furthermore, any "Data.Time.Clock"@.@'T.DiffTime' (and 'T.NominalDiffTime')
-longer than /~2.15 ms/ exceeds /2^31 ps/, and would overflow a native
-'GHC.Prim.Int#' on 32-bit architectures, incurring the cost of using
-'GHC.Integer.GMP.Internals.BigNat's inside
-'GHC.Integer.GMP.Internals.Integer'. Even for 64-bit 'Int#'s, /2^63 ps/
-corresponds to only /~106 days/, and it's not inconceivable to deal with
-durations longer than this. In both cases, there is the additional overhead
-of working with lifted 'GHC.Integer.GMP.Internals.Integer's.
-
--}{- }}} -}
-
+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Data.Thyme.Docs+    (+    -- * #api#API+    -- $api++    -- ** #compat#Compatibility with @time@+    -- $compat++    -- ** #spaces#VectorSpace and AffineSpace+    -- $spaces++    -- ** #lenses#Isomorphisms and Lenses+    -- $lenses++    -- * #tutorial#Tutorial+    -- $tutorial++    -- * #impl#Implementation+    -- $impl++    -- ** #range#Range+    -- $range++    -- ** #prec#Precision+    -- $prec++    -- ** #perf#Performance+    -- $perf+    ) where++import Control.Lens+import Data.AffineSpace+import Data.Int+import Data.IntMap (Key, IntMap)+import Data.Map.Strict (Map)+import Data.Thyme+import Data.Thyme.Calendar.WeekDate+import Data.Thyme.Clock.TAI+import Data.Thyme.Format.Human+import Data.Thyme.Time.Core+import qualified Data.Time as T+import Data.VectorSpace++-- Note: {{{ and }}} below are fold markers for Vim. Please ignore.++{- {{{ api -}+{- $api++In general stick to 'UTCTime' and 'NominalDiffTime' for time calculations,+converting from/to 'LocalTime', or 'ZonedTime' et cetera only for+input/output.++Synonyms for 'Int'—such as 'Year', 'Month', and 'DayOfMonth'—are provided+for more descriptive type signatures. There are records (with strict and+unpacked fields) for some common tuples, e.g. 'YearMonthDay', instead of+@('Integer', 'Int', 'Int')@.++On platforms where the native 'Int' is 64-bits wide, types with an 'Enum'+instance such as 'Day' can be used as 'Key's for 'IntMap', preferably via an+@<http://hackage.haskell.org/package/enummapset-th EnumMap>@ wrapper. In any+case the 'Ord' instances are much faster, if you must use 'Map'.++-}{- }}} -}++{- {{{ compat -}+{- $compat++@thyme@ tries to maintain API compatibility with @time@ and each module+exports the same functions as corresponding one in @time@. There are however+some differences to keep in mind:++* 'UTCTime' is an opaque type and there is no @UTCTime@ constructor. Since+  GHC 7.8 you can use the @<Data-Thyme-Clock.html#v:UTCTime UTCTime>@+  pattern synonym. In any case, 'utcTime' can convert it to a 'UTCView'.++* 'UniversalTime' similarly has the+  @<Data-Thyme-Clock.html#v:ModJulianDate ModJulianDate>@ pattern synonym,+  along with 'modJulianDate'.++* 'Year's are 'Int's, not 'Integer's: you may need 'fromIntegral'.++* If you'd rather not use @lens@ or @vector-space@ directly, most modules+  list functions under a ‘Compatibility’ section that mimics the @time@ API.++* Where a third party library uses @time@, you can use 'toThyme' and+  'fromThyme' from "Data.Thyme.Time.Core" to convert between the+  corresponding types.++* "Data.Thyme.Time" provides 'Num', 'Real', 'Fractional', and 'RealFrac'+  instances for 'DiffTime' and 'NominalDiffTime'. Avoid using this in new+  code, <#spaces because of reasons>.++Any other differences not covered here may be unintentional. Please check+<https://github.com/liyang/thyme/issues?q= the list of issues> on GitHub and+file a new one if necessary.++-}{- }}} -}++{- {{{ spaces -}+{- $spaces++One of the issues arising from 'Num', 'Real', 'Fractional', and 'RealFrac'+instances for e.g. 'NominalDiffTime' is that we must also supply nonsensical+operations such as @('*')@: multiplying two quantities of+<https://en.wikipedia.org/wiki/Dimensional_analysis#Definition dimension T>+gives something of dimension /T²/, yet according to the type of @('*')@ the+result is another 'NominalDiffTime' of dimension /T/.++A more principled approach is to invoke our geometric intuition and think of+instants in time as points in a one-dimensional affine space—that is, a line+without an origin per se; a time-line, if you will. Taking the distance+(displacement) between two points in this space amounts to finding the+(signed) duration between two instants in time. These durations are akin to+vectors in the geometric sense, and as such we can add, subtract, or scaled+them by some factor to obtain another duration. Conversely a point plus (or+minus) a vector results in another point, and likewise an instant in time+plus (or minus) a duration takes us to another instant in time.++The 'AffineSpace' and 'VectorSpace' classes from+<http://hackage.haskell.org/package/vector-space vector-space> allows us to+express exactly this idea: 'UTCTime' correspond to points on the time-line,+and is therefore an instance of 'AffineSpace' with the associated++@+type 'Diff' 'UTCTime' = 'NominalDiffTime'+@++as the type of durations between instants. It may help to think of the+provided operations as having these restricted types:++@+('.-.') :: 'UTCTime' -> 'UTCTime' -> 'NominalDiffTime'+('.+^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime'+('.-^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime'+@++In turn 'NominalDiffTime' is an instance of 'VectorSpace' (and also+'AdditiveGroup') which comes with the following operations:++@+('^+^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime'+('^-^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime'+@++Said instance also defines @type 'Scalar' 'NominalDiffTime' = 'Rational'@,+so we can scale 'NominalDiffTime's thusly:++@+('*^') :: 'Rational' -> 'NominalDiffTime' -> 'NominalDiffTime'+('^*') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime'+('^/') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime'+@++On operator naming: remember that @.@ are points, and @^@ are vectors.+Thus @('.+^')@ corresponds to the operation /point plus vector/, and+@('^-^')@ means /vector minus vector/, and so on.++Similarly, 'AbsoluteTime' is an 'AffineSpace', and 'DiffTime' is+a 'VectorSpace', with++@+type 'Diff' 'AbsoluteTime' = 'DiffTime'+type 'Scalar' 'DiffTime' = 'Rational'+@++If you must have 'Num', 'Real', 'Fractional', and 'RealFrac' for 'DiffTime'+and 'NominalDiffTime', they are provided as orhpan instances in the+"Data.Thyme.Time" module.++-}{- }}} -}++{- {{{ lenses -}+{- $lenses++Since a large part of @thyme@'s functionality is involved in converting back+and forth between various representations of time, it's convenient to expose+these as "Control.Lens.Iso"s from the+@<http://hackage.haskell.org/package/lens lens>@ package, and field+accessors as "Control.Lens.Lens"es.++A full @lens@ <https://www.google.com/search?q=haskell+lens+tutorial tutorial>+is however beyond the scope of this documentation. As far as /using/ @thyme@+is concerned, it's sufficient to restrict ourselves to a subset of the+@lens@ API:++@+'view'   :: 'Lens'' s a -> s -> a+'review' :: 'Iso''  s a -> a -> s+'over'   :: 'Lens'' s a -> (a -> a) -> s -> s+@++There are infix versions of the above:++@+('^.') = 'flip' 'view'+('Control.Lens.#')  = 'review'+('%~') = 'over'+@++An 'Iso'' can be used wherever a 'Lens'' is required, so it is helpful to+think of 'view' and 'over' as also having the following types:++@+'view'   :: 'Iso'' s a -> s -> a+'over'   :: 'Iso'' s a -> (a -> a) -> s -> s+@++You can use a @'Lens'' s a@ to extract an @a@ out of an @s@ with 'view'. An+'Iso' s a' means you can also construct an @s@ from an @a@ with 'review'.+Furthermore 'Lens''s and 'Iso''s can be chained with the standard @('.')@+function composition.++@+('.') :: 'Lens'' s u -> 'Lens'' u a -> 'Lens'' s a+('.') :: 'Iso''  s u -> 'Iso''  u a -> 'Iso''  s a+@++Composing an 'Iso'' with a 'Lens'' however ‘downgrades’ the result to+a 'Lens''.++The <#tutorial tutorial below> has some examples.++-}{- }}} -}++{- {{{ tutorial -}+{- $tutorial++Start @ghci@ with the @lens@ and @vector-space@ packages, along with some+preliminary imports:++@+$ ghci -package thyme -package lens -package vector-space+> import "Control.Lens"+> import "Data.AffineSpace"+> import "Data.Thyme"+> import "Data.VectorSpace"+@++Let's begin by getting the current UTC date and time from the local system+clock:++@+> now <- 'getCurrentTime'+> now+2016-04-06 03:50:11.159991 UTC+@++What date and time is it in my local time zone, formatted using the default+locale?++@+> zone <- 'getCurrentTimeZone'+> 'formatTime' 'defaultTimeLocale' \"%c\" $ (zone, now) '^.' 'zonedTime'+"Wed Apr  6 12:50:11 JST 2016"+@++See also: 'getZonedTime'.++What will be the local time-of-day be /1000/ seconds from now?++@+> (now '.+^' 'fromSeconds'' 1000) '^.' 'utcLocalTime' zone '.' '_localTimeOfDay'+12:50:11.159991+@++Approximately how long has it been since the Unix epoch at midnight+/1970-01-01/?++@+> import "Data.Thyme.Format.Human"+> let posixEpoch = 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 1970 1 1) 'zeroV'+> 'humanTimeDiff' (now '.-.' posixEpoch)+"5 decades"+@++Two months from today, what day of the week will it be?++@+> import "Data.Thyme.Calendar.WeekDate"+> let later = now '&' '_utctDay' '.' 'gregorian' '%~' 'gregorianMonthsClip' 2+> later+2016-06-06 03:50:11.159991 UTC+> later '^.' '_utctDay' '.' 'weekDate'+'WeekDate' {'wdYear' = 2016, 'wdWeek' = 23, 'wdDay' = 1}+> 'formatTime' 'defaultTimeLocale' \"%A\" later+"Monday"+@++-}{- }}} -}++{- {{{ impl -}+{- $impl++The performance improvement of "Data.Thyme" comes chiefly from representing+times internally as a single @newtype@d 'Int64's instead of multiple+'GHC.Integer.GMP.Internals.Integer's, as is the case with+"Data.Time.Clock"@.@'T.UTCTime'. The trade-offs are summarised below.++-}{- }}} -}++{- {{{ range -}+{- $range++'T.UTCTime' from "Data.Time.Clock" has unbounded range, whereas 'UTCTime'+from "Data.Thyme.Clock" has a usable range just under 600,000 years, between+the following times inclusive:++@+-290419-11-07 19:59:05.224192 UTC+ 294135-11-26 04:00:54.775807 UTC+@++@thyme@ is therefore not Y294K-compliant.++-}{- }}} -}++{- {{{ prec -}+{- $prec++'UTCTime', 'NominalDiffTime', 'DiffTime', and so on from "Data.Thyme.Clock"+have resolutions of /1 μs/ = /10^-6 s/, while those from "Data.Time.Clock"+have resolutions of /1 ps/ = /10^-12 s/.++However keep in mind that a call to @gettimeofday(3)@ or @clock_gettime(3)@+takes on the order of ~0.4μs on a relatively recent (circa 2016) desktop, so+the coarser resolution is not really an issue in almost all applications.++-}{- }}} -}++{- {{{ perf -}+{- $perf++"Data.Thyme.Clock"@.@'UTCTime' is implemented as @newtype@ wrappers around+a single 'Int64', so that 'addUTCTime' and 'diffUTCTime' both compile down+to a single arithmetic operation. Likewise "Data.Thyme.Clock"@.@'DiffTime'+(and 'NominalDiffTime') are also @newtype@s over 'Int64's.++"Data.Time.Clock"@.@'T.UTCTime' on the other hand comprises of two+'Integer's internally: one for the 'T.Day' and another for the 'T.DiffTime'+time-of-day. Here 'T.diffUTCTime' has to account for the difference in+'T.Day's, while 'T.addUTCTime' must normalise its result to ensure+'T.utctDayTime' stays within 'T.posixDayLength'.++Furthermore, any "Data.Time.Clock"@.@'T.DiffTime' (and 'T.NominalDiffTime')+longer than /~2.15 ms/ exceeds /2^31 ps/, and would overflow a native+'GHC.Prim.Int#' on 32-bit architectures, incurring the cost of using+'GHC.Integer.GMP.Internals.BigNat's inside+'GHC.Integer.GMP.Internals.Integer'. Even for 64-bit 'Int#'s, /2^63 ps/+corresponds to only /~106 days/, and it's not inconceivable to deal with+durations longer than this. In both cases, there is the additional overhead+of working with lifted 'GHC.Integer.GMP.Internals.Integer's.++-}{- }}} -}+

src/Data/Thyme/Format.hs view

@@ -1,989 +1,992 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans -Wno-unused-record-wildcards #-}
-
-#include "thyme.h"
-
--- | Formatting and parsing for dates and times.
-module Data.Thyme.Format
-    (
-    -- * Formatting Date/Time to String
-      FormatTime (..)
-    , formatTime
-    -- * Parsing Date/Time from String
-    , ParseTime (..)
-    , parseTime
-    , readTime
-    , readsTime
-    , TimeParse (..)
-    , timeParser
-
-    -- * Time Locale
-    , TimeLocale (..)
-    , defaultTimeLocale
-    ) where
-
-import Prelude
-import Control.Applicative
-#if SHOW_INTERNAL
-import Control.Arrow
-#endif
-import Control.Lens
-import Control.Monad.Trans
-import Control.Monad.State.Strict
-import Data.Attoparsec.ByteString.Char8 (Parser)
-import qualified Data.Attoparsec.ByteString.Char8 as P
-import Data.Bits
-import qualified Data.ByteString.Char8 as S
-import Data.Char
-import Data.Int
-import Data.Thyme.Internal.Micro
-import Data.Thyme.Calendar
-import Data.Thyme.Calendar.Internal
-import Data.Thyme.Clock.Internal
-import Data.Thyme.Clock.POSIX
-import Data.Thyme.Clock.TAI
-import Data.Thyme.Format.Internal
-import Data.Thyme.LocalTime
-import Data.VectorSpace
-
-#if MIN_VERSION_time(1,5,0)
-import Data.Time.Format (TimeLocale (..), defaultTimeLocale)
-#else
-import System.Locale
-#endif
-
--- | All instances of this class may be formatted by 'formatTime'.
-class FormatTime t where
-    showsTime
-        :: TimeLocale
-        -> t
-        -> (Char -> ShowS)
-        -> Char
-        -> ShowS
-
-
--- TODO Here are the formatting codes from the @time@ library which are not
---      implemented.
---
--- [@%t@] tab
---
--- [@%n@] newline
---
--- === glibc-style modifiers can be used before the letter (here marked as @z@)
---
--- [@%-z@] no padding
---
--- [@%_z@] pad with spaces
---
--- [@%0z@] pad with zeros
---
--- [@%^z@] convert to upper case
---
--- [@%#z@] convert to lower case (consistently, unlike glibc)
---
--- === For 'UTCTime' and 'ZonedTime'
--- [@%s@] doesn't work for 'ZonedTime'
---
--- [@%Y@] Note __@%0Y@__ and __@%_Y@__ pad to four chars
---
--- [@%G@] Note __@%0G@__ and __@%_G@__ pad to four chars
---
--- [@%f@] Note __@%0f@__ and __@%_f@__ pad to two chars
---
--- [@%C@] Note __@%0C@__ and __@%_C@__ pad to two chars
---
---
--- TODO Format codes for week-of-month?
---
--- TODO It's impossible to print out an ordinal day of month or day of week
---      without padding. Implement the @time@ padding modifiers? Of course
---      the work-around, the 'Show' instance for 'Int', isn't too bad.
---
--- TODO drop the dependency on @old-locale@ for the TimeLocale type?
-
-
-
--- | Format a 'FormatTime' instance value according to a template string.
---
--- These formatting template codes are intended to be compatible with
--- __@glibc@__ @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime()>@
--- function, following "Data.Time.Format", which
--- follows 'System.Time.formatCalendarTime' from the @old-time@ package.
--- Codes which differ from @strftime()@ are marked as
--- /EXTENSION/.
---
--- == Show/Parse template string spec
---
--- === For all types
---
--- [@%%@] literal @\"%\"@
---
--- === For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):
---
--- [@%z@] RFC 822/ISO 8601:1988 style numeric time zone (e.g., @\"-0600\"@ or @\"+0100\"@)
---
--- [@%N@] ISO 8601 style numeric time zone (e.g., @\"-06:00\"@ or @\"+01:00\"@) /EXTENSION/
---
--- [@%Z@] timezone name
---
--- === For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime')
---
--- [@%c@] The preferred calendar time representation for the current locale. As 'dateTimeFmt' @locale@ (e.g. __@%a %b %e %H:%M:%S %Z %Y@__)
---
--- === For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime')
---
--- [@%R@] same as __@%H:%M@__
---
--- [@%T@] same as __@%H:%M:%S@__
---
--- [@%X@] The preferred time of day representation for the current locale. As 'timeFmt' @locale@ (e.g. __@%H:%M:%S@__)
---
--- [@%r@] The complete calendar time using the AM/PM format of the current locale. As 'time12Fmt' @locale@ (e.g. __@%I:%M:%S %p@__)
---
--- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @\"am\"@, @\"pm\"@
---
--- [@%p@] day-half of day from ('amPm' @locale@), @\"AM\"@, @\"PM\"@
---
--- [@%H@] hour of day (24-hour), 0-padded to two chars, @\"00\"@–@\"23\"@
---
--- [@%k@] hour of day (24-hour), space-padded to two chars, @\" 0\"@–@\"23\"@
---
--- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @\"01\"@–@\"12\"@
---
--- [@%l@] hour of day-half (12-hour), space-padded to two chars, @\" 1\"@–@\"12\"@
---
--- [@%M@] minute of hour, 0-padded to two chars, @\"00\"@–@\"59\"@
---
--- [@%S@] second of minute (without decimal part), 0-padded to two chars, @\"00\"@–@\"60\"@
---
--- [@%q@] picosecond of second, 0-padded to twelve chars, @\"000000000000\"@–@\"999999999999\"@. /EXTENSION/
---
--- [@%v@] microsecond of second, 0-padded to six chars, @\"000000\"@–@\"999999\"@. /EXTENSION/
---
--- [@%Q@] decimal point and fraction of second, up to 6 second decimals, without trailing zeros.
---        For a whole number of seconds, __@%Q@__ produces the empty string. /EXTENSION/
---
--- === For 'UTCTime'
---
--- [@%s@] number of whole seconds since the Unix epoch. For times before
--- the Unix epoch, this is a negative number. Note that in __@%s.%q@__ and __@%s%Q@__
--- the decimals are positive, not negative. For example, 0.9 seconds
--- before the Unix epoch is formatted as @\"-1.1\"@ with __@%s%Q@__.
---
--- === For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime')
---
--- [@%D@] same as __@%m\/%d\/%y@__
---
--- [@%F@] same as __@%Y-%m-%d@__
---
--- [@%x@] as 'dateFmt' @locale@ (e.g. __@%m\/%d\/%y@__)
---
--- [@%Y@] year, no padding.
---
--- [@%y@] year of century, 0-padded to two chars, @\"00\"@–@\"99\"@
---
--- [@%C@] century, no padding.
---
--- [@%B@] month name, long form ('fst' from 'months' @locale@), @\"January\"@–@\"December\"@
---
--- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @\"Jan\"@–@\"Dec\"@
---
--- [@%m@] month of year, 0-padded to two chars, @\"01\"@–@\"12\"@
---
--- [@%d@] day of month, 0-padded to two chars, @\"01\"@–@\"31\"@
---
--- [@%e@] day of month, space-padded to two chars, @\" 1\"@–@\"31\"@
---
--- [@%j@] day of year, 0-padded to three chars, @\"001\"@–@\"366\"@
---
--- [@%G@] year for Week Date format, no padding.
---
--- [@%g@] year of century for Week Date format, 0-padded to two chars, @\"00\"@–@\"99\"@
---
--- [@%f@] century for Week Date format, no padding. /EXTENSION/
---
--- [@%V@] week of year for Week Date format, 0-padded to two chars, @\"01\"@–@\"53\"@
---
--- [@%u@] day of week for Week Date format, @\"1\"@–@\"7\"@
---
--- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @\"Sun\"@–@\"Sat\"@
---
--- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @\"Sunday\"@–@\"Saturday\"@
---
--- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @\"00\"@–@\"53\"@
---
--- [@%w@] day of week number, @\"0\"@ (= Sunday) – @\"6\"@ (= Saturday)
---
--- [@%W@] week of year where weeks start on Monday (as 'Data.Thyme.Calendar.WeekdayOfMonth.mondayStartWeek'), 0-padded to two chars, @\"00\"@–@\"53\"@
---
--- == Examples
---
--- ==== <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601>
--- @
--- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" $ 'mkUTCTime' 2015 1 15  12 34 56.78
--- "2015-01-15T12:34:56+00:00"
--- @
---
--- ==== <http://tools.ietf.org/html/rfc822#section-5 RFC822>
--- @
--- > 'formatTime' 'defaultTimeLocale' "%a, %_d %b %Y %H:%M:%S %Z" $ 'mkUTCTime' 2015 1 15  12 34 56.78
--- "Thu, 15 Jan 2015 12:34:56 UTC"
--- @
---
--- ==== YYYY-MM-DD hh:mm:ss.000000
--- @
--- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%d %H:%M:%S.%v" $ 'mkUTCTime' 2015 1 15  12 34 56.78
--- "2015-01-15 12:34:56.780000"
--- @
-{-# INLINEABLE formatTime #-}
-formatTime :: (FormatTime t)
-    => TimeLocale
-        -- ^ Locale for formatting.
-    -> String
-        -- ^ Template spec string.
-    -> t
-        -- ^ 'FormatTime' instance value to be formatted.
-    -> String
-formatTime l@TimeLocale {..} spec t = go spec "" where
-    -- leave unrecognised codes as they are
-    format = showsTime l t (\ c s -> '%' : c : s)
-    go s = case s of
-        '%' : c : rest -> case c of
-            -- aggregate
-            'c' -> go (dateTimeFmt ++ rest)
-            'r' -> go (time12Fmt ++ rest)
-            'X' -> go (timeFmt ++ rest)
-            'x' -> go (dateFmt ++ rest)
-            -- modifier (whatever)
-            '-' -> go ('%' : rest)
-            '_' -> go ('%' : rest)
-            '0' -> go ('%' : rest)
-            '^' -> go ('%' : rest)
-            '#' -> go ('%' : rest)
-            -- escape (why would anyone need %t and %n?)
-            '%' -> (:) '%' . go rest
-            -- default
-            _ -> format c . go rest
-        c : rest -> (:) c . go rest
-        [] -> id
-
--- | 'ShowS' a year with a minimum of four digits (even in the first
--- millennium), to comply with
--- <https://en.wikipedia.org/wiki/ISO_8601#Years ISO 8601 Years>.
-{-# INLINE showsY #-}
-showsY :: Year -> ShowS
-#if BUG_FOR_BUG
-showsY = shows
-#else
--- ISO 8601 says minimum of 4 digits, even for first millennium.
-showsY = showsYear
-#endif
-
-instance FormatTime TimeOfDay where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (TimeOfDay h m (DiffTime s)) = \ def c -> case c of
-        -- aggregate
-        'R' -> shows02 h . (:) ':' . shows02 m
-        'T' -> shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 si
-        -- AM/PM
-        'P' -> (++) $ toLower <$> if h < 12 then fst amPm else snd amPm
-        'p' -> (++) $ if h < 12 then fst amPm else snd amPm
-        -- Hour
-        'H' -> shows02 h
-        'I' -> shows02 $ 1 + mod (h - 1) 12
-        'k' -> shows_2 h
-        'l' -> shows_2 $ 1 + mod (h - 1) 12
-        -- Minute
-        'M' -> shows02 m
-        -- Second
-        'S' -> shows02 si
-        'q' -> fills06 su . shows su . (++) "000000"
-        'v' -> fills06 su . shows su
-        'Q' -> if su == 0 then id else (:) '.' . fills06 su . drops0 su
-        -- default
-        _ -> def c
-        where (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000)
-
-instance FormatTime YearMonthDay where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (YearMonthDay y m d) = \ def c -> case c of
-        -- aggregate
-        'D' -> shows02 m . (:) '/' . shows02 d . (:) '/' . shows02 (mod y 100)
-        'F' -> showsY y . (:) '-' . shows02 m . (:) '-' . shows02 d
-        -- Year
-        'Y' -> showsY y
-        'y' -> shows02 (mod y 100)
-        'C' -> shows02 (div y 100)
-        -- Month
-        'B' -> (++) . fst $ months !! (m - 1)
-        'b' -> (++) . snd $ months !! (m - 1)
-        'h' -> (++) . snd $ months !! (m - 1)
-        'm' -> shows02 m
-        -- DayOfMonth
-        'd' -> shows02 d
-        'e' -> shows_2 d
-        -- default
-        _ -> def c
-
-instance FormatTime MonthDay where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (MonthDay m d) = \ def c -> case c of
-        -- Month
-        'B' -> (++) . fst $ months !! (m - 1)
-        'b' -> (++) . snd $ months !! (m - 1)
-        'h' -> (++) . snd $ months !! (m - 1)
-        'm' -> shows02 m
-        -- DayOfMonth
-        'd' -> shows02 d
-        'e' -> shows_2 d
-        -- default
-        _ -> def c
-
-instance FormatTime OrdinalDate where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (OrdinalDate y d) = \ def c -> case c of
-        -- Year
-        'Y' -> showsY y
-        'y' -> shows02 (mod y 100)
-        'C' -> shows02 (div y 100)
-        -- DayOfYear
-        'j' -> shows03 d
-        -- default
-        _ -> def c
-
-instance FormatTime WeekDate where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of
-        -- Year
-        'G' -> showsY y
-        'g' -> shows02 (mod y 100)
-        'f' -> shows02 (div y 100)
-        -- WeekOfYear
-        'V' -> shows02 w
-        -- DayOfWeek
-        'u' -> shows $ if d == 0 then 7 else d
-        'w' -> shows $ if d == 7 then 0 else d
-        'A' -> (++) . fst $ wDays !! mod d 7
-        'a' -> (++) . snd $ wDays !! mod d 7
-        -- default
-        _ -> def c
-
-instance FormatTime SundayWeek where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (SundayWeek y w d) = \ def c -> case c of
-        -- Year
-        'Y' -> showsY y
-        'y' -> shows02 (mod y 100)
-        'C' -> shows02 (div y 100)
-        -- WeekOfYear
-        'U' -> shows02 w
-        -- DayOfWeek
-        'u' -> shows $ if d == 0 then 7 else d
-        'w' -> shows $ if d == 7 then 0 else d
-        'A' -> (++) . fst $ wDays !! mod d 7
-        'a' -> (++) . snd $ wDays !! mod d 7
-        -- default
-        _ -> def c
-
-instance FormatTime MondayWeek where
-    {-# INLINEABLE showsTime #-}
-    showsTime TimeLocale {..} (MondayWeek y w d) = \ def c -> case c of
-        -- Year
-        'Y' -> showsY y
-        'y' -> shows02 (mod y 100)
-        'C' -> shows02 (div y 100)
-        -- WeekOfYear
-        'W' -> shows02 w
-        -- DayOfWeek
-        'u' -> shows $ if d == 0 then 7 else d
-        'w' -> shows $ if d == 7 then 0 else d
-        'A' -> (++) . fst $ wDays !! mod d 7
-        'a' -> (++) . snd $ wDays !! mod d 7
-        -- default
-        _ -> def c
-
-instance FormatTime LocalTime where
-    {-# INLINEABLE showsTime #-}
-    showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod
-
-instance FormatTime Day where
-    {-# INLINEABLE showsTime #-}
-    showsTime l d@(view ordinalDate -> ordinal)
-        = showsTime l ordinal
-        . showsTime l (ordinal ^. yearMonthDay)
-        . showsTime l (toWeekOrdinal ordinal d)
-        . showsTime l (toSundayOrdinal ordinal d)
-        . showsTime l (toMondayOrdinal ordinal d)
-
-instance FormatTime TimeZone where
-    {-# INLINEABLE showsTime #-}
-    showsTime _ tz@(TimeZone _ _ name) = \ def c -> case c of
-        'z' -> (++) (timeZoneOffsetString tz)
-        'N' -> (++) (timeZoneOffsetStringColon tz)
-        'Z' -> (++) (if null name then timeZoneOffsetString tz else name)
-        _ -> def c
-
-instance FormatTime ZonedTime where
-    {-# INLINEABLE showsTime #-}
-    showsTime l (ZonedTime lt tz) = showsTime l lt . showsTime l tz
-
-instance FormatTime UTCTime where
-    {-# INLINEABLE showsTime #-}
-    showsTime l t = \ def c -> case c of
-        's' -> shows . fst $ qr s (Micro 1000000)
-        _ -> showsTime l ((utc, t) ^. zonedTime) def c
-      where
-        NominalDiffTime s = t ^. posixTime
-#if BUG_FOR_BUG
-        qr = microDivMod -- rounds down
-#else
-        qr = microQuotRem -- rounds to 0
-#endif
-
-instance FormatTime UniversalTime where
-    {-# INLINEABLE showsTime #-}
-    showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "UT1"} where
-        lt = t ^. ut1LocalTime 0
-
-instance FormatTime AbsoluteTime where
-    {-# INLINEABLE showsTime #-}
-    showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "TAI"} where
-        lt = t ^. from (absoluteTime tum) . utcLocalTime utc
-        tum = TAIUTCMap mempty mempty
-
-------------------------------------------------------------------------
-
-data TimeFlag
-    = PostMeridiem
-    | TwelveHour
-    | HasCentury
-    | IsPOSIXTime
-    | IsOrdinalDate
-    | IsGregorian
-    | IsWeekDate
-    | IsSundayWeek
-    | IsMondayWeek
-    deriving (Enum, Show)
-
--- | Unconstituted date-time for parsing.
-data TimeParse = TimeParse
-    { tpCentury :: {-# UNPACK #-}!Int
-    , tpCenturyYear :: {-# UNPACK #-}!Int{-YearOfCentury-}
-    , tpMonth :: {-# UNPACK #-}!Month
-    , tpWeekOfYear :: {-# UNPACK #-}!WeekOfYear
-    , tpDayOfMonth :: {-# UNPACK #-}!DayOfMonth
-    , tpDayOfYear :: {-# UNPACK #-}!DayOfYear
-    , tpDayOfWeek :: {-# UNPACK #-}!DayOfWeek
-    , tpFlags :: {-# UNPACK #-}!Int{-BitSet TimeFlag-}
-    , tpHour :: {-# UNPACK #-}!Hour
-    , tpMinute :: {-# UNPACK #-}!Minute
-    , tpSecond :: {-# UNPACK #-}!Int
-    , tpSecFrac :: {-# UNPACK #-}!DiffTime
-    , tpPOSIXTime :: {-# UNPACK #-}!POSIXTime
-    , tpTimeZone :: !TimeZone
-    } deriving (Show)
-
-LENS(TimeParse,tpCentury,Int)
-LENS(TimeParse,tpCenturyYear,Int{-YearOfCentury-})
-LENS(TimeParse,tpMonth,Month)
-LENS(TimeParse,tpWeekOfYear,WeekOfYear)
-LENS(TimeParse,tpDayOfMonth,DayOfMonth)
-LENS(TimeParse,tpDayOfWeek,DayOfWeek)
-LENS(TimeParse,tpDayOfYear,DayOfYear)
-LENS(TimeParse,tpFlags,Int{-BitSet TimeFlag-})
-LENS(TimeParse,tpHour,Hour)
-LENS(TimeParse,tpMinute,Minute)
-LENS(TimeParse,tpSecond,Int)
-LENS(TimeParse,tpSecFrac,DiffTime)
-LENS(TimeParse,tpPOSIXTime,POSIXTime)
-LENS(TimeParse,tpTimeZone,TimeZone)
-
-{-# INLINE flag #-}
-flag :: TimeFlag -> Lens' TimeParse Bool
-flag (fromEnum -> f) = _tpFlags . lens
-    (`testBit` f) (\ n b -> (if b then setBit else clearBit) n f)
-
--- | Produce a 'Parser' for UTF-8 encoded 'ByteString's.
---
--- This function is used internally by 'parseTime', 'readTime', and 'readsTime';
--- consider using one of those functions instead.
---
--- Attoparsec easily beats any 'String' parser out there, but we do have to
--- be careful to convert the input to UTF-8 'ByteString's.
-{-# INLINEABLE timeParser #-}
-timeParser
-    :: TimeLocale
-        -- ^ Locale.
-    -> String
-        -- ^ Parser template spec string. See 'formatTime' for spec.
-    -> Parser TimeParse
-timeParser TimeLocale {..} = flip execStateT unixEpoch . go where
-
-    go :: String -> StateT TimeParse Parser ()
-    go spec = case spec of
-        '%' : cspec : rspec -> case cspec of
-            -- aggregate
-            'c' -> go (dateTimeFmt ++ rspec)
-            'r' -> go (time12Fmt ++ rspec)
-            'X' -> go (timeFmt ++ rspec)
-            'x' -> go (dateFmt ++ rspec)
-            'R' -> go ("%H:%M" ++ rspec)
-            'T' -> go ("%H:%M:%S" ++ rspec)
-            'D' -> go ("%m/%d/%y" ++ rspec)
-            'F' -> go ("%Y-%m-%d" ++ rspec)
-            -- AM/PM
-            'P' -> dayHalf
-            'p' -> dayHalf
-            -- Hour
-            'H' -> lift (dec0 2) >>= setHour24
-            'I' -> lift (dec0 2) >>= setHour12
-            'k' -> (lift (dec_ 2) >>= setHour24)
-                <|> (lift (dec_ 1) >>= setHour24)
-            'l' -> (lift (dec_ 2) >>= setHour12)
-                <|> (lift (dec_ 1) >>= setHour12)
-            -- Minute
-            'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec
-            -- Second
-            'S' -> lift (dec0 2) >>= assign _tpSecond >> go rspec
-            'q' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec
-            'v' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec
-            'Q' -> lift ((P.char '.' >> DiffTime <$> micro) <|> return zeroV)
-                >>= assign _tpSecFrac >> go rspec
-
-            -- Year
-            'Y' -> fullYear
-            'y' -> lift (dec0 2) >>= setCenturyYear
-            'C' -> lift (dec0 2) >>= setCentury
-            -- Month
-            'B' -> lift (indexOfCI $ fst <$> months) >>= setMonth . succ
-            'b' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ
-            'h' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ
-            'm' -> lift (dec0 2) >>= setMonth
-            -- DayOfMonth
-            'd' -> lift (dec0 2) >>= setDayOfMonth
-            'e' -> (lift (dec_ 2) >>= setDayOfMonth)
-                <|> (lift (dec_ 1) >>= setDayOfMonth)
-            -- DayOfYear
-            'j' -> lift (dec0 3) >>= assign _tpDayOfYear
-                >> flag IsOrdinalDate .= True >> go rspec
-
-            -- Year (WeekDate)
-            -- FIXME: problematic if input contains both %Y and %G
-            'G' -> flag IsWeekDate .= True >> fullYear
-            'g' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCenturyYear
-            'f' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCentury
-            -- WeekOfYear
-            -- FIXME: problematic if more than one of the following
-            'V' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setWeekOfYear
-            'U' -> flag IsSundayWeek .= True >> lift (dec0 2) >>= setWeekOfYear
-            'W' -> flag IsMondayWeek .= True >> lift (dec0 2) >>= setWeekOfYear
-            -- DayOfWeek
-            'w' -> lift (dec0 1) >>= setDayOfWeek
-            'u' -> lift (dec0 1) >>= setDayOfWeek
-            'A' -> lift (indexOfCI $ fst <$> wDays) >>= setDayOfWeek
-            'a' -> lift (indexOfCI $ snd <$> wDays) >>= setDayOfWeek
-
-            -- TimeZone
-            'z' -> do tzOffset; go rspec
-            'N' -> do tzOffset; go rspec
-            'Z' -> do tzOffset <|> tzName; go rspec
-            -- UTCTime
-            's' -> do
-                s <- lift (negative P.decimal)
-                _tpPOSIXTime .= fromSeconds (s :: Int64)
-                flag IsPOSIXTime .= True
-                go rspec
-
-            -- modifier (whatever)
-            '-' -> go ('%' : rspec)
-            '_' -> go ('%' : rspec)
-            '0' -> go ('%' : rspec)
-            -- escape (why would anyone need %t and %n?)
-            '%' -> lift (P.char '%') >> go rspec
-            _ -> lift . fail $ "Unknown format character: " ++ show cspec
-
-          where
-            dayHalf = do
-                pm <- lift $ False <$ stringCI (fst amPm)
-                    <|> True <$ stringCI (snd amPm)
-                flag PostMeridiem .= pm
-                flag TwelveHour .= True
-                go rspec
-            -- NOTE: if a greedy parse fails or causes a later failure,
-            -- then backtrack and only accept 4-digit years; see #5.
-            fullYear = year (negative P.decimal) <|> year (dec0 4) where
-                year p = do
-                    (c, y) <- (`divMod` 100) <$> lift p
-                    flag HasCentury .= True
-                    _tpCentury .= c
-                    _tpCenturyYear .= y
-                    go rspec
-            setHour12 h = do
-                flag TwelveHour .= True
-                _tpHour .= h
-                go rspec
-            setHour24 h = do
-                flag TwelveHour .= False
-                _tpHour .= h
-                go rspec
-            setCenturyYear y = do _tpCenturyYear .= y; go rspec
-            setCentury c = do
-                _tpCentury .= c
-                flag HasCentury .= True
-                go rspec
-            setMonth m = do
-                flag IsGregorian .= True
-                _tpMonth .= m
-                go rspec
-            setDayOfMonth d = do
-                flag IsGregorian .= True
-                _tpDayOfMonth .= d
-                go rspec
-            setWeekOfYear w = do _tpWeekOfYear .= w; go rspec
-            setDayOfWeek d = do _tpDayOfWeek .= d; go rspec
-            tzOffset = do
-                s <- lift (id <$ P.char '+' <|> negate <$ P.char '-')
-                h <- lift (dec0 2)
-                () <$ lift (P.char ':') <|> pure ()
-                m <- lift (dec0 2)
-                _tpTimeZone . _timeZoneMinutes .= s (h * 60 + m)
-            tzName = lift timeZoneParser >>= assign _tpTimeZone
-
-        c : rspec | P.isSpace c ->
-            lift (P.takeWhile P.isSpace) >> go (dropWhile P.isSpace rspec)
-        c : rspec | isAscii c -> lift (P.char c) >> go rspec
-        c : rspec -> lift (charU8 c) >> go rspec
-        "" -> return ()
-
-    {-# INLINE micro #-}
-    micro :: Parser Micro
-    micro = do
-        us10 <- either fail return . P.parseOnly P.decimal . S.take 7
-            . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit
-        return $ Micro (div (us10 + 5) 10)
-
-    {-# INLINE unixEpoch #-}
-    unixEpoch :: TimeParse
-    unixEpoch = TimeParse {..} where
-        tpCentury = 19
-        tpCenturyYear = 70
-        tpMonth = 1
-        tpWeekOfYear = 1
-        tpDayOfYear = 1
-        tpDayOfMonth = 1
-        tpDayOfWeek = 4
-        tpFlags = 0
-        tpHour = 0
-        tpMinute = 0
-        tpSecond = 0
-        tpSecFrac = zeroV
-        tpPOSIXTime = zeroV
-        tpTimeZone = utc
-
--- | Parse a string as a 'ParseTime' instance value.
---
--- Return 'Nothing' if parsing fails.
---
--- === Examples
---
--- ==== <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601>
--- @
--- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" "2015-01-15T12:34:56+00:00" :: 'Maybe' 'UTCTime'
---   Just 2015-01-15 12:34:56 UTC
---
--- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" "2015-01-15T12:34:56-12:00" :: 'Maybe' 'UTCTime'
---   Just 2015-01-16 00:34:56 UTC
--- @
---
--- ==== YYYY-MM-DD hh:mm:ss.0
--- @
--- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%d %H:%M:%S%Q" "2015-01-15 12:34:56.78" :: 'Maybe' 'UTCTime'
---   Just 2015-01-15 12:34:56.78 UTC
--- @
-{-# INLINEABLE parseTime #-}
-parseTime :: (ParseTime t)
-    => TimeLocale
-        -- ^ Locale.
-    -> String
-        -- ^ Parser template spec string. See 'formatTime' for spec.
-    -> String
-        -- ^ String value to be parsed as a 'ParseTime' instance value.
-    -> Maybe t
-parseTime l spec = either (const Nothing) Just
-        . P.parseOnly parser . utf8String where
-    parser = buildTime <$ P.skipSpace <*> timeParser l spec
-        <* P.skipSpace <* P.endOfInput
-
--- | Parse a string as a 'ParseTime' instance value.
---
--- Call 'error' if parsing fails.
-{-# INLINEABLE readTime #-}
-readTime :: (ParseTime t)
-    => TimeLocale
-        -- ^ Locale.
-    -> String
-        -- ^ Parser template spec string. See 'formatTime' for spec.
-    -> String
-        -- ^ String value to be parsed as a 'ParseTime' instance value.
-    -> t
-readTime l spec = either error id . P.parseOnly parser . utf8String where
-    parser = buildTime <$ P.skipSpace <*> timeParser l spec
-        <* P.skipSpace <* P.endOfInput
-
--- | Produce a 'ReadS' to parse a string as a 'ParseTime' instance value.
-{-# INLINEABLE readsTime #-}
-readsTime :: (ParseTime t)
-    => TimeLocale
-        -- ^ Locale.
-    -> String
-        -- ^ Parser template spec string. See 'formatTime' for spec.
-    -> ReadS t
-readsTime l spec = parserToReadS $
-    buildTime <$ P.skipSpace <*> timeParser l spec
-
-------------------------------------------------------------------------
-
-deriving instance Read UTCView
-#if SHOW_INTERNAL
-deriving instance Read Day
-deriving instance Read TimeOfDay
-deriving instance Read LocalTime
-deriving instance Read ZonedTime
-deriving instance Read TimeZone
-instance Read UTCTime where
-    {-# INLINE readsPrec #-}
-    readsPrec n = fmap (first $ review utcTime) . readsPrec n
-#else
-instance Read Day where
-    {-# INLINEABLE readsPrec #-}
-    readsPrec _ = readParen False $
-        readsTime defaultTimeLocale "%Y-%m-%d"
-
-instance Read TimeOfDay where
-    {-# INLINEABLE readsPrec #-}
-    readsPrec _ = readParen False $
-        readsTime defaultTimeLocale "%H:%M:%S%Q"
-
-instance Read LocalTime where
-    {-# INLINEABLE readsPrec #-}
-    readsPrec _ = readParen False $
-        readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q"
-
-instance Read ZonedTime where
-    {-# INLINEABLE readsPrec #-}
-    readsPrec _ = readParen False $
-        readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z"
-
-instance Read UTCTime where
-    {-# INLINEABLE readsPrec #-}
-    readsPrec _ = readParen False $
-        readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z"
-#endif
-
-------------------------------------------------------------------------
-
--- | All instances of this class may be parsed by 'parseTime', 'readTime', and
--- 'readsTime'.
-class ParseTime t where
-    buildTime :: TimeParse -> t
-
-instance ParseTime TimeOfDay where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = TimeOfDay h tpMinute
-            (fromSeconds tpSecond ^+^ tpSecFrac) where
-        h = case tp ^. flag TwelveHour of
-            False -> tpHour
-            True -> case tp ^. flag PostMeridiem of
-                False -> mod tpHour 12
-                True -> if tpHour < 12 then tpHour + 12 else tpHour
-
-{-# INLINE tpYear #-}
-tpYear :: TimeParse -> Year
-tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury
-    then tpCentury else if tpCenturyYear < 69 then 20 else 19
-
-instance ParseTime YearMonthDay where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = YearMonthDay (tpYear tp) tpMonth tpDayOfMonth
-
-instance ParseTime MonthDay where
-    {-# INLINE buildTime #-}
-    buildTime TimeParse {..} = MonthDay tpMonth tpDayOfMonth
-
-instance ParseTime OrdinalDate where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = OrdinalDate (tpYear tp) tpDayOfYear
-
-instance ParseTime WeekDate where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear
-        (if tpDayOfWeek == 0 then 7 else tpDayOfWeek)
-
-instance ParseTime SundayWeek where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = SundayWeek (tpYear tp) tpWeekOfYear
-        (if tpDayOfWeek == 7 then 0 else tpDayOfWeek)
-
-instance ParseTime MondayWeek where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = MondayWeek (tpYear tp) tpWeekOfYear
-        (if tpDayOfWeek == 0 then 7 else tpDayOfWeek)
-
-instance ParseTime LocalTime where
-    {-# INLINE buildTime #-}
-    buildTime = LocalTime <$> buildTime <*> buildTime
-
-instance ParseTime Day where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..}
-        | tp ^. flag IsOrdinalDate = ordinalDate # buildTime tp
-        | tp ^. flag IsGregorian = gregorian # buildTime tp
-        | tp ^. flag IsWeekDate = weekDate # buildTime tp
-        | tp ^. flag IsSundayWeek = sundayWeek # buildTime tp
-        | tp ^. flag IsMondayWeek = mondayWeek # buildTime tp
-        | otherwise = ordinalDate # buildTime tp
-        -- TODO: Better conflict handling when multiple flags are set?
-
-instance ParseTime TimeZone where
-    {-# INLINE buildTime #-}
-    buildTime = tpTimeZone
-
-instance ParseTime ZonedTime where
-    {-# INLINE buildTime #-}
-    buildTime = ZonedTime <$> buildTime <*> buildTime
-
-instance ParseTime UTCTime where
-    {-# INLINE buildTime #-}
-    buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime
-        then posixTime # tpPOSIXTime
-        else snd $ buildTime tp ^. from zonedTime
-
-instance ParseTime UniversalTime where
-    {-# INLINE buildTime #-}
-    buildTime (buildTime -> UTCRep t) = UniversalRep t
-
-instance ParseTime AbsoluteTime where
-    {-# INLINE buildTime #-}
-    buildTime tp = buildTime tp ^. absoluteTime (TAIUTCMap mempty mempty)
-
-------------------------------------------------------------------------
-
--- Dubiously pilfered from time-1.4.0.2
--- s/^.*-- \(.*\)\n.*\("[A-Z]\+"\).*"\([+-]\)\([0-9]\{2\}\):\([0-9]\{2\}\)", \(True\|False\).*$/    <|> zone \2 (($\3) \4 \5) \6 -- \1/
--- followed by !sort -r , because some names are prefixes of others.
-timeZoneParser :: Parser TimeZone
-timeZoneParser = zone "TAI" 0 False <|> zone "UT1" 0 False
-
-    <|> zone "ZULU" (($+) 00 00) False --  Same as UTC
-    <|> zone "Z" (($+) 00 00) False --  Same as UTC
-    <|> zone "YST" (($-) 09 00) False -- Yukon Standard Time
-    <|> zone "YDT" (($-) 08 00) True -- Yukon Daylight-Saving Time
-    <|> zone "WST" (($+) 08 00) False -- West Australian Standard Time
-    <|> zone "WETDST" (($+) 01 00) True -- Western European Daylight-Saving Time
-    <|> zone "WET" (($+) 00 00) False --  Western European Time
-    <|> zone "WDT" (($+) 09 00) True -- West Australian Daylight-Saving Time
-    <|> zone "WAT" (($-) 01 00) False -- West Africa Time
-    <|> zone "WAST" (($+) 07 00) False -- West Australian Standard Time
-    <|> zone "WADT" (($+) 08 00) True -- West Australian Daylight-Saving Time
-    <|> zone "UTC" (($+) 00 00) False --  Universal Coordinated Time
-    <|> zone "UT" (($+) 00 00) False --  Universal Time
-    <|> zone "TFT" (($+) 05 00) False -- Kerguelen Time
-    <|> zone "SWT" (($+) 01 00) False -- Swedish Winter Time
-    <|> zone "SST" (($+) 02 00) False -- Swedish Summer Time
-    <|> zone "SET" (($+) 01 00) False -- Seychelles Time
-    <|> zone "SCT" (($+) 04 00) False -- Mahe Island Time
-    <|> zone "SAST" (($+) 09 30) False -- South Australia Standard Time
-    <|> zone "SADT" (($+) 10 30) True -- South Australian Daylight-Saving Time
-    <|> zone "RET" (($+) 04 00) False -- Reunion Island Time
-    <|> zone "PST" (($-) 08 00) False -- Pacific Standard Time
-    <|> zone "PDT" (($-) 07 00) True -- Pacific Daylight-Saving Time
-    <|> zone "NZT" (($+) 12 00) False -- New Zealand Time
-    <|> zone "NZST" (($+) 12 00) False -- New Zealand Standard Time
-    <|> zone "NZDT" (($+) 13 00) True -- New Zealand Daylight-Saving Time
-    <|> zone "NT" (($-) 11 00) False -- Nome Time
-    <|> zone "NST" (($-) 03 30) False -- Newfoundland Standard Time
-    <|> zone "NOR" (($+) 01 00) False -- Norway Standard Time
-    <|> zone "NFT" (($-) 03 30) False -- Newfoundland Standard Time
-    <|> zone "NDT" (($-) 02 30) True -- Newfoundland Daylight-Saving Time
-    <|> zone "MVT" (($+) 05 00) False -- Maldives Island Time
-    <|> zone "MUT" (($+) 04 00) False -- Mauritius Island Time
-    <|> zone "MT" (($+) 08 30) False -- Moluccas Time
-    <|> zone "MST" (($-) 07 00) False -- Mountain Standard Time
-    <|> zone "MMT" (($+) 06 30) False -- Myanmar Time
-    <|> zone "MHT" (($+) 09 00) False -- Kwajalein Time
-    <|> zone "MEZ" (($+) 01 00) False -- Mitteleuropaeische Zeit
-    <|> zone "MEWT" (($+) 01 00) False -- Middle European Winter Time
-    <|> zone "METDST" (($+) 02 00) True -- Middle Europe Daylight-Saving Time
-    <|> zone "MET" (($+) 01 00) False -- Middle European Time
-    <|> zone "MEST" (($+) 02 00) False -- Middle European Summer Time
-    <|> zone "MDT" (($-) 06 00) True -- Mountain Daylight-Saving Time
-    <|> zone "MAWT" (($+) 06 00) False -- Mawson (Antarctica) Time
-    <|> zone "MART" (($-) 09 30) False -- Marquesas Time
-    <|> zone "LIGT" (($+) 10 00) False -- Melbourne, Australia
-    <|> zone "KST" (($+) 09 00) False -- Korea Standard Time
-    <|> zone "JT" (($+) 07 30) False -- Java Time
-    <|> zone "JST" (($+) 09 00) False -- Japan Standard Time, Russia zone 8
-    <|> zone "IT" (($+) 03 30) False -- Iran Time
-    <|> zone "IST" (($+) 02 00) False -- Israel Standard Time
-    <|> zone "IRT" (($+) 03 30) False -- Iran Time
-    <|> zone "IOT" (($+) 05 00) False -- Indian Chagos Time
-    <|> zone "IDLW" (($-) 12 00) False -- International Date Line, West
-    <|> zone "IDLE" (($+) 12 00) False -- International Date Line, East
-    <|> zone "HST" (($-) 10 00) False -- Hawaii Standard Time
-    <|> zone "HMT" (($+) 03 00) False -- Hellas Mediterranean Time (?)
-    <|> zone "HDT" (($-) 09 00) True -- Hawaii/Alaska Daylight-Saving Time
-    <|> zone "GST" (($+) 10 00) False -- Guam Standard Time, Russia zone 9
-    <|> zone "GMT" (($+) 00 00) False --  Greenwich Mean Time
-    <|> zone "FWT" (($+) 02 00) False -- French Winter Time
-    <|> zone "FST" (($+) 01 00) False -- French Summer Time
-    <|> zone "FNT" (($-) 02 00) False -- Fernando de Noronha Time
-    <|> zone "FNST" (($-) 01 00) False -- Fernando de Noronha Summer Time
-    <|> zone "EST" (($-) 05 00) False -- Eastern Standard Time
-    <|> zone "EETDST" (($+) 03 00) True -- Eastern Europe Daylight-Saving Time
-    <|> zone "EET" (($+) 02 00) False -- Eastern European Time, Russia zone 1
-    <|> zone "EDT" (($-) 04 00) True -- Eastern Daylight-Saving Time
-    <|> zone "EAT" (($+) 03 00) False -- Antananarivo, Comoro Time
-    <|> zone "EAST" (($+) 10 00) False -- East Australian Standard Time
-    <|> zone "EAST" (($+) 04 00) False -- Antananarivo Summer Time
-    <|> zone "DNT" (($+) 01 00) False -- Dansk Normal Tid
-    <|> zone "CXT" (($+) 07 00) False -- Christmas (Island) Time
-    <|> zone "CST" (($-) 06 00) False -- Central Standard Time
-    <|> zone "CETDST" (($+) 02 00) True -- Central European Daylight-Saving Time
-    <|> zone "CET" (($+) 01 00) False -- Central European Time
-    <|> zone "CEST" (($+) 02 00) False -- Central European Summer Time
-    <|> zone "CDT" (($-) 05 00) True -- Central Daylight-Saving Time
-    <|> zone "CCT" (($+) 08 00) False -- China Coastal Time
-    <|> zone "CAT" (($-) 10 00) False -- Central Alaska Time
-    <|> zone "CAST" (($+) 09 30) False -- Central Australia Standard Time
-    <|> zone "CADT" (($+) 10 30) True -- Central Australia Daylight-Saving Time
-    <|> zone "BT" (($+) 03 00) False -- Baghdad Time
-    <|> zone "BST" (($+) 01 00) False -- British Summer Time
-    <|> zone "BRT" (($-) 03 00) False -- Brasilia Time
-    <|> zone "BRST" (($-) 02 00) False -- Brasilia Summer Time
-    <|> zone "BDST" (($+) 02 00) False -- British Double Summer Time
-    <|> zone "AWT" (($-) 03 00) False -- (unknown)
-    <|> zone "AWST" (($+) 08 00) False -- Australia Western Standard Time
-    <|> zone "AWSST" (($+) 09 00) False -- Australia Western Summer Standard Time
-    <|> zone "AST" (($-) 04 00) False -- Atlantic Standard Time (Canada)
-    <|> zone "ALMT" (($+) 06 00) False -- Almaty Time
-    <|> zone "ALMST" (($+) 07 00) False -- Almaty Summer Time
-    <|> zone "AKST" (($-) 09 00) False -- Alaska Standard Time
-    <|> zone "AKDT" (($-) 08 00) True -- Alaska Daylight-Saving Time
-    <|> zone "AHST" (($-) 10 00) False -- Alaska/Hawaii Standard Time
-    <|> zone "AFT" (($+) 04 30) False -- Afghanistan Time
-    <|> zone "AEST" (($+) 10 00) False -- Australia Eastern Standard Time
-    <|> zone "AESST" (($+) 11 00) False -- Australia Eastern Summer Standard Time
-    <|> zone "ADT" (($-) 03 00) True -- Atlantic Daylight-Saving Time
-    <|> zone "ACT" (($-) 05 00) False -- Atlantic/Porto Acre Standard Time
-    <|> zone "ACST" (($-) 04 00) False -- Atlantic/Porto Acre Summer Time
-    <|> zone "ACSST" (($+) 10 30) False -- Central Australia Summer Standard Time
-
-  where
-    zone name offset dst = TimeZone offset dst name <$ P.string (S.pack name)
-    ($+) h m = h * 60 + m
-    ($-) h m = negate (h * 60 + m)
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}+#endif++#include "thyme.h"++-- | Formatting and parsing for dates and times.+module Data.Thyme.Format+    (+    -- * Formatting Date/Time to String+      FormatTime (..)+    , formatTime+    -- * Parsing Date/Time from String+    , ParseTime (..)+    , parseTime+    , readTime+    , readsTime+    , TimeParse (..)+    , timeParser++    -- * Time Locale+    , TimeLocale (..)+    , defaultTimeLocale+    ) where++import Prelude+import Control.Applicative+#if SHOW_INTERNAL+import Control.Arrow+#endif+import Control.Lens+import Control.Monad.Trans+import Control.Monad.State.Strict+import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as P+import Data.Bits+import qualified Data.ByteString.Char8 as S+import Data.Char+import Data.Int+import Data.Thyme.Internal.Micro+import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal+import Data.Thyme.Clock.Internal+import Data.Thyme.Clock.POSIX+import Data.Thyme.Clock.TAI+import Data.Thyme.Format.Internal+import Data.Thyme.LocalTime+import Data.VectorSpace++#if MIN_VERSION_time(1,5,0)+import Data.Time.Format (TimeLocale (..), defaultTimeLocale)+#else+import System.Locale+#endif++-- | All instances of this class may be formatted by 'formatTime'.+class FormatTime t where+    showsTime+        :: TimeLocale+        -> t+        -> (Char -> ShowS)+        -> Char+        -> ShowS+++-- TODO Here are the formatting codes from the @time@ library which are not+--      implemented.+--+-- [@%t@] tab+--+-- [@%n@] newline+--+-- === glibc-style modifiers can be used before the letter (here marked as @z@)+--+-- [@%-z@] no padding+--+-- [@%_z@] pad with spaces+--+-- [@%0z@] pad with zeros+--+-- [@%^z@] convert to upper case+--+-- [@%#z@] convert to lower case (consistently, unlike glibc)+--+-- === For 'UTCTime' and 'ZonedTime'+-- [@%s@] doesn't work for 'ZonedTime'+--+-- [@%Y@] Note __@%0Y@__ and __@%_Y@__ pad to four chars+--+-- [@%G@] Note __@%0G@__ and __@%_G@__ pad to four chars+--+-- [@%f@] Note __@%0f@__ and __@%_f@__ pad to two chars+--+-- [@%C@] Note __@%0C@__ and __@%_C@__ pad to two chars+--+--+-- TODO Format codes for week-of-month?+--+-- TODO It's impossible to print out an ordinal day of month or day of week+--      without padding. Implement the @time@ padding modifiers? Of course+--      the work-around, the 'Show' instance for 'Int', isn't too bad.+--+-- TODO drop the dependency on @old-locale@ for the TimeLocale type?++++-- | Format a 'FormatTime' instance value according to a template string.+--+-- These formatting template codes are intended to be compatible with+-- __@glibc@__ @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime()>@+-- function, following "Data.Time.Format", which+-- follows 'System.Time.formatCalendarTime' from the @old-time@ package.+-- Codes which differ from @strftime()@ are marked as+-- /EXTENSION/.+--+-- == Show/Parse template string spec+--+-- === For all types+--+-- [@%%@] literal @\"%\"@+--+-- === For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):+--+-- [@%z@] RFC 822/ISO 8601:1988 style numeric time zone (e.g., @\"-0600\"@ or @\"+0100\"@)+--+-- [@%N@] ISO 8601 style numeric time zone (e.g., @\"-06:00\"@ or @\"+01:00\"@) /EXTENSION/+--+-- [@%Z@] timezone name+--+-- === For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime')+--+-- [@%c@] The preferred calendar time representation for the current locale. As 'dateTimeFmt' @locale@ (e.g. __@%a %b %e %H:%M:%S %Z %Y@__)+--+-- === For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime')+--+-- [@%R@] same as __@%H:%M@__+--+-- [@%T@] same as __@%H:%M:%S@__+--+-- [@%X@] The preferred time of day representation for the current locale. As 'timeFmt' @locale@ (e.g. __@%H:%M:%S@__)+--+-- [@%r@] The complete calendar time using the AM/PM format of the current locale. As 'time12Fmt' @locale@ (e.g. __@%I:%M:%S %p@__)+--+-- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @\"am\"@, @\"pm\"@+--+-- [@%p@] day-half of day from ('amPm' @locale@), @\"AM\"@, @\"PM\"@+--+-- [@%H@] hour of day (24-hour), 0-padded to two chars, @\"00\"@–@\"23\"@+--+-- [@%k@] hour of day (24-hour), space-padded to two chars, @\" 0\"@–@\"23\"@+--+-- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @\"01\"@–@\"12\"@+--+-- [@%l@] hour of day-half (12-hour), space-padded to two chars, @\" 1\"@–@\"12\"@+--+-- [@%M@] minute of hour, 0-padded to two chars, @\"00\"@–@\"59\"@+--+-- [@%S@] second of minute (without decimal part), 0-padded to two chars, @\"00\"@–@\"60\"@+--+-- [@%q@] picosecond of second, 0-padded to twelve chars, @\"000000000000\"@–@\"999999999999\"@. /EXTENSION/+--+-- [@%v@] microsecond of second, 0-padded to six chars, @\"000000\"@–@\"999999\"@. /EXTENSION/+--+-- [@%Q@] decimal point and fraction of second, up to 6 second decimals, without trailing zeros.+--        For a whole number of seconds, __@%Q@__ produces the empty string. /EXTENSION/+--+-- === For 'UTCTime'+--+-- [@%s@] number of whole seconds since the Unix epoch. For times before+-- the Unix epoch, this is a negative number. Note that in __@%s.%q@__ and __@%s%Q@__+-- the decimals are positive, not negative. For example, 0.9 seconds+-- before the Unix epoch is formatted as @\"-1.1\"@ with __@%s%Q@__.+--+-- === For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime')+--+-- [@%D@] same as __@%m\/%d\/%y@__+--+-- [@%F@] same as __@%Y-%m-%d@__+--+-- [@%x@] as 'dateFmt' @locale@ (e.g. __@%m\/%d\/%y@__)+--+-- [@%Y@] year, no padding.+--+-- [@%y@] year of century, 0-padded to two chars, @\"00\"@–@\"99\"@+--+-- [@%C@] century, no padding.+--+-- [@%B@] month name, long form ('fst' from 'months' @locale@), @\"January\"@–@\"December\"@+--+-- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @\"Jan\"@–@\"Dec\"@+--+-- [@%m@] month of year, 0-padded to two chars, @\"01\"@–@\"12\"@+--+-- [@%d@] day of month, 0-padded to two chars, @\"01\"@–@\"31\"@+--+-- [@%e@] day of month, space-padded to two chars, @\" 1\"@–@\"31\"@+--+-- [@%j@] day of year, 0-padded to three chars, @\"001\"@–@\"366\"@+--+-- [@%G@] year for Week Date format, no padding.+--+-- [@%g@] year of century for Week Date format, 0-padded to two chars, @\"00\"@–@\"99\"@+--+-- [@%f@] century for Week Date format, no padding. /EXTENSION/+--+-- [@%V@] week of year for Week Date format, 0-padded to two chars, @\"01\"@–@\"53\"@+--+-- [@%u@] day of week for Week Date format, @\"1\"@–@\"7\"@+--+-- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @\"Sun\"@–@\"Sat\"@+--+-- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @\"Sunday\"@–@\"Saturday\"@+--+-- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @\"00\"@–@\"53\"@+--+-- [@%w@] day of week number, @\"0\"@ (= Sunday) – @\"6\"@ (= Saturday)+--+-- [@%W@] week of year where weeks start on Monday (as 'Data.Thyme.Calendar.WeekdayOfMonth.mondayStartWeek'), 0-padded to two chars, @\"00\"@–@\"53\"@+--+-- == Examples+--+-- ==== <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601>+-- @+-- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" $ 'mkUTCTime' 2015 1 15  12 34 56.78+-- "2015-01-15T12:34:56+00:00"+-- @+--+-- ==== <http://tools.ietf.org/html/rfc822#section-5 RFC822>+-- @+-- > 'formatTime' 'defaultTimeLocale' "%a, %_d %b %Y %H:%M:%S %Z" $ 'mkUTCTime' 2015 1 15  12 34 56.78+-- "Thu, 15 Jan 2015 12:34:56 UTC"+-- @+--+-- ==== YYYY-MM-DD hh:mm:ss.000000+-- @+-- > 'formatTime' 'defaultTimeLocale' "%Y-%m-%d %H:%M:%S.%v" $ 'mkUTCTime' 2015 1 15  12 34 56.78+-- "2015-01-15 12:34:56.780000"+-- @+{-# INLINEABLE formatTime #-}+formatTime :: (FormatTime t)+    => TimeLocale+        -- ^ Locale for formatting.+    -> String+        -- ^ Template spec string.+    -> t+        -- ^ 'FormatTime' instance value to be formatted.+    -> String+formatTime l@TimeLocale {..} spec t = go spec "" where+    -- leave unrecognised codes as they are+    format = showsTime l t (\ c s -> '%' : c : s)+    go s = case s of+        '%' : c : rest -> case c of+            -- aggregate+            'c' -> go (dateTimeFmt ++ rest)+            'r' -> go (time12Fmt ++ rest)+            'X' -> go (timeFmt ++ rest)+            'x' -> go (dateFmt ++ rest)+            -- modifier (whatever)+            '-' -> go ('%' : rest)+            '_' -> go ('%' : rest)+            '0' -> go ('%' : rest)+            '^' -> go ('%' : rest)+            '#' -> go ('%' : rest)+            -- escape (why would anyone need %t and %n?)+            '%' -> (:) '%' . go rest+            -- default+            _ -> format c . go rest+        c : rest -> (:) c . go rest+        [] -> id++-- | 'ShowS' a year with a minimum of four digits (even in the first+-- millennium), to comply with+-- <https://en.wikipedia.org/wiki/ISO_8601#Years ISO 8601 Years>.+{-# INLINE showsY #-}+showsY :: Year -> ShowS+#if BUG_FOR_BUG+showsY = shows+#else+-- ISO 8601 says minimum of 4 digits, even for first millennium.+showsY = showsYear+#endif++instance FormatTime TimeOfDay where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale{..} (TimeOfDay h m (DiffTime s)) = \ def c -> case c of+        -- aggregate+        'R' -> shows02 h . (:) ':' . shows02 m+        'T' -> shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 si+        -- AM/PM+        'P' -> (++) $ toLower <$> if h < 12 then fst amPm else snd amPm+        'p' -> (++) $ if h < 12 then fst amPm else snd amPm+        -- Hour+        'H' -> shows02 h+        'I' -> shows02 $ 1 + mod (h - 1) 12+        'k' -> shows_2 h+        'l' -> shows_2 $ 1 + mod (h - 1) 12+        -- Minute+        'M' -> shows02 m+        -- Second+        'S' -> shows02 si+        'q' -> fills06 su . shows su . (++) "000000"+        'v' -> fills06 su . shows su+        'Q' -> if su == 0 then id else (:) '.' . fills06 su . drops0 su+        -- default+        _ -> def c+        where (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000)++instance FormatTime YearMonthDay where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale {..} (YearMonthDay y m d) = \ def c -> case c of+        -- aggregate+        'D' -> shows02 m . (:) '/' . shows02 d . (:) '/' . shows02 (mod y 100)+        'F' -> showsY y . (:) '-' . shows02 m . (:) '-' . shows02 d+        -- Year+        'Y' -> showsY y+        'y' -> shows02 (mod y 100)+        'C' -> shows02 (div y 100)+        -- Month+        'B' -> (++) . fst $ months !! (m - 1)+        'b' -> (++) . snd $ months !! (m - 1)+        'h' -> (++) . snd $ months !! (m - 1)+        'm' -> shows02 m+        -- DayOfMonth+        'd' -> shows02 d+        'e' -> shows_2 d+        -- default+        _ -> def c++instance FormatTime MonthDay where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale {..} (MonthDay m d) = \ def c -> case c of+        -- Month+        'B' -> (++) . fst $ months !! (m - 1)+        'b' -> (++) . snd $ months !! (m - 1)+        'h' -> (++) . snd $ months !! (m - 1)+        'm' -> shows02 m+        -- DayOfMonth+        'd' -> shows02 d+        'e' -> shows_2 d+        -- default+        _ -> def c++instance FormatTime OrdinalDate where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale {..} (OrdinalDate y d) = \ def c -> case c of+        -- Year+        'Y' -> showsY y+        'y' -> shows02 (mod y 100)+        'C' -> shows02 (div y 100)+        -- DayOfYear+        'j' -> shows03 d+        -- default+        _ -> def c++instance FormatTime WeekDate where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of+        -- Year+        'G' -> showsY y+        'g' -> shows02 (mod y 100)+        'f' -> shows02 (div y 100)+        -- WeekOfYear+        'V' -> shows02 w+        -- DayOfWeek+        'u' -> shows $ if d == 0 then 7 else d+        'w' -> shows $ if d == 7 then 0 else d+        'A' -> (++) . fst $ wDays !! mod d 7+        'a' -> (++) . snd $ wDays !! mod d 7+        -- default+        _ -> def c++instance FormatTime SundayWeek where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale {..} (SundayWeek y w d) = \ def c -> case c of+        -- Year+        'Y' -> showsY y+        'y' -> shows02 (mod y 100)+        'C' -> shows02 (div y 100)+        -- WeekOfYear+        'U' -> shows02 w+        -- DayOfWeek+        'u' -> shows $ if d == 0 then 7 else d+        'w' -> shows $ if d == 7 then 0 else d+        'A' -> (++) . fst $ wDays !! mod d 7+        'a' -> (++) . snd $ wDays !! mod d 7+        -- default+        _ -> def c++instance FormatTime MondayWeek where+    {-# INLINEABLE showsTime #-}+    showsTime TimeLocale {..} (MondayWeek y w d) = \ def c -> case c of+        -- Year+        'Y' -> showsY y+        'y' -> shows02 (mod y 100)+        'C' -> shows02 (div y 100)+        -- WeekOfYear+        'W' -> shows02 w+        -- DayOfWeek+        'u' -> shows $ if d == 0 then 7 else d+        'w' -> shows $ if d == 7 then 0 else d+        'A' -> (++) . fst $ wDays !! mod d 7+        'a' -> (++) . snd $ wDays !! mod d 7+        -- default+        _ -> def c++instance FormatTime LocalTime where+    {-# INLINEABLE showsTime #-}+    showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod++instance FormatTime Day where+    {-# INLINEABLE showsTime #-}+    showsTime l d@(view ordinalDate -> ordinal)+        = showsTime l ordinal+        . showsTime l (ordinal ^. yearMonthDay)+        . showsTime l (toWeekOrdinal ordinal d)+        . showsTime l (toSundayOrdinal ordinal d)+        . showsTime l (toMondayOrdinal ordinal d)++instance FormatTime TimeZone where+    {-# INLINEABLE showsTime #-}+    showsTime _ tz@(TimeZone _ _ name) = \ def c -> case c of+        'z' -> (++) (timeZoneOffsetString tz)+        'N' -> (++) (timeZoneOffsetStringColon tz)+        'Z' -> (++) (if null name then timeZoneOffsetString tz else name)+        _ -> def c++instance FormatTime ZonedTime where+    {-# INLINEABLE showsTime #-}+    showsTime l (ZonedTime lt tz) = showsTime l lt . showsTime l tz++instance FormatTime UTCTime where+    {-# INLINEABLE showsTime #-}+    showsTime l t = \ def c -> case c of+        's' -> shows . fst $ qr s (Micro 1000000)+        _ -> showsTime l ((utc, t) ^. zonedTime) def c+      where+        NominalDiffTime s = t ^. posixTime+#if BUG_FOR_BUG+        qr = microDivMod -- rounds down+#else+        qr = microQuotRem -- rounds to 0+#endif++instance FormatTime UniversalTime where+    {-# INLINEABLE showsTime #-}+    showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "UT1"} where+        lt = t ^. ut1LocalTime 0++instance FormatTime AbsoluteTime where+    {-# INLINEABLE showsTime #-}+    showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "TAI"} where+        lt = t ^. from (absoluteTime tum) . utcLocalTime utc+        tum = TAIUTCMap mempty mempty++------------------------------------------------------------------------++data TimeFlag+    = PostMeridiem+    | TwelveHour+    | HasCentury+    | IsPOSIXTime+    | IsOrdinalDate+    | IsGregorian+    | IsWeekDate+    | IsSundayWeek+    | IsMondayWeek+    deriving (Enum, Show)++-- | Unconstituted date-time for parsing.+data TimeParse = TimeParse+    { tpCentury :: {-# UNPACK #-}!Int+    , tpCenturyYear :: {-# UNPACK #-}!Int{-YearOfCentury-}+    , tpMonth :: {-# UNPACK #-}!Month+    , tpWeekOfYear :: {-# UNPACK #-}!WeekOfYear+    , tpDayOfMonth :: {-# UNPACK #-}!DayOfMonth+    , tpDayOfYear :: {-# UNPACK #-}!DayOfYear+    , tpDayOfWeek :: {-# UNPACK #-}!DayOfWeek+    , tpFlags :: {-# UNPACK #-}!Int{-BitSet TimeFlag-}+    , tpHour :: {-# UNPACK #-}!Hour+    , tpMinute :: {-# UNPACK #-}!Minute+    , tpSecond :: {-# UNPACK #-}!Int+    , tpSecFrac :: {-# UNPACK #-}!DiffTime+    , tpPOSIXTime :: {-# UNPACK #-}!POSIXTime+    , tpTimeZone :: !TimeZone+    } deriving (Show)++LENS(TimeParse,tpCentury,Int)+LENS(TimeParse,tpCenturyYear,Int{-YearOfCentury-})+LENS(TimeParse,tpMonth,Month)+LENS(TimeParse,tpWeekOfYear,WeekOfYear)+LENS(TimeParse,tpDayOfMonth,DayOfMonth)+LENS(TimeParse,tpDayOfWeek,DayOfWeek)+LENS(TimeParse,tpDayOfYear,DayOfYear)+LENS(TimeParse,tpFlags,Int{-BitSet TimeFlag-})+LENS(TimeParse,tpHour,Hour)+LENS(TimeParse,tpMinute,Minute)+LENS(TimeParse,tpSecond,Int)+LENS(TimeParse,tpSecFrac,DiffTime)+LENS(TimeParse,tpPOSIXTime,POSIXTime)+LENS(TimeParse,tpTimeZone,TimeZone)++{-# INLINE flag #-}+flag :: TimeFlag -> Lens' TimeParse Bool+flag (fromEnum -> f) = _tpFlags . lens+    (`testBit` f) (\ n b -> (if b then setBit else clearBit) n f)++-- | Produce a 'Parser' for UTF-8 encoded 'ByteString's.+--+-- This function is used internally by 'parseTime', 'readTime', and 'readsTime';+-- consider using one of those functions instead.+--+-- Attoparsec easily beats any 'String' parser out there, but we do have to+-- be careful to convert the input to UTF-8 'ByteString's.+{-# INLINEABLE timeParser #-}+timeParser+    :: TimeLocale+        -- ^ Locale.+    -> String+        -- ^ Parser template spec string. See 'formatTime' for spec.+    -> Parser TimeParse+timeParser TimeLocale {..} = flip execStateT unixEpoch . go where++    go :: String -> StateT TimeParse Parser ()+    go spec = case spec of+        '%' : cspec : rspec -> case cspec of+            -- aggregate+            'c' -> go (dateTimeFmt ++ rspec)+            'r' -> go (time12Fmt ++ rspec)+            'X' -> go (timeFmt ++ rspec)+            'x' -> go (dateFmt ++ rspec)+            'R' -> go ("%H:%M" ++ rspec)+            'T' -> go ("%H:%M:%S" ++ rspec)+            'D' -> go ("%m/%d/%y" ++ rspec)+            'F' -> go ("%Y-%m-%d" ++ rspec)+            -- AM/PM+            'P' -> dayHalf+            'p' -> dayHalf+            -- Hour+            'H' -> lift (dec0 2) >>= setHour24+            'I' -> lift (dec0 2) >>= setHour12+            'k' -> (lift (dec_ 2) >>= setHour24)+                <|> (lift (dec_ 1) >>= setHour24)+            'l' -> (lift (dec_ 2) >>= setHour12)+                <|> (lift (dec_ 1) >>= setHour12)+            -- Minute+            'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec+            -- Second+            'S' -> lift (dec0 2) >>= assign _tpSecond >> go rspec+            'q' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec+            'v' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec+            'Q' -> lift ((P.char '.' >> DiffTime <$> micro) <|> return zeroV)+                >>= assign _tpSecFrac >> go rspec++            -- Year+            'Y' -> fullYear+            'y' -> lift (dec0 2) >>= setCenturyYear+            'C' -> lift (dec0 2) >>= setCentury+            -- Month+            'B' -> lift (indexOfCI $ fst <$> months) >>= setMonth . succ+            'b' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ+            'h' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ+            'm' -> lift (dec0 2) >>= setMonth+            -- DayOfMonth+            'd' -> lift (dec0 2) >>= setDayOfMonth+            'e' -> (lift (dec_ 2) >>= setDayOfMonth)+                <|> (lift (dec_ 1) >>= setDayOfMonth)+            -- DayOfYear+            'j' -> lift (dec0 3) >>= assign _tpDayOfYear+                >> flag IsOrdinalDate .= True >> go rspec++            -- Year (WeekDate)+            -- FIXME: problematic if input contains both %Y and %G+            'G' -> flag IsWeekDate .= True >> fullYear+            'g' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCenturyYear+            'f' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCentury+            -- WeekOfYear+            -- FIXME: problematic if more than one of the following+            'V' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setWeekOfYear+            'U' -> flag IsSundayWeek .= True >> lift (dec0 2) >>= setWeekOfYear+            'W' -> flag IsMondayWeek .= True >> lift (dec0 2) >>= setWeekOfYear+            -- DayOfWeek+            'w' -> lift (dec0 1) >>= setDayOfWeek+            'u' -> lift (dec0 1) >>= setDayOfWeek+            'A' -> lift (indexOfCI $ fst <$> wDays) >>= setDayOfWeek+            'a' -> lift (indexOfCI $ snd <$> wDays) >>= setDayOfWeek++            -- TimeZone+            'z' -> do tzOffset; go rspec+            'N' -> do tzOffset; go rspec+            'Z' -> do tzOffset <|> tzName; go rspec+            -- UTCTime+            's' -> do+                s <- lift (negative P.decimal)+                _tpPOSIXTime .= fromSeconds (s :: Int64)+                flag IsPOSIXTime .= True+                go rspec++            -- modifier (whatever)+            '-' -> go ('%' : rspec)+            '_' -> go ('%' : rspec)+            '0' -> go ('%' : rspec)+            -- escape (why would anyone need %t and %n?)+            '%' -> lift (P.char '%') >> go rspec+            _ -> lift . fail $ "Unknown format character: " ++ show cspec++          where+            dayHalf = do+                pm <- lift $ False <$ stringCI (fst amPm)+                    <|> True <$ stringCI (snd amPm)+                flag PostMeridiem .= pm+                flag TwelveHour .= True+                go rspec+            -- NOTE: if a greedy parse fails or causes a later failure,+            -- then backtrack and only accept 4-digit years; see #5.+            fullYear = year (negative P.decimal) <|> year (dec0 4) where+                year p = do+                    (c, y) <- (`divMod` 100) <$> lift p+                    flag HasCentury .= True+                    _tpCentury .= c+                    _tpCenturyYear .= y+                    go rspec+            setHour12 h = do+                flag TwelveHour .= True+                _tpHour .= h+                go rspec+            setHour24 h = do+                flag TwelveHour .= False+                _tpHour .= h+                go rspec+            setCenturyYear y = do _tpCenturyYear .= y; go rspec+            setCentury c = do+                _tpCentury .= c+                flag HasCentury .= True+                go rspec+            setMonth m = do+                flag IsGregorian .= True+                _tpMonth .= m+                go rspec+            setDayOfMonth d = do+                flag IsGregorian .= True+                _tpDayOfMonth .= d+                go rspec+            setWeekOfYear w = do _tpWeekOfYear .= w; go rspec+            setDayOfWeek d = do _tpDayOfWeek .= d; go rspec+            tzOffset = do+                s <- lift (id <$ P.char '+' <|> negate <$ P.char '-')+                h <- lift (dec0 2)+                () <$ lift (P.char ':') <|> pure ()+                m <- lift (dec0 2)+                _tpTimeZone . _timeZoneMinutes .= s (h * 60 + m)+            tzName = lift timeZoneParser >>= assign _tpTimeZone++        c : rspec | P.isSpace c ->+            lift (P.takeWhile P.isSpace) >> go (dropWhile P.isSpace rspec)+        c : rspec | isAscii c -> lift (P.char c) >> go rspec+        c : rspec -> lift (charU8 c) >> go rspec+        "" -> return ()++    {-# INLINE micro #-}+    micro :: Parser Micro+    micro = do+        us10 <- either fail return . P.parseOnly P.decimal . S.take 7+            . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit+        return $ Micro (div (us10 + 5) 10)++    {-# INLINE unixEpoch #-}+    unixEpoch :: TimeParse+    unixEpoch = TimeParse {..} where+        tpCentury = 19+        tpCenturyYear = 70+        tpMonth = 1+        tpWeekOfYear = 1+        tpDayOfYear = 1+        tpDayOfMonth = 1+        tpDayOfWeek = 4+        tpFlags = 0+        tpHour = 0+        tpMinute = 0+        tpSecond = 0+        tpSecFrac = zeroV+        tpPOSIXTime = zeroV+        tpTimeZone = utc++-- | Parse a string as a 'ParseTime' instance value.+--+-- Return 'Nothing' if parsing fails.+--+-- === Examples+--+-- ==== <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601>+-- @+-- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" "2015-01-15T12:34:56+00:00" :: 'Maybe' 'UTCTime'+--   Just 2015-01-15 12:34:56 UTC+--+-- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%dT%H:%M:%S%N" "2015-01-15T12:34:56-12:00" :: 'Maybe' 'UTCTime'+--   Just 2015-01-16 00:34:56 UTC+-- @+--+-- ==== YYYY-MM-DD hh:mm:ss.0+-- @+-- > 'parseTime' 'defaultTimeLocale' "%Y-%m-%d %H:%M:%S%Q" "2015-01-15 12:34:56.78" :: 'Maybe' 'UTCTime'+--   Just 2015-01-15 12:34:56.78 UTC+-- @+{-# INLINEABLE parseTime #-}+parseTime :: (ParseTime t)+    => TimeLocale+        -- ^ Locale.+    -> String+        -- ^ Parser template spec string. See 'formatTime' for spec.+    -> String+        -- ^ String value to be parsed as a 'ParseTime' instance value.+    -> Maybe t+parseTime l spec = either (const Nothing) Just+        . P.parseOnly parser . utf8String where+    parser = buildTime <$ P.skipSpace <*> timeParser l spec+        <* P.skipSpace <* P.endOfInput++-- | Parse a string as a 'ParseTime' instance value.+--+-- Call 'error' if parsing fails.+{-# INLINEABLE readTime #-}+readTime :: (ParseTime t)+    => TimeLocale+        -- ^ Locale.+    -> String+        -- ^ Parser template spec string. See 'formatTime' for spec.+    -> String+        -- ^ String value to be parsed as a 'ParseTime' instance value.+    -> t+readTime l spec = either error id . P.parseOnly parser . utf8String where+    parser = buildTime <$ P.skipSpace <*> timeParser l spec+        <* P.skipSpace <* P.endOfInput++-- | Produce a 'ReadS' to parse a string as a 'ParseTime' instance value.+{-# INLINEABLE readsTime #-}+readsTime :: (ParseTime t)+    => TimeLocale+        -- ^ Locale.+    -> String+        -- ^ Parser template spec string. See 'formatTime' for spec.+    -> ReadS t+readsTime l spec = parserToReadS $+    buildTime <$ P.skipSpace <*> timeParser l spec++------------------------------------------------------------------------++deriving instance Read UTCView+#if SHOW_INTERNAL+deriving instance Read Day+deriving instance Read TimeOfDay+deriving instance Read LocalTime+deriving instance Read ZonedTime+deriving instance Read TimeZone+instance Read UTCTime where+    {-# INLINE readsPrec #-}+    readsPrec n = fmap (first $ review utcTime) . readsPrec n+#else+instance Read Day where+    {-# INLINEABLE readsPrec #-}+    readsPrec _ = readParen False $+        readsTime defaultTimeLocale "%Y-%m-%d"++instance Read TimeOfDay where+    {-# INLINEABLE readsPrec #-}+    readsPrec _ = readParen False $+        readsTime defaultTimeLocale "%H:%M:%S%Q"++instance Read LocalTime where+    {-# INLINEABLE readsPrec #-}+    readsPrec _ = readParen False $+        readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q"++instance Read ZonedTime where+    {-# INLINEABLE readsPrec #-}+    readsPrec _ = readParen False $+        readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z"++instance Read UTCTime where+    {-# INLINEABLE readsPrec #-}+    readsPrec _ = readParen False $+        readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z"+#endif++------------------------------------------------------------------------++-- | All instances of this class may be parsed by 'parseTime', 'readTime', and+-- 'readsTime'.+class ParseTime t where+    buildTime :: TimeParse -> t++instance ParseTime TimeOfDay where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = TimeOfDay h tpMinute+            (fromSeconds tpSecond ^+^ tpSecFrac) where+        h = case tp ^. flag TwelveHour of+            False -> tpHour+            True -> case tp ^. flag PostMeridiem of+                False -> mod tpHour 12+                True -> if tpHour < 12 then tpHour + 12 else tpHour++{-# INLINE tpYear #-}+tpYear :: TimeParse -> Year+tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury+    then tpCentury else if tpCenturyYear < 69 then 20 else 19++instance ParseTime YearMonthDay where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = YearMonthDay (tpYear tp) tpMonth tpDayOfMonth++instance ParseTime MonthDay where+    {-# INLINE buildTime #-}+    buildTime TimeParse {..} = MonthDay tpMonth tpDayOfMonth++instance ParseTime OrdinalDate where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = OrdinalDate (tpYear tp) tpDayOfYear++instance ParseTime WeekDate where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear+        (if tpDayOfWeek == 0 then 7 else tpDayOfWeek)++instance ParseTime SundayWeek where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = SundayWeek (tpYear tp) tpWeekOfYear+        (if tpDayOfWeek == 7 then 0 else tpDayOfWeek)++instance ParseTime MondayWeek where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = MondayWeek (tpYear tp) tpWeekOfYear+        (if tpDayOfWeek == 0 then 7 else tpDayOfWeek)++instance ParseTime LocalTime where+    {-# INLINE buildTime #-}+    buildTime = LocalTime <$> buildTime <*> buildTime++instance ParseTime Day where+    {-# INLINE buildTime #-}+    buildTime tp+        | tp ^. flag IsOrdinalDate = ordinalDate # buildTime tp+        | tp ^. flag IsGregorian = gregorian # buildTime tp+        | tp ^. flag IsWeekDate = weekDate # buildTime tp+        | tp ^. flag IsSundayWeek = sundayWeek # buildTime tp+        | tp ^. flag IsMondayWeek = mondayWeek # buildTime tp+        | otherwise = ordinalDate # buildTime tp+        -- TODO: Better conflict handling when multiple flags are set?++instance ParseTime TimeZone where+    {-# INLINE buildTime #-}+    buildTime = tpTimeZone++instance ParseTime ZonedTime where+    {-# INLINE buildTime #-}+    buildTime = ZonedTime <$> buildTime <*> buildTime++instance ParseTime UTCTime where+    {-# INLINE buildTime #-}+    buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime+        then posixTime # tpPOSIXTime+        else snd $ buildTime tp ^. from zonedTime++instance ParseTime UniversalTime where+    {-# INLINE buildTime #-}+    buildTime (buildTime -> UTCRep t) = UniversalRep t++instance ParseTime AbsoluteTime where+    {-# INLINE buildTime #-}+    buildTime tp = buildTime tp ^. absoluteTime (TAIUTCMap mempty mempty)++------------------------------------------------------------------------++-- Dubiously pilfered from time-1.4.0.2+-- s/^.*-- \(.*\)\n.*\("[A-Z]\+"\).*"\([+-]\)\([0-9]\{2\}\):\([0-9]\{2\}\)", \(True\|False\).*$/    <|> zone \2 (($\3) \4 \5) \6 -- \1/+-- followed by !sort -r , because some names are prefixes of others.+timeZoneParser :: Parser TimeZone+timeZoneParser = zone "TAI" 0 False <|> zone "UT1" 0 False++    <|> zone "ZULU" (($+) 00 00) False --  Same as UTC+    <|> zone "Z" (($+) 00 00) False --  Same as UTC+    <|> zone "YST" (($-) 09 00) False -- Yukon Standard Time+    <|> zone "YDT" (($-) 08 00) True -- Yukon Daylight-Saving Time+    <|> zone "WST" (($+) 08 00) False -- West Australian Standard Time+    <|> zone "WETDST" (($+) 01 00) True -- Western European Daylight-Saving Time+    <|> zone "WET" (($+) 00 00) False --  Western European Time+    <|> zone "WDT" (($+) 09 00) True -- West Australian Daylight-Saving Time+    <|> zone "WAT" (($-) 01 00) False -- West Africa Time+    <|> zone "WAST" (($+) 07 00) False -- West Australian Standard Time+    <|> zone "WADT" (($+) 08 00) True -- West Australian Daylight-Saving Time+    <|> zone "UTC" (($+) 00 00) False --  Universal Coordinated Time+    <|> zone "UT" (($+) 00 00) False --  Universal Time+    <|> zone "TFT" (($+) 05 00) False -- Kerguelen Time+    <|> zone "SWT" (($+) 01 00) False -- Swedish Winter Time+    <|> zone "SST" (($+) 02 00) False -- Swedish Summer Time+    <|> zone "SET" (($+) 01 00) False -- Seychelles Time+    <|> zone "SCT" (($+) 04 00) False -- Mahe Island Time+    <|> zone "SAST" (($+) 09 30) False -- South Australia Standard Time+    <|> zone "SADT" (($+) 10 30) True -- South Australian Daylight-Saving Time+    <|> zone "RET" (($+) 04 00) False -- Reunion Island Time+    <|> zone "PST" (($-) 08 00) False -- Pacific Standard Time+    <|> zone "PDT" (($-) 07 00) True -- Pacific Daylight-Saving Time+    <|> zone "NZT" (($+) 12 00) False -- New Zealand Time+    <|> zone "NZST" (($+) 12 00) False -- New Zealand Standard Time+    <|> zone "NZDT" (($+) 13 00) True -- New Zealand Daylight-Saving Time+    <|> zone "NT" (($-) 11 00) False -- Nome Time+    <|> zone "NST" (($-) 03 30) False -- Newfoundland Standard Time+    <|> zone "NOR" (($+) 01 00) False -- Norway Standard Time+    <|> zone "NFT" (($-) 03 30) False -- Newfoundland Standard Time+    <|> zone "NDT" (($-) 02 30) True -- Newfoundland Daylight-Saving Time+    <|> zone "MVT" (($+) 05 00) False -- Maldives Island Time+    <|> zone "MUT" (($+) 04 00) False -- Mauritius Island Time+    <|> zone "MT" (($+) 08 30) False -- Moluccas Time+    <|> zone "MST" (($-) 07 00) False -- Mountain Standard Time+    <|> zone "MMT" (($+) 06 30) False -- Myanmar Time+    <|> zone "MHT" (($+) 09 00) False -- Kwajalein Time+    <|> zone "MEZ" (($+) 01 00) False -- Mitteleuropaeische Zeit+    <|> zone "MEWT" (($+) 01 00) False -- Middle European Winter Time+    <|> zone "METDST" (($+) 02 00) True -- Middle Europe Daylight-Saving Time+    <|> zone "MET" (($+) 01 00) False -- Middle European Time+    <|> zone "MEST" (($+) 02 00) False -- Middle European Summer Time+    <|> zone "MDT" (($-) 06 00) True -- Mountain Daylight-Saving Time+    <|> zone "MAWT" (($+) 06 00) False -- Mawson (Antarctica) Time+    <|> zone "MART" (($-) 09 30) False -- Marquesas Time+    <|> zone "LIGT" (($+) 10 00) False -- Melbourne, Australia+    <|> zone "KST" (($+) 09 00) False -- Korea Standard Time+    <|> zone "JT" (($+) 07 30) False -- Java Time+    <|> zone "JST" (($+) 09 00) False -- Japan Standard Time, Russia zone 8+    <|> zone "IT" (($+) 03 30) False -- Iran Time+    <|> zone "IST" (($+) 02 00) False -- Israel Standard Time+    <|> zone "IRT" (($+) 03 30) False -- Iran Time+    <|> zone "IOT" (($+) 05 00) False -- Indian Chagos Time+    <|> zone "IDLW" (($-) 12 00) False -- International Date Line, West+    <|> zone "IDLE" (($+) 12 00) False -- International Date Line, East+    <|> zone "HST" (($-) 10 00) False -- Hawaii Standard Time+    <|> zone "HMT" (($+) 03 00) False -- Hellas Mediterranean Time (?)+    <|> zone "HDT" (($-) 09 00) True -- Hawaii/Alaska Daylight-Saving Time+    <|> zone "GST" (($+) 10 00) False -- Guam Standard Time, Russia zone 9+    <|> zone "GMT" (($+) 00 00) False --  Greenwich Mean Time+    <|> zone "FWT" (($+) 02 00) False -- French Winter Time+    <|> zone "FST" (($+) 01 00) False -- French Summer Time+    <|> zone "FNT" (($-) 02 00) False -- Fernando de Noronha Time+    <|> zone "FNST" (($-) 01 00) False -- Fernando de Noronha Summer Time+    <|> zone "EST" (($-) 05 00) False -- Eastern Standard Time+    <|> zone "EETDST" (($+) 03 00) True -- Eastern Europe Daylight-Saving Time+    <|> zone "EET" (($+) 02 00) False -- Eastern European Time, Russia zone 1+    <|> zone "EDT" (($-) 04 00) True -- Eastern Daylight-Saving Time+    <|> zone "EAT" (($+) 03 00) False -- Antananarivo, Comoro Time+    <|> zone "EAST" (($+) 10 00) False -- East Australian Standard Time+    <|> zone "EAST" (($+) 04 00) False -- Antananarivo Summer Time+    <|> zone "DNT" (($+) 01 00) False -- Dansk Normal Tid+    <|> zone "CXT" (($+) 07 00) False -- Christmas (Island) Time+    <|> zone "CST" (($-) 06 00) False -- Central Standard Time+    <|> zone "CETDST" (($+) 02 00) True -- Central European Daylight-Saving Time+    <|> zone "CET" (($+) 01 00) False -- Central European Time+    <|> zone "CEST" (($+) 02 00) False -- Central European Summer Time+    <|> zone "CDT" (($-) 05 00) True -- Central Daylight-Saving Time+    <|> zone "CCT" (($+) 08 00) False -- China Coastal Time+    <|> zone "CAT" (($-) 10 00) False -- Central Alaska Time+    <|> zone "CAST" (($+) 09 30) False -- Central Australia Standard Time+    <|> zone "CADT" (($+) 10 30) True -- Central Australia Daylight-Saving Time+    <|> zone "BT" (($+) 03 00) False -- Baghdad Time+    <|> zone "BST" (($+) 01 00) False -- British Summer Time+    <|> zone "BRT" (($-) 03 00) False -- Brasilia Time+    <|> zone "BRST" (($-) 02 00) False -- Brasilia Summer Time+    <|> zone "BDST" (($+) 02 00) False -- British Double Summer Time+    <|> zone "AWT" (($-) 03 00) False -- (unknown)+    <|> zone "AWST" (($+) 08 00) False -- Australia Western Standard Time+    <|> zone "AWSST" (($+) 09 00) False -- Australia Western Summer Standard Time+    <|> zone "AST" (($-) 04 00) False -- Atlantic Standard Time (Canada)+    <|> zone "ALMT" (($+) 06 00) False -- Almaty Time+    <|> zone "ALMST" (($+) 07 00) False -- Almaty Summer Time+    <|> zone "AKST" (($-) 09 00) False -- Alaska Standard Time+    <|> zone "AKDT" (($-) 08 00) True -- Alaska Daylight-Saving Time+    <|> zone "AHST" (($-) 10 00) False -- Alaska/Hawaii Standard Time+    <|> zone "AFT" (($+) 04 30) False -- Afghanistan Time+    <|> zone "AEST" (($+) 10 00) False -- Australia Eastern Standard Time+    <|> zone "AESST" (($+) 11 00) False -- Australia Eastern Summer Standard Time+    <|> zone "ADT" (($-) 03 00) True -- Atlantic Daylight-Saving Time+    <|> zone "ACT" (($-) 05 00) False -- Atlantic/Porto Acre Standard Time+    <|> zone "ACST" (($-) 04 00) False -- Atlantic/Porto Acre Summer Time+    <|> zone "ACSST" (($+) 10 30) False -- Central Australia Summer Standard Time++  where+    zone name offset dst = TimeZone offset dst name <$ P.string (S.pack name)+    ($+) h m = h * 60 + m+    ($-) h m = negate (h * 60 + m)+

src/Data/Thyme/Format/Aeson.hs view

@@ -1,108 +1,108 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Instances of 'FromJSON' and 'ToJSON' for 'UTCTime' and 'ZonedTime',
--- along with a newtype wrapper 'DotNetTime'.
-module Data.Thyme.Format.Aeson
-    ( DotNetTime (..)
-    ) where
-
-import Prelude
-import Control.Applicative
-import Data.Aeson hiding (DotNetTime (..))
-import Data.Aeson.Types hiding (DotNetTime (..))
-import Data.Data
-#if !MIN_VERSION_base(4,8,0)
-import Data.Monoid
-#endif
-import Data.Text (pack, unpack)
-import qualified Data.Text as T
-import Data.Thyme
-
--- Copyright:   (c) 2011, 2012, 2013 Bryan O'Sullivan
---              (c) 2011 MailRank, Inc.
-
-------------------------------------------------------------------------
--- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Internal
-
--- | A newtype wrapper for 'UTCTime' that uses the same non-standard
--- serialization format as Microsoft .NET, whose @System.DateTime@
--- type is by default serialized to JSON as in the following example:
---
--- > /Date(1302547608878)/
---
--- The number represents milliseconds since the Unix epoch.
-newtype DotNetTime = DotNetTime {
-      fromDotNetTime :: UTCTime
-    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
-
-------------------------------------------------------------------------
--- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Instances
-
-instance ToJSON DotNetTime where
-    toJSON (DotNetTime t) =
-        String (pack (secs ++ formatMillis t ++ ")/"))
-      where secs  = formatTime defaultTimeLocale "/Date(%s" t
-    {-# INLINE toJSON #-}
-
-instance FromJSON DotNetTime where
-    parseJSON = withText "DotNetTime" $ \t ->
-        let (s,m) = T.splitAt (T.length t - 5) t
-            t'    = T.concat [s,".",m]
-        in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
-             Just d -> pure (DotNetTime d)
-             _      -> fail "could not parse .NET time"
-    {-# INLINE parseJSON #-}
-
-instance ToJSON ZonedTime where
-    toJSON t = String $ pack $ formatTime defaultTimeLocale format t
-      where
-        format = "%FT%T." ++ formatMillis t ++ tzFormat
-        tzFormat
-          | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"
-          | otherwise = "%z"
-
-formatMillis :: (FormatTime t) => t -> String
-formatMillis t = take 3 $ formatTime defaultTimeLocale "%q" t
-
-instance FromJSON ZonedTime where
-    parseJSON (String t) =
-      tryFormats alternateFormats
-      <|> fail "could not parse ECMA-262 ISO-8601 date"
-      where
-        tryFormat f =
-          case parseTime defaultTimeLocale f (unpack t) of
-            Just d -> pure d
-            Nothing -> empty
-        tryFormats = foldr1 (<|>) . map tryFormat
-        alternateFormats =
-          dateTimeFmt defaultTimeLocale :
-          distributeList ["%Y", "%Y-%m", "%F"]
-                         ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
-
-        distributeList xs ys =
-          foldr (\x acc -> acc ++ distribute x ys) [] xs
-        distribute x = map (mappend x)
-
-    parseJSON v = typeMismatch "ZonedTime" v
-
-instance ToJSON UTCTime where
-    toJSON t = String $ pack $ formatTime defaultTimeLocale format t
-      where
-        format = "%FT%T." ++ formatMillis t ++ "Z"
-    {-# INLINE toJSON #-}
-
-instance FromJSON UTCTime where
-    parseJSON = withText "UTCTime" $ \t ->
-        case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
-          Just d -> pure d
-          _      -> fail "could not parse ISO-8601 date"
-    {-# INLINE parseJSON #-}
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if HLINT+#include "cabal_macros.h"+#endif++-- | Instances of 'FromJSON' and 'ToJSON' for 'UTCTime' and 'ZonedTime',+-- along with a newtype wrapper 'DotNetTime'.+module Data.Thyme.Format.Aeson+    ( DotNetTime (..)+    ) where++import Prelude+import Control.Applicative+import Data.Aeson hiding (DotNetTime (..))+import Data.Aeson.Types hiding (DotNetTime (..))+import Data.Data+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif+import Data.Text (pack, unpack)+import qualified Data.Text as T+import Data.Thyme++-- Copyright:   (c) 2011, 2012, 2013 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.++------------------------------------------------------------------------+-- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Internal++-- | A newtype wrapper for 'UTCTime' that uses the same non-standard+-- serialization format as Microsoft .NET, whose @System.DateTime@+-- type is by default serialized to JSON as in the following example:+--+-- > /Date(1302547608878)/+--+-- The number represents milliseconds since the Unix epoch.+newtype DotNetTime = DotNetTime {+      fromDotNetTime :: UTCTime+    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)++------------------------------------------------------------------------+-- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Instances++instance ToJSON DotNetTime where+    toJSON (DotNetTime t) =+        String (pack (secs ++ formatMillis t ++ ")/"))+      where secs  = formatTime defaultTimeLocale "/Date(%s" t+    {-# INLINE toJSON #-}++instance FromJSON DotNetTime where+    parseJSON = withText "DotNetTime" $ \t ->+        let (s,m) = T.splitAt (T.length t - 5) t+            t'    = T.concat [s,".",m]+        in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of+             Just d -> pure (DotNetTime d)+             _      -> fail "could not parse .NET time"+    {-# INLINE parseJSON #-}++instance ToJSON ZonedTime where+    toJSON t = String $ pack $ formatTime defaultTimeLocale format t+      where+        format = "%FT%T." ++ formatMillis t ++ tzFormat+        tzFormat+          | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"+          | otherwise = "%z"++formatMillis :: (FormatTime t) => t -> String+formatMillis t = take 3 $ formatTime defaultTimeLocale "%q" t++instance FromJSON ZonedTime where+    parseJSON (String t) =+      tryFormats alternateFormats+      <|> fail "could not parse ECMA-262 ISO-8601 date"+      where+        tryFormat f =+          case parseTime defaultTimeLocale f (unpack t) of+            Just d -> pure d+            Nothing -> empty+        tryFormats = foldr1 (<|>) . map tryFormat+        alternateFormats =+          dateTimeFmt defaultTimeLocale :+          distributeList ["%Y", "%Y-%m", "%F"]+                         ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]++        distributeList xs ys =+          foldr (\x acc -> acc ++ distribute x ys) [] xs+        distribute x = map (mappend x)++    parseJSON v = typeMismatch "ZonedTime" v++instance ToJSON UTCTime where+    toJSON t = String $ pack $ formatTime defaultTimeLocale format t+      where+        format = "%FT%T." ++ formatMillis t ++ "Z"+    {-# INLINE toJSON #-}++instance FromJSON UTCTime where+    parseJSON = withText "UTCTime" $ \t ->+        case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of+          Just d -> pure d+          _      -> fail "could not parse ISO-8601 date"+    {-# INLINE parseJSON #-}+

src/Data/Thyme/Format/Human.hs view

@@ -1,94 +1,94 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Vague textual descriptions of time durations.
-module Data.Thyme.Format.Human
-    ( humanTimeDiff
-    , humanTimeDiffs
-    , humanRelTime
-    , humanRelTimes
-    ) where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.Lens
-import Control.Monad
-import Data.AdditiveGroup
-import Data.AffineSpace
-import Data.Foldable
-import Data.Thyme.Internal.Micro
-import Data.Monoid
-import Data.Thyme.Clock.Internal
-import Data.VectorSpace
-
-data Unit = Unit
-    { unit :: Micro
-    , single :: ShowS
-    , plural :: ShowS
-    }
-LENS(Unit,plural,ShowS)
-
--- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form.
-{-# INLINE humanTimeDiff #-}
-humanTimeDiff :: (TimeDiff d) => d -> String
-humanTimeDiff d = humanTimeDiffs d ""
-
--- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form.
-{-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-}
-humanTimeDiffs :: (TimeDiff d) => d -> ShowS
-humanTimeDiffs td = (if signed < 0 then (:) '-' else id) . diff where
-    signed@(Micro . abs -> us) = td ^. microseconds
-    diff = maybe id id . getFirst . fold $
-        zipWith (approx us . unit) (tail units) units
-
--- | Display one 'UTCTime' relative to another, in a human-readable form.
-{-# INLINE humanRelTime #-}
-humanRelTime :: UTCTime -> UTCTime -> String
-humanRelTime ref time = humanRelTimes ref time ""
-
--- | Display one 'UTCTime' relative to another, in a human-readable form.
-humanRelTimes :: UTCTime -> UTCTime -> ShowS
-humanRelTimes ref time = thence $ humanTimeDiffs diff where
-    (diff, thence) = case compare delta zeroV of
-        LT -> (negateV delta, ((++) "in " .))
-        EQ -> (zeroV, const $ (++) "right now")
-        GT -> (delta, (. (++) " ago"))
-        where delta = time .-. ref
-
-approx :: Micro -> Micro -> Unit -> First ShowS
-approx us next Unit {..} = First $
-        shows n . inflection <$ guard (us < next) where
-    n = fst $ microQuotRem (us ^+^ half) unit where
-        half = Micro . fst $ microQuotRem unit (Micro 2)
-    inflection = if n == 1 then single else plural
-
-units :: [Unit]
-units = scanl (&)
-    (Unit (Micro 1) (" microsecond" ++) (" microseconds" ++))
-    [ times "millisecond"   1000
-    , times "second"        1000
-    , times "minute"        60
-    , times "hour"          60
-    , times "day"           24
-    , times "week"          7
-    , times "month"         (30.4368 / 7)
-    , times "year"          12
-    , times "decade"        10
-    , times "century"       10 >>> set _plural (" centuries" ++)
-    , times "millennium"    10 >>> set _plural (" millennia" ++)
-    , const (Unit maxBound id id) -- upper bound needed for humanTimeDiffs.diff
-    ] where
-    times :: String -> Rational -> Unit -> Unit
-    times ((++) . (:) ' ' -> single) r Unit {unit}
-        = Unit {unit = r *^ unit, plural = single . (:) 's', ..}
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++-- | Vague textual descriptions of time durations.+module Data.Thyme.Format.Human+    ( humanTimeDiff+    , humanTimeDiffs+    , humanRelTime+    , humanRelTimes+    ) where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.Lens+import Control.Monad+import Data.AdditiveGroup+import Data.AffineSpace+import Data.Foldable+import Data.Thyme.Internal.Micro+import Data.Monoid+import Data.Thyme.Clock.Internal+import Data.VectorSpace++data Unit = Unit+    { unit :: Micro+    , single :: ShowS+    , plural :: ShowS+    }+LENS(Unit,plural,ShowS)++-- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form.+{-# INLINE humanTimeDiff #-}+humanTimeDiff :: (TimeDiff d) => d -> String+humanTimeDiff d = humanTimeDiffs d ""++-- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form.+{-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-}+humanTimeDiffs :: (TimeDiff d) => d -> ShowS+humanTimeDiffs td = (if signed < 0 then (:) '-' else id) . diff where+    signed@(Micro . abs -> us) = td ^. microseconds+    diff = maybe id id . getFirst . fold $+        zipWith (approx us . unit) (tail units) units++-- | Display one 'UTCTime' relative to another, in a human-readable form.+{-# INLINE humanRelTime #-}+humanRelTime :: UTCTime -> UTCTime -> String+humanRelTime ref time = humanRelTimes ref time ""++-- | Display one 'UTCTime' relative to another, in a human-readable form.+humanRelTimes :: UTCTime -> UTCTime -> ShowS+humanRelTimes ref time = thence $ humanTimeDiffs diff where+    (diff, thence) = case compare delta zeroV of+        LT -> (negateV delta, ((++) "in " .))+        EQ -> (zeroV, const $ (++) "right now")+        GT -> (delta, (. (++) " ago"))+        where delta = time .-. ref++approx :: Micro -> Micro -> Unit -> First ShowS+approx us next Unit {..} = First $+        shows n . inflection <$ guard (us < next) where+    n = fst $ microQuotRem (us ^+^ half) unit where+        half = Micro . fst $ microQuotRem unit (Micro 2)+    inflection = if n == 1 then single else plural++units :: [Unit]+units = scanl (&)+    (Unit (Micro 1) (" microsecond" ++) (" microseconds" ++))+    [ times "millisecond"   1000+    , times "second"        1000+    , times "minute"        60+    , times "hour"          60+    , times "day"           24+    , times "week"          7+    , times "month"         (30.4368 / 7)+    , times "year"          12+    , times "decade"        10+    , times "century"       10 >>> set _plural (" centuries" ++)+    , times "millennium"    10 >>> set _plural (" millennia" ++)+    , const (Unit maxBound id id) -- upper bound needed for humanTimeDiffs.diff+    ] where+    times :: String -> Rational -> Unit -> Unit+    times ((++) . (:) ' ' -> single) r Unit {unit}+        = Unit {unit = r *^ unit, plural = single . (:) 's', ..}+

src/Data/Thyme/Format/Internal.hs view

@@ -1,147 +1,147 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
-module Data.Thyme.Format.Internal where
-
-import Prelude
-import Control.Applicative
-import Data.Attoparsec.ByteString.Char8 (Parser, Result, IResult (..))
-import qualified Data.Attoparsec.ByteString.Char8 as P
-import qualified Data.ByteString.Char8 as S
-import Data.Char
-import Data.Int
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-
-#if MIN_VERSION_bytestring(0,10,0)
-# if MIN_VERSION_bytestring(0,10,2)
-import qualified Data.ByteString.Builder as B
-# else
-import qualified Data.ByteString.Lazy.Builder as B
-# endif
-import qualified Data.ByteString.Lazy as L
-#endif
-
-{-# INLINE utf8Char #-}
-{-# INLINE utf8String #-}
-utf8Char :: Char -> S.ByteString
-utf8String :: String -> S.ByteString
-#if MIN_VERSION_bytestring(0,10,0)
-utf8Char = L.toStrict . B.toLazyByteString . B.charUtf8
-utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8
-#else
-utf8Char = Text.encodeUtf8 . Text.singleton
-utf8String = Text.encodeUtf8 . Text.pack
-#endif
-
-------------------------------------------------------------------------
-
-{-# INLINE shows02 #-}
-shows02 :: Int -> ShowS
-shows02 n = if n < 10 then (:) '0' . shows n else shows n
-
-{-# ANN shows_2 "HLint: ignore Use camelCase" #-}
-{-# INLINE shows_2 #-}
-shows_2 :: Int -> ShowS
-shows_2 n = if n < 10 then (:) ' ' . shows n else shows n
-
-{-# INLINE shows03 #-}
-shows03 :: Int -> ShowS
-shows03 n
-    | n < 10 = (++) "00" . shows n
-    | n < 100 = (++) "0" . shows n
-    | otherwise = shows n
-
-{-# INLINE showsYear #-}
-showsYear :: Int -> ShowS
-showsYear n@(abs -> u)
-    | u < 10 = neg . (++) "000" . shows u
-    | u < 100 = neg . (++) "00" . shows u
-    | u < 1000 = neg . (++) "0" . shows u
-    | otherwise = neg . shows u
-    where neg = if n < 0 then (:) '-' else id
-
-{-# INLINE fills06 #-}
-fills06 :: Int64 -> ShowS
-fills06 n
-    | n < 10 = (++) "00000"
-    | n < 100 = (++) "0000"
-    | n < 1000 = (++) "000"
-    | n < 10000 = (++) "00"
-    | n < 100000 = (++) "0"
-    | otherwise = id
-
-{-# INLINE drops0 #-}
-drops0 :: Int64 -> ShowS
-drops0 n = case divMod n 10 of
-    (q, 0) -> drops0 q
-    _ -> shows n
-
-------------------------------------------------------------------------
-
-{-# INLINEABLE parserToReadS #-}
-parserToReadS :: Parser a -> ReadS a
-parserToReadS = go . P.parse where
-    {-# INLINEABLE go #-}
-    go :: (S.ByteString -> Result a) -> ReadS a
-    go k (splitAt 32 -> (h, t)) = case k (utf8String h) of
-        -- `date -R | wc -c` is 32 characters
-        Fail rest cxts msg -> fail $ concat [ "parserToReadS: ", msg
-            , "; remaining: ", show (utf8Decode rest), "; stack: ", show cxts ]
-        Partial k' -> go k' t
-        Done rest a -> return (a, utf8Decode rest ++ t)
-
-    {-# INLINE utf8Decode #-}
-    utf8Decode :: S.ByteString -> String
-    utf8Decode = Text.unpack . Text.decodeUtf8
-
-{-# INLINE indexOf #-}
-indexOf :: [String] -> Parser Int
-indexOf = P.choice . zipWith (\ i s -> i <$ P.string (S.pack s)) [0..]
-
-{-# INLINE indexOfCI #-}
-indexOfCI :: [String] -> Parser Int
-indexOfCI = P.choice . zipWith (\ i s -> i <$ stringCI s) [0..]
-
--- | Case-insensitive UTF-8 ByteString parser
---
--- Matches one character at a time. Slow.
-{-# INLINE stringCI #-}
-stringCI :: String -> Parser ()
-stringCI = foldl (\ p c -> p *> charCI c) (pure ())
-
--- | Case-insensitive UTF-8 ByteString parser
---
--- We can't easily perform upper/lower case conversion on the input, so
--- instead we accept either one of @toUpper c@ and @toLower c@.
-{-# INLINE charCI #-}
-charCI :: Char -> Parser ()
-charCI c = if u == l then charU8 c else charU8 l <|> charU8 u where
-    l = toLower c
-    u = toUpper c
-
-{-# INLINE charU8 #-}
-charU8 :: Char -> Parser ()
-charU8 c = () <$ P.string (utf8Char c)
-
--- | Number may be prefixed with '-'
-{-# INLINE negative #-}
-negative :: (Integral n) => Parser n -> Parser n
-negative p = ($) <$> (negate <$ P.char '-' <|> pure id) <*> p
-
--- | Fixed-length 0-padded decimal
-{-# INLINE dec0 #-}
-dec0 :: Int -> Parser Int
-dec0 n = either fail return . P.parseOnly P.decimal =<< P.take n
-
--- | Fixed-length space-padded decimal
-{-# INLINE dec_ #-}
-dec_ :: Int -> Parser Int
-dec_ n = either fail return . P.parseOnly P.decimal
-    =<< S.dropWhile isSpace <$> P.take n
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}++#if HLINT+#include "cabal_macros.h"+#endif++module Data.Thyme.Format.Internal where++import Prelude+import Control.Applicative+import Data.Attoparsec.ByteString.Char8 (Parser, Result, IResult (..))+import qualified Data.Attoparsec.ByteString.Char8 as P+import qualified Data.ByteString.Char8 as S+import Data.Char+import Data.Int+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++#if MIN_VERSION_bytestring(0,10,0)+# if MIN_VERSION_bytestring(0,10,2)+import qualified Data.ByteString.Builder as B+# else+import qualified Data.ByteString.Lazy.Builder as B+# endif+import qualified Data.ByteString.Lazy as L+#endif++{-# INLINE utf8Char #-}+{-# INLINE utf8String #-}+utf8Char :: Char -> S.ByteString+utf8String :: String -> S.ByteString+#if MIN_VERSION_bytestring(0,10,0)+utf8Char = L.toStrict . B.toLazyByteString . B.charUtf8+utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8+#else+utf8Char = Text.encodeUtf8 . Text.singleton+utf8String = Text.encodeUtf8 . Text.pack+#endif++------------------------------------------------------------------------++{-# INLINE shows02 #-}+shows02 :: Int -> ShowS+shows02 n = if n < 10 then (:) '0' . shows n else shows n++{-# ANN shows_2 "HLint: ignore Use camelCase" #-}+{-# INLINE shows_2 #-}+shows_2 :: Int -> ShowS+shows_2 n = if n < 10 then (:) ' ' . shows n else shows n++{-# INLINE shows03 #-}+shows03 :: Int -> ShowS+shows03 n+    | n < 10 = (++) "00" . shows n+    | n < 100 = (++) "0" . shows n+    | otherwise = shows n++{-# INLINE showsYear #-}+showsYear :: Int -> ShowS+showsYear n@(abs -> u)+    | u < 10 = neg . (++) "000" . shows u+    | u < 100 = neg . (++) "00" . shows u+    | u < 1000 = neg . (++) "0" . shows u+    | otherwise = neg . shows u+    where neg = if n < 0 then (:) '-' else id++{-# INLINE fills06 #-}+fills06 :: Int64 -> ShowS+fills06 n+    | n < 10 = (++) "00000"+    | n < 100 = (++) "0000"+    | n < 1000 = (++) "000"+    | n < 10000 = (++) "00"+    | n < 100000 = (++) "0"+    | otherwise = id++{-# INLINE drops0 #-}+drops0 :: Int64 -> ShowS+drops0 n = case divMod n 10 of+    (q, 0) -> drops0 q+    _ -> shows n++------------------------------------------------------------------------++{-# INLINEABLE parserToReadS #-}+parserToReadS :: Parser a -> ReadS a+parserToReadS = go . P.parse where+    {-# INLINEABLE go #-}+    go :: (S.ByteString -> Result a) -> ReadS a+    go k (splitAt 32 -> (h, t)) = case k (utf8String h) of+        -- `date -R | wc -c` is 32 characters+        Fail rest cxts msg -> fail $ concat [ "parserToReadS: ", msg+            , "; remaining: ", show (utf8Decode rest), "; stack: ", show cxts ]+        Partial k' -> go k' t+        Done rest a -> return (a, utf8Decode rest ++ t)++    {-# INLINE utf8Decode #-}+    utf8Decode :: S.ByteString -> String+    utf8Decode = Text.unpack . Text.decodeUtf8++{-# INLINE indexOf #-}+indexOf :: [String] -> Parser Int+indexOf = P.choice . zipWith (\ i s -> i <$ P.string (S.pack s)) [0..]++{-# INLINE indexOfCI #-}+indexOfCI :: [String] -> Parser Int+indexOfCI = P.choice . zipWith (\ i s -> i <$ stringCI s) [0..]++-- | Case-insensitive UTF-8 ByteString parser+--+-- Matches one character at a time. Slow.+{-# INLINE stringCI #-}+stringCI :: String -> Parser ()+stringCI = foldl (\ p c -> p *> charCI c) (pure ())++-- | Case-insensitive UTF-8 ByteString parser+--+-- We can't easily perform upper/lower case conversion on the input, so+-- instead we accept either one of @toUpper c@ and @toLower c@.+{-# INLINE charCI #-}+charCI :: Char -> Parser ()+charCI c = if u == l then charU8 c else charU8 l <|> charU8 u where+    l = toLower c+    u = toUpper c++{-# INLINE charU8 #-}+charU8 :: Char -> Parser ()+charU8 c = () <$ P.string (utf8Char c)++-- | Number may be prefixed with '-'+{-# INLINE negative #-}+negative :: (Integral n) => Parser n -> Parser n+negative p = ($) <$> (negate <$ P.char '-' <|> pure id) <*> p++-- | Fixed-length 0-padded decimal+{-# INLINE dec0 #-}+dec0 :: Int -> Parser Int+dec0 n = either fail return . P.parseOnly P.decimal =<< P.take n++-- | Fixed-length space-padded decimal+{-# INLINE dec_ #-}+dec_ :: Int -> Parser Int+dec_ n = either fail return . P.parseOnly P.decimal+    =<< S.dropWhile isSpace <$> P.take n+

src/Data/Thyme/Internal/Micro.hs view

@@ -1,107 +1,107 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-#include "thyme.h"
-
--- | FOR INTERNAL USE ONLY.
-module Data.Thyme.Internal.Micro where
-
-import Prelude
-import Control.DeepSeq
-import Data.AdditiveGroup
-import Data.Basis
-import Data.Data
-import Data.Hashable
-import Data.Int
-import Data.Ix
-import Data.Ratio
-#if __GLASGOW_HASKELL__ == 704
-import qualified Data.Vector.Generic
-import qualified Data.Vector.Generic.Mutable
-#endif
-import Data.Vector.Unboxed.Deriving
-import Data.VectorSpace
-import GHC.Generics (Generic)
-import System.Random
-import Test.QuickCheck
-
-#if !SHOW_INTERNAL
-import Control.Monad
-import Data.Char
-import Data.Thyme.Format.Internal
-import Numeric
-import Text.ParserCombinators.ReadPrec
-import Text.ParserCombinators.ReadP
-import Text.Read
-#endif
-
-newtype Micro = Micro Int64 deriving (INSTANCES_MICRO)
-
-derivingUnbox "Micro" [t| Micro -> Int64 |]
-    [| \ (Micro a) -> a |] [| Micro |]
-
-#if SHOW_INTERNAL
-deriving instance Show Micro
-deriving instance Read Micro
-#else
-instance Show Micro where
-    {-# INLINEABLE showsPrec #-}
-    showsPrec _ (Micro a) = sign . shows si . frac where
-        sign = if a < 0 then (:) '-' else id
-        (si, su) = abs a `divMod` 1000000
-        frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su
-
-instance Read Micro where
-    {-# INLINEABLE readPrec #-}
-    readPrec = lift $ do
-        sign <- (char '-' >> return negate) `mplus` return id
-        s <- readS_to_P readDec
-        us <- (`mplus` return 0) $ do
-            _ <- char '.'
-            [(us10, "")] <- (readDec . take 7 . (++ "000000"))
-                `fmap` munch1 isDigit
-            return (div (us10 + 5) 10)
-        return . Micro . sign $ s * 1000000 + us
-#endif
-
-{-# INLINE microQuotRem #-}
-{-# INLINE microDivMod #-}
-microQuotRem, microDivMod :: Micro -> Micro -> (Int64, Micro)
-microQuotRem (Micro a) (Micro b) = (n, Micro f) where (n, f) = quotRem a b
-microDivMod  (Micro a) (Micro b) = (n, Micro f) where (n, f) = divMod a b
-
-instance AdditiveGroup Micro where
-    {-# INLINE zeroV #-}
-    zeroV = Micro 0
-    {-# INLINE (^+^) #-}
-    (^+^) = \ (Micro a) (Micro b) -> Micro (a + b)
-    {-# INLINE negateV #-}
-    negateV = \ (Micro a) -> Micro (negate a)
-
-instance VectorSpace Micro where
-    type Scalar Micro = Rational
-    {-# INLINE (*^) #-}
-    s *^ Micro a = Micro . fromInteger $ -- 'round'-to-even
-        case compare (2 * abs r) (denominator s) of
-            LT -> n
-            EQ -> if even n then n else m
-            GT -> m
-      where
-        (n, r) = quotRem (toInteger a * numerator s) (denominator s)
-        m = if r < 0 then n - 1 else n + 1
-
-instance HasBasis Micro where
-    type Basis Micro = ()
-    {-# INLINE basisValue #-}
-    basisValue = \ _ -> Micro 1000000
-    {-# INLINE decompose #-}
-    decompose = \ (Micro a) -> [((), fromIntegral a % 1000000)]
-    {-# INLINE decompose' #-}
-    decompose' = \ (Micro a) _ -> fromIntegral a % 1000000
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#include "thyme.h"++-- | FOR INTERNAL USE ONLY.+module Data.Thyme.Internal.Micro where++import Prelude+import Control.DeepSeq+import Data.AdditiveGroup+import Data.Basis+import Data.Data+import Data.Hashable+import Data.Int+import Data.Ix+import Data.Ratio+#if __GLASGOW_HASKELL__ == 704+import qualified Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable+#endif+import Data.Vector.Unboxed.Deriving+import Data.VectorSpace+import GHC.Generics (Generic)+import System.Random+import Test.QuickCheck++#if !SHOW_INTERNAL+import Control.Monad+import Data.Char+import Data.Thyme.Format.Internal+import Numeric+import Text.ParserCombinators.ReadPrec+import Text.ParserCombinators.ReadP+import Text.Read+#endif++newtype Micro = Micro Int64 deriving (INSTANCES_MICRO)++derivingUnbox "Micro" [t| Micro -> Int64 |]+    [| \ (Micro a) -> a |] [| Micro |]++#if SHOW_INTERNAL+deriving instance Show Micro+deriving instance Read Micro+#else+instance Show Micro where+    {-# INLINEABLE showsPrec #-}+    showsPrec _ (Micro a) = sign . shows si . frac where+        sign = if a < 0 then (:) '-' else id+        (si, su) = abs a `divMod` 1000000+        frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su++instance Read Micro where+    {-# INLINEABLE readPrec #-}+    readPrec = lift $ do+        sign <- (char '-' >> return negate) `mplus` return id+        s <- readS_to_P readDec+        us <- (`mplus` return 0) $ do+            _ <- char '.'+            [(us10, "")] <- (readDec . take 7 . (++ "000000"))+                `fmap` munch1 isDigit+            return (div (us10 + 5) 10)+        return . Micro . sign $ s * 1000000 + us+#endif++{-# INLINE microQuotRem #-}+{-# INLINE microDivMod #-}+microQuotRem, microDivMod :: Micro -> Micro -> (Int64, Micro)+microQuotRem (Micro a) (Micro b) = (n, Micro f) where (n, f) = quotRem a b+microDivMod  (Micro a) (Micro b) = (n, Micro f) where (n, f) = divMod a b++instance AdditiveGroup Micro where+    {-# INLINE zeroV #-}+    zeroV = Micro 0+    {-# INLINE (^+^) #-}+    (^+^) = \ (Micro a) (Micro b) -> Micro (a + b)+    {-# INLINE negateV #-}+    negateV = \ (Micro a) -> Micro (negate a)++instance VectorSpace Micro where+    type Scalar Micro = Rational+    {-# INLINE (*^) #-}+    s *^ Micro a = Micro . fromInteger $ -- 'round'-to-even+        case compare (2 * abs r) (denominator s) of+            LT -> n+            EQ -> if even n then n else m+            GT -> m+      where+        (n, r) = quotRem (toInteger a * numerator s) (denominator s)+        m = if r < 0 then n - 1 else n + 1++instance HasBasis Micro where+    type Basis Micro = ()+    {-# INLINE basisValue #-}+    basisValue = \ _ -> Micro 1000000+    {-# INLINE decompose #-}+    decompose = \ (Micro a) -> [((), fromIntegral a % 1000000)]+    {-# INLINE decompose' #-}+    decompose' = \ (Micro a) _ -> fromIntegral a % 1000000+

src/Data/Thyme/LocalTime.hs view

@@ -1,671 +1,671 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-#include "thyme.h"
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | Local time and time zones.
-module Data.Thyme.LocalTime
-    ( Hour, Minute
-    , module Data.Thyme.LocalTime
-    ) where
-
-import Prelude hiding ((.))
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Arrow
-import Control.Category hiding (id)
-import Control.DeepSeq
-import Control.Lens
-import Control.Monad
-import Data.AffineSpace
-import Data.Bits
-import Data.Data
-import Data.Hashable
-import Data.Int
-import Data.Thyme.Internal.Micro
-import Data.Thyme.Calendar
-import Data.Thyme.Calendar.Internal
-import Data.Thyme.Clock
-import Data.Thyme.Clock.Internal
-import Data.Thyme.Format.Internal
-import qualified Data.Time as T
-#if __GLASGOW_HASKELL__ == 704
-import qualified Data.Vector.Generic
-import qualified Data.Vector.Generic.Mutable
-#endif
-import Data.Vector.Unboxed.Deriving
-import Data.VectorSpace
-import GHC.Generics (Generic)
-import System.Random
-import Test.QuickCheck hiding ((.&.))
-
--- | Hours duration.
-type Hours = Int
--- | Minutes duration.
-type Minutes = Int
-
-------------------------------------------------------------------------
--- * Time Zones
-
--- | Description of one time zone.
---
--- A 'TimeZone' is a whole number of minutes offset from UTC, together with
--- a name and a ‘summer time’ flag.
-data TimeZone = TimeZone
-    { timeZoneMinutes :: {-# UNPACK #-}!Minutes
-    -- ^ The number of minutes offset from UTC.
-    , timeZoneSummerOnly :: !Bool
-    -- ^ Is this a summer-only (i.e. daylight savings) time zone?
-    , timeZoneName :: String
-    -- ^ The name of the zone, typically a three- or four-letter acronym.
-    } deriving (INSTANCES_USUAL)
-
-LENS(TimeZone,timeZoneMinutes,Minutes)
-LENS(TimeZone,timeZoneSummerOnly,Bool)
-LENS(TimeZone,timeZoneName,String)
-
-instance Hashable TimeZone
-instance NFData TimeZone
-
-#if SHOW_INTERNAL
-deriving instance Show TimeZone
-#else
-instance Show TimeZone where
-    show tz@TimeZone {..} = if null timeZoneName
-        then timeZoneOffsetString tz else timeZoneName
-#endif
-
-instance Bounded TimeZone where
-    minBound = TimeZone (-12 * 60) minBound "AAAA"
-    maxBound = TimeZone (13 * 60) maxBound "ZZZZ"
-
-instance Random TimeZone where
-    randomR (l, u) g0 = (TimeZone minutes summer name, g3) where
-        (minutes, g1) = randomR (timeZoneMinutes l, timeZoneMinutes u) g0
-        (summer, g2) = randomR (timeZoneSummerOnly l, timeZoneSummerOnly u) g1
-        -- slightly dubious interpretation of ‘range’
-        (name, g3) = foldr randChar ([], g2) . take 4 $ zip
-            (timeZoneName l ++ "AAAA") (timeZoneName u ++ "ZZZZ")
-        randChar nR (ns, g) = (: ns) `first` randomR nR g
-    random = randomR (minBound, maxBound)
-
-instance Arbitrary TimeZone where
-    arbitrary = choose (minBound, maxBound)
-    shrink tz@TimeZone {..}
-        = [ tz {timeZoneSummerOnly = s} | s <- shrink timeZoneSummerOnly ]
-        ++ [ tz {timeZoneMinutes = m} | m <- shrink timeZoneMinutes ]
-        ++ [ tz {timeZoneName = n} | n <- shrink timeZoneName ]
-
-instance CoArbitrary TimeZone where
-    coarbitrary (TimeZone m s n)
-        = coarbitrary m . coarbitrary s . coarbitrary n
-
--- | Text representing the offset of this timezone, e.g. \"-0800\" or
--- \"+0400\" (like @%z@ in 'Data.Thyme.Format.formatTime')
-{-# INLINEABLE timeZoneOffsetString #-}
-timeZoneOffsetString :: TimeZone -> String
-timeZoneOffsetString TimeZone {..} = sign : (shows02 h . shows02 m) "" where
-    (h, m) = divMod offset 60
-    (sign, offset) = if timeZoneMinutes < 0
-        then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes)
-
--- | Text representing the offset of this timezone in ISO 8601 style,
--- e.g. \"-08:00\" or
--- \"+04:00\" (like @%N@ in 'Data.Thyme.Format.formatTime')
-{-# INLINEABLE timeZoneOffsetStringColon #-}
-timeZoneOffsetStringColon :: TimeZone -> String
-timeZoneOffsetStringColon TimeZone {..} =
-    sign : (shows02 h . (:) ':' . shows02 m) "" where
-    (h, m) = divMod offset 60
-    (sign, offset) = if timeZoneMinutes < 0
-        then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes)
-
--- | Create a nameless non-summer timezone for this number of minutes
-minutesToTimeZone :: Minutes -> TimeZone
-minutesToTimeZone m = TimeZone m False ""
-
--- | Create a nameless non-summer timezone for this number of hours
-hoursToTimeZone :: Hours -> TimeZone
-hoursToTimeZone i = minutesToTimeZone (60 * i)
-
--- | The UTC (Zulu) time zone.
---
--- @
--- 'utc' = 'TimeZone' 0 'False' \"UTC\"
--- @
-utc :: TimeZone
-utc = TimeZone 0 False "UTC"
-
--- | Get the local time zone at the given time, varying as per summer time
--- adjustments.
---
--- Performed by
--- <https://www.gnu.org/software/libc/manual/html_node/Broken_002ddown-Time.html localtime_r>
--- or a similar call.
-{-# INLINEABLE getTimeZone #-}
-getTimeZone :: UTCTime -> IO TimeZone
-getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where
-    day = T.ModifiedJulianDay (toInteger mjd)
-    UTCView (ModifiedJulianDay mjd) dt = t ^. utcTime
-    thyme T.TimeZone {..} = TimeZone {..}
-
--- | Get the current local time zone.
---
--- @
--- 'getCurrentTimeZone' = 'getCurrentTime' >>= 'getTimeZone'
--- @
---
--- @
--- > 'getCurrentTimeZone'
--- JST
--- @
-{-# INLINE getCurrentTimeZone #-}
-getCurrentTimeZone :: IO TimeZone
-getCurrentTimeZone = getCurrentTime >>= getTimeZone
-
-------------------------------------------------------------------------
--- * Time of Day
-
--- | Time of day in hour, minute, second.
-data TimeOfDay = TimeOfDay
-    { todHour :: {-# UNPACK #-}!Hour
-    , todMin :: {-# UNPACK #-}!Minute
-    , todSec :: {-# UNPACK #-}!DiffTime -- ^ Second.
-    } deriving (INSTANCES_USUAL)
-
-LENS(TimeOfDay,todHour,Hour)
-LENS(TimeOfDay,todMin,Minute)
-LENS(TimeOfDay,todSec,DiffTime)
-
-derivingUnbox "TimeOfDay" [t| TimeOfDay -> Int64 |]
-    [| \ TimeOfDay {..} -> fromIntegral (todHour .|. shiftL todMin 8)
-        .|. shiftL (todSec ^. microseconds) 16 |]
-    [| \ n -> TimeOfDay (fromIntegral $ n .&. 0xff)
-        (fromIntegral $ shiftR n 8 .&. 0xff) (microseconds # shiftR n 16) |]
-
-instance Hashable TimeOfDay
-instance NFData TimeOfDay
-
-#if SHOW_INTERNAL
-deriving instance Show TimeOfDay
-#else
-instance Show TimeOfDay where
-    showsPrec _ (TimeOfDay h m (DiffTime s))
-            = shows02 h . (:) ':' . shows02 m . (:) ':'
-            . shows02 (fromIntegral si) . frac where
-        (si, Micro su) = microQuotRem s (Micro 1000000)
-        frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su
-#endif
-
-instance Bounded TimeOfDay where
-    minBound = TimeOfDay 0 0 zeroV
-    maxBound = TimeOfDay 23 59 (microseconds # 60999999)
-
-instance Random TimeOfDay where
-    randomR = randomIsoR timeOfDay
-    random = first (^. timeOfDay) . random
-
-instance Arbitrary TimeOfDay where
-    arbitrary = do
-        h <- choose (0, 23)
-        m <- choose (0, 59)
-        let DiffTime ml = minuteLength h m
-        TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml)
-    shrink tod = view timeOfDay . (^+^) noon
-            <$> shrink (timeOfDay # tod ^-^ noon) where
-        noon = timeOfDay # midday -- shrink towards midday
-
-instance CoArbitrary TimeOfDay where
-    coarbitrary (TimeOfDay h m s)
-        = coarbitrary h . coarbitrary m . coarbitrary s
-
--- | The maximum possible length of a minute. Always /60s/, except at
--- /23:59/ due to leap seconds.
---
--- @
--- 'minuteLength' 23 59 = 'fromSeconds'' 61
--- 'minuteLength' _  _  = 'fromSeconds'' 60
--- @
-{-# INLINE minuteLength #-}
-minuteLength :: Hour -> Minute -> DiffTime
-minuteLength 23 59 = fromSeconds' 61
-minuteLength _  _  = fromSeconds' 60
-
--- | Hour zero, midnight.
---
--- @
--- 'midnight' = 'TimeOfDay' 0 0 'zeroV'
--- @
-midnight :: TimeOfDay
-midnight = TimeOfDay 0 0 zeroV
-
--- | Hour twelve, noon.
---
--- @
--- 'midday' = 'TimeOfDay' 12 0 'zeroV'
--- @
-midday :: TimeOfDay
-midday = TimeOfDay 12 0 zeroV
-
--- | Construct a 'TimeOfDay' from the hour, minute, and second.
---
--- Returns 'Nothing' if these constraints are not satisfied:
---
--- * /0 ≤ @hour@ ≤ 23/
--- * /0 ≤ @minute@ ≤ 59/
--- * /0 ≤ @second@ < 'minuteLength' @hour@ @minute@/
-{-# INLINE makeTimeOfDayValid #-}
-makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay
-makeTimeOfDayValid h m s = TimeOfDay h m s
-    <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59)
-    <* guard (zeroV <= s && s < minuteLength h m)
-
--- | Conversion between 'DiffTime' and 'TimeOfDay'.
---
--- @
--- > 'fromSeconds'' 100 '^.' 'timeOfDay'
--- 00:01:40
---
--- > 'timeOfDay' 'Control.Lens.#' 'TimeOfDay' 0 1 40
--- 100s
--- @
-{-# INLINE timeOfDay #-}
-timeOfDay :: Iso' DiffTime TimeOfDay
-timeOfDay = iso fromDiff toDiff where
-
-    {-# INLINEABLE fromDiff #-}
-    fromDiff :: DiffTime -> TimeOfDay
-    fromDiff (DiffTime t) = TimeOfDay
-            (fromIntegral h) (fromIntegral m) (DiffTime s) where
-        (h, ms) = microQuotRem t (Micro 3600000000)
-        (m, s) = microQuotRem ms (Micro 60000000)
-
-    {-# INLINEABLE toDiff #-}
-    toDiff :: TimeOfDay -> DiffTime
-    toDiff (TimeOfDay h m s) = s
-        ^+^ fromIntegral m *^ DiffTime (Micro 60000000)
-        ^+^ fromIntegral h *^ DiffTime (Micro 3600000000)
-
--- | Add some minutes to a 'TimeOfDay'; the result includes a day adjustment.
---
--- @
--- > 'addMinutes' 10 ('TimeOfDay' 23 55 0)
--- (1,00:05:00)
--- @
-{-# INLINE addMinutes #-}
-addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay)
-addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where
-    (dd, h') = divMod (h + dh) 24
-    (dh, m') = divMod (m + dm) 60
-
--- | Conversion between 'TimeOfDay' and the fraction of a day.
---
--- @
--- > 'TimeOfDay' 6 0 0 '^.' 'dayFraction'
--- 1 % 4
--- > 'TimeOfDay' 8 0 0 '^.' 'dayFraction'
--- 1 % 3
---
--- > 'dayFraction' 'Control.Lens.#' (1 / 4)
--- 06:00:00
--- > 'dayFraction' 'Control.Lens.#' (1 / 3)
--- 08:00:00
--- @
-{-# INLINE dayFraction #-}
-dayFraction :: Iso' TimeOfDay Rational
-dayFraction = from timeOfDay . iso toRatio fromRatio where
-
-    {-# INLINEABLE toRatio #-}
-    toRatio :: DiffTime -> Rational
-    toRatio t = toSeconds t / toSeconds posixDayLength
-
-    {-# INLINEABLE fromRatio #-}
-    fromRatio :: Rational -> DiffTime
-    fromRatio ((*^ posixDayLength) -> NominalDiffTime r) = DiffTime r
-
-------------------------------------------------------------------------
--- * Local Time
-
--- | Local calendar date and time-of-day.
---
--- This type is appropriate for inputting from and outputting to the
--- outside world.
---
--- To actually perform logic and arithmetic on local date-times, a 'LocalTime'
--- should first be converted to a 'UTCTime' by the 'utcLocalTime' Iso.
---
--- See also: 'ZonedTime'.
-data LocalTime = LocalTime
-    { localDay :: {-# UNPACK #-}!Day
-    -- ^ Local calendar date.
-    , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay
-    -- ^ Local time-of-day.
-    } deriving (INSTANCES_USUAL)
-
-LENS(LocalTime,localDay,Day)
-LENS(LocalTime,localTimeOfDay,TimeOfDay)
-
-derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |]
-    [| \ LocalTime {..} -> (localDay, localTimeOfDay) |]
-    [| \ (localDay, localTimeOfDay) -> LocalTime {..} |]
-
-instance Hashable LocalTime
-instance NFData LocalTime
-
-#if SHOW_INTERNAL
-deriving instance Show LocalTime
-#else
-instance Show LocalTime where
-    showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t
-#endif
-
-instance Bounded LocalTime where
-    minBound = minBound ^. utcLocalTime maxBound
-    maxBound = maxBound ^. utcLocalTime minBound
-
-instance Random LocalTime where
-    randomR = randomIsoR (utcLocalTime utc)
-    random = randomR (minBound, maxBound)
-
-instance Arbitrary LocalTime where
-    arbitrary = choose (minBound, maxBound)
-    shrink lt@LocalTime {..}
-        = [ lt {localDay = d} | d <- shrink localDay ]
-        ++ [ lt {localTimeOfDay = d} | d <- shrink localTimeOfDay ]
-
-instance CoArbitrary LocalTime where
-    coarbitrary (LocalTime d t) = coarbitrary d . coarbitrary t
-
--- | Conversion between 'UTCTime' and 'LocalTime'.
---
--- @
--- > tz <- 'getCurrentTimeZone'
---
--- > 'timeZoneName' tz
--- \"JST\"
---
--- > 'timeZoneOffsetString' tz
--- \"+0900\"
---
--- > now <- 'getCurrentTime'
--- > now
--- 2016-04-23 02:00:00.000000 UTC
---
--- > let local = now '^.' 'utcLocalTime' tz
--- > local
--- 2016-04-23 11:00:00.000000
---
--- > 'utcLocalTime' tz 'Control.Lens.#' local
--- 2016-04-23 02:00:00.000000 UTC
--- @
---
--- See also: 'zonedTime'.
-{-# INLINE utcLocalTime #-}
-utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime
-utcLocalTime TimeZone {..} = utcTime . iso localise globalise where
-
-    {-# INLINEABLE localise #-}
-    localise :: UTCView -> LocalTime
-    localise (UTCView day dt) = LocalTime (day .+^ dd) tod where
-        (dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay)
-
-    {-# INLINEABLE globalise #-}
-    globalise :: LocalTime -> UTCView
-    globalise (LocalTime day tod) = UTCView (day .+^ dd)
-            (timeOfDay # utcToD) where
-        (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod
-
--- | Conversion between 'UniversalTime' and 'LocalTime'.
-{-# INLINE ut1LocalTime #-}
-ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime
-ut1LocalTime long = iso localise globalise where
-    NominalDiffTime posixDay@(Micro usDay) = posixDayLength
-
-    {-# INLINEABLE localise #-}
-    localise :: UniversalTime -> LocalTime
-    localise (UniversalRep (NominalDiffTime t)) = LocalTime
-            (ModifiedJulianDay $ fromIntegral day)
-            (DiffTime dt ^. timeOfDay) where
-        (day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay
-
-    {-# INLINEABLE globalise #-}
-    globalise :: LocalTime -> UniversalTime
-    globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $
-            Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where
-        ModifiedJulianDay (fromIntegral -> mjd) = day
-        DiffTime dt = timeOfDay # tod
-
-------------------------------------------------------------------------
--- * Zoned Time
-
--- | A 'LocalTime' and its 'TimeZone'.
---
--- This type is appropriate for inputting from and outputting to the
--- outside world.
---
--- To actually perform logic and arithmetic on local date-times, a 'ZonedTime'
--- should first be converted to a 'UTCTime' by the 'zonedTime' Iso.
-data ZonedTime = ZonedTime
-    { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime
-    , zonedTimeZone :: !TimeZone
-    } deriving (INSTANCES_USUAL)
-
-LENS(ZonedTime,zonedTimeToLocalTime,LocalTime)
-LENS(ZonedTime,zonedTimeZone,TimeZone)
-
-instance Hashable ZonedTime
-instance NFData ZonedTime where
-    rnf ZonedTime {..} = rnf zonedTimeZone
-
-instance Bounded ZonedTime where
-    minBound = ZonedTime minBound maxBound
-    maxBound = ZonedTime maxBound minBound
-
-instance Random ZonedTime where
-    randomR (l, u) g0 = (view zonedTime . (,) tz)
-            `first` randomR (l', u') g1 where
-        (tz, g1) = random g0 -- ignore TimeZone from l and u
-        l' = snd $ zonedTime # l
-        u' = snd $ zonedTime # u
-    random = randomR (minBound, maxBound)
-
-instance Arbitrary ZonedTime where
-    arbitrary = choose (minBound, maxBound)
-    shrink zt@ZonedTime {..}
-        = [ zt {zonedTimeToLocalTime = lt} | lt <- shrink zonedTimeToLocalTime ]
-        ++ [ zt {zonedTimeZone = tz} | tz <- shrink zonedTimeZone ]
-
-instance CoArbitrary ZonedTime where
-    coarbitrary (ZonedTime lt tz) = coarbitrary lt . coarbitrary tz
-
--- | Conversion between ('TimeZone', 'UTCTime') and 'ZonedTime'.
---
--- @
--- > now <- 'getZonedTime'
--- > now
--- 2016-04-04 16:00:00.000000 JST
---
--- > 'zonedTime' 'Control.Lens.#' now
--- (JST,2016-04-04 07:00:00.000000 UTC)
---
--- > ('zonedTime' 'Control.Lens.#' now) '^.' 'zonedTime'
--- 2016-04-04 16:00:00.000000 JST
--- @
---
--- See also: 'utcLocalTime'.
-{-# INLINE zonedTime #-}
-zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime
-zonedTime = iso toZoned fromZoned where
-
-    {-# INLINE toZoned #-}
-    toZoned :: (TimeZone, UTCTime) -> ZonedTime
-    toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz
-
-    {-# INLINE fromZoned #-}
-    fromZoned :: ZonedTime -> (TimeZone, UTCTime)
-    fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt)
-
-#if SHOW_INTERNAL
-deriving instance Show ZonedTime
-instance Show UTCTime where
-    showsPrec p = showsPrec p . view utcTime
-#else
-instance Show ZonedTime where
-    showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz
-instance Show UTCTime where
-    showsPrec p = showsPrec p . view zonedTime . (,) utc
-#endif
-
--- | Get the current local date, time, and time zone.
---
--- @
--- > 'getZonedTime'
--- 2016-04-23 11:57:22.516064 JST
--- @
---
--- See also: 'getCurrentTime', 'Data.Thyme.Clock.POSIX.getPOSIXTime'.
-{-# INLINE getZonedTime #-}
-getZonedTime :: IO ZonedTime
-getZonedTime = utcToLocalZonedTime =<< getCurrentTime
-
--- | Convert a 'UTCTime' to a 'ZonedTime' according to the local time zone
--- returned by 'getTimeZone'.
---
--- See also: 'zonedTime'.
-{-# INLINEABLE utcToLocalZonedTime #-}
-utcToLocalZonedTime :: UTCTime -> IO ZonedTime
-utcToLocalZonedTime time = do
-    tz <- getTimeZone time
-    return $ (tz, time) ^. zonedTime
-
--- * Compatibility
-
--- | Convert a UTC 'TimeOfDay' to a 'TimeOfDay' in some timezone, together
--- with a day adjustment.
---
--- @
--- 'utcToLocalTimeOfDay' = 'addMinutes' '.' 'timeZoneMinutes'
--- @
-{-# INLINE utcToLocalTimeOfDay #-}
-utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay)
-utcToLocalTimeOfDay = addMinutes . timeZoneMinutes
-
--- | Convert a 'TimeOfDay' in some timezone to a UTC 'TimeOfDay', together
--- with a day adjustment.
---
--- @
--- 'localToUTCTimeOfDay' = 'addMinutes' '.' 'negate' '.' 'timeZoneMinutes'
--- @
-{-# INLINE localToUTCTimeOfDay #-}
-localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay)
-localToUTCTimeOfDay = addMinutes . negate . timeZoneMinutes
-
--- | Convert a 'DiffTime' of the duration since midnight to a 'TimeOfDay'.
--- Durations exceeding 24 hours will be treated as leap-seconds.
---
--- @
--- 'timeToTimeOfDay' = 'view' 'timeOfDay'
--- 'timeToTimeOfDay' d ≡ d '^.' 'timeOfDay'
--- @
-{-# INLINE timeToTimeOfDay #-}
-timeToTimeOfDay :: DiffTime -> TimeOfDay
-timeToTimeOfDay = view timeOfDay
-
--- | Convert a 'TimeOfDay' to a 'DiffTime' of the duration since midnight.
--- 'TimeOfDay' greater than 24 hours will be treated as leap-seconds.
---
--- @
--- 'timeOfDayToTime' = 'review' 'timeOfDay'
--- 'timeOfDayToTime' tod ≡ 'timeOfDay' 'Control.Lens.#' tod
--- @
-{-# INLINE timeOfDayToTime #-}
-timeOfDayToTime :: TimeOfDay -> DiffTime
-timeOfDayToTime = review timeOfDay
-
--- | Convert a fraction of a day since midnight to a 'TimeOfDay'.
---
--- @
--- 'dayFractionToTimeOfDay' = 'review' 'dayFraction'
--- @
-{-# INLINE dayFractionToTimeOfDay #-}
-dayFractionToTimeOfDay :: Rational -> TimeOfDay
-dayFractionToTimeOfDay = review dayFraction
-
--- | Convert a 'TimeOfDay' to a fraction of a day since midnight.
---
--- @
--- 'timeOfDayToDayFraction' = 'view' 'dayFraction'
--- @
-{-# INLINE timeOfDayToDayFraction #-}
-timeOfDayToDayFraction :: TimeOfDay -> Rational
-timeOfDayToDayFraction = view dayFraction
-
--- | Convert a 'UTCTime' to a 'LocalTime' in the given 'TimeZone'.
---
--- @
--- 'utcToLocalTime' = 'view' '.' 'utcLocalTime'
--- @
-{-# INLINE utcToLocalTime #-}
-utcToLocalTime :: TimeZone -> UTCTime -> LocalTime
-utcToLocalTime tz = view (utcLocalTime tz)
-
--- | Convert a 'LocalTime' in the given 'TimeZone' to a 'UTCTime'.
---
--- @
--- 'localTimeToUTC' = 'review' '.' 'utcLocalTime'
--- @
-{-# INLINE localTimeToUTC #-}
-localTimeToUTC :: TimeZone -> LocalTime -> UTCTime
-localTimeToUTC tz = review (utcLocalTime tz)
-
--- | Convert a 'UniversalTime' to a 'LocalTime' at the given medidian in
--- degrees East.
---
--- @
--- 'ut1ToLocalTime' = 'view' '.' 'ut1LocalTime'
--- @
-{-# INLINE ut1ToLocalTime #-}
-ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime
-ut1ToLocalTime l = view (ut1LocalTime l)
-
--- | Convert a 'LocalTime' at the given meridian in degrees East to
--- a 'UniversalTime'.
---
--- @
--- 'localTimeToUT1' = 'review' '.' 'ut1LocalTime'
--- @
-{-# INLINE localTimeToUT1 #-}
-localTimeToUT1 :: Rational -> LocalTime -> UniversalTime
-localTimeToUT1 l = review (ut1LocalTime l)
-
--- | Convert a 'UTCTime' and the given 'TimeZone' into a 'ZonedTime'.
---
--- @
--- 'utcToZonedTime' z t = 'view' 'zonedTime' (z, t)
--- @
-{-# INLINE utcToZonedTime #-}
-utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime
-utcToZonedTime z t = view zonedTime (z, t)
-
--- | Converts a 'ZonedTime' to a 'UTCTime'.
---
--- @
--- 'zonedTimeToUTC' = 'snd' '.' 'review' 'zonedTime'
--- @
-{-# INLINE zonedTimeToUTC #-}
-zonedTimeToUTC :: ZonedTime -> UTCTime
-zonedTimeToUTC = snd . review zonedTime
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "thyme.h"+#if HLINT+#include "cabal_macros.h"+#endif++-- | Local time and time zones.+module Data.Thyme.LocalTime+    ( Hour, Minute+    , module Data.Thyme.LocalTime+    ) where++import Prelude hiding ((.))+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Arrow+import Control.Category hiding (id)+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.AffineSpace+import Data.Bits+import Data.Data+import Data.Hashable+import Data.Int+import Data.Thyme.Internal.Micro+import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal+import Data.Thyme.Clock+import Data.Thyme.Clock.Internal+import Data.Thyme.Format.Internal+import qualified Data.Time as T+#if __GLASGOW_HASKELL__ == 704+import qualified Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable+#endif+import Data.Vector.Unboxed.Deriving+import Data.VectorSpace+import GHC.Generics (Generic)+import System.Random+import Test.QuickCheck hiding ((.&.))++-- | Hours duration.+type Hours = Int+-- | Minutes duration.+type Minutes = Int++------------------------------------------------------------------------+-- * Time Zones++-- | Description of one time zone.+--+-- A 'TimeZone' is a whole number of minutes offset from UTC, together with+-- a name and a ‘summer time’ flag.+data TimeZone = TimeZone+    { timeZoneMinutes :: {-# UNPACK #-}!Minutes+    -- ^ The number of minutes offset from UTC.+    , timeZoneSummerOnly :: !Bool+    -- ^ Is this a summer-only (i.e. daylight savings) time zone?+    , timeZoneName :: String+    -- ^ The name of the zone, typically a three- or four-letter acronym.+    } deriving (INSTANCES_USUAL)++LENS(TimeZone,timeZoneMinutes,Minutes)+LENS(TimeZone,timeZoneSummerOnly,Bool)+LENS(TimeZone,timeZoneName,String)++instance Hashable TimeZone+instance NFData TimeZone++#if SHOW_INTERNAL+deriving instance Show TimeZone+#else+instance Show TimeZone where+    show tz@TimeZone {..} = if null timeZoneName+        then timeZoneOffsetString tz else timeZoneName+#endif++instance Bounded TimeZone where+    minBound = TimeZone (-12 * 60) minBound "AAAA"+    maxBound = TimeZone (13 * 60) maxBound "ZZZZ"++instance Random TimeZone where+    randomR (l, u) g0 = (TimeZone minutes summer name, g3) where+        (minutes, g1) = randomR (timeZoneMinutes l, timeZoneMinutes u) g0+        (summer, g2) = randomR (timeZoneSummerOnly l, timeZoneSummerOnly u) g1+        -- slightly dubious interpretation of ‘range’+        (name, g3) = foldr randChar ([], g2) . take 4 $ zip+            (timeZoneName l ++ "AAAA") (timeZoneName u ++ "ZZZZ")+        randChar nR (ns, g) = (: ns) `first` randomR nR g+    random = randomR (minBound, maxBound)++instance Arbitrary TimeZone where+    arbitrary = choose (minBound, maxBound)+    shrink tz@TimeZone {..}+        = [ tz {timeZoneSummerOnly = s} | s <- shrink timeZoneSummerOnly ]+        ++ [ tz {timeZoneMinutes = m} | m <- shrink timeZoneMinutes ]+        ++ [ tz {timeZoneName = n} | n <- shrink timeZoneName ]++instance CoArbitrary TimeZone where+    coarbitrary (TimeZone m s n)+        = coarbitrary m . coarbitrary s . coarbitrary n++-- | Text representing the offset of this timezone, e.g. \"-0800\" or+-- \"+0400\" (like @%z@ in 'Data.Thyme.Format.formatTime')+{-# INLINEABLE timeZoneOffsetString #-}+timeZoneOffsetString :: TimeZone -> String+timeZoneOffsetString TimeZone {..} = sign : (shows02 h . shows02 m) "" where+    (h, m) = divMod offset 60+    (sign, offset) = if timeZoneMinutes < 0+        then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes)++-- | Text representing the offset of this timezone in ISO 8601 style,+-- e.g. \"-08:00\" or+-- \"+04:00\" (like @%N@ in 'Data.Thyme.Format.formatTime')+{-# INLINEABLE timeZoneOffsetStringColon #-}+timeZoneOffsetStringColon :: TimeZone -> String+timeZoneOffsetStringColon TimeZone {..} =+    sign : (shows02 h . (:) ':' . shows02 m) "" where+    (h, m) = divMod offset 60+    (sign, offset) = if timeZoneMinutes < 0+        then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes)++-- | Create a nameless non-summer timezone for this number of minutes+minutesToTimeZone :: Minutes -> TimeZone+minutesToTimeZone m = TimeZone m False ""++-- | Create a nameless non-summer timezone for this number of hours+hoursToTimeZone :: Hours -> TimeZone+hoursToTimeZone i = minutesToTimeZone (60 * i)++-- | The UTC (Zulu) time zone.+--+-- @+-- 'utc' = 'TimeZone' 0 'False' \"UTC\"+-- @+utc :: TimeZone+utc = TimeZone 0 False "UTC"++-- | Get the local time zone at the given time, varying as per summer time+-- adjustments.+--+-- Performed by+-- <https://www.gnu.org/software/libc/manual/html_node/Broken_002ddown-Time.html localtime_r>+-- or a similar call.+{-# INLINEABLE getTimeZone #-}+getTimeZone :: UTCTime -> IO TimeZone+getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where+    day = T.ModifiedJulianDay (toInteger mjd)+    UTCView (ModifiedJulianDay mjd) dt = t ^. utcTime+    thyme T.TimeZone {..} = TimeZone {..}++-- | Get the current local time zone.+--+-- @+-- 'getCurrentTimeZone' = 'getCurrentTime' >>= 'getTimeZone'+-- @+--+-- @+-- > 'getCurrentTimeZone'+-- JST+-- @+{-# INLINE getCurrentTimeZone #-}+getCurrentTimeZone :: IO TimeZone+getCurrentTimeZone = getCurrentTime >>= getTimeZone++------------------------------------------------------------------------+-- * Time of Day++-- | Time of day in hour, minute, second.+data TimeOfDay = TimeOfDay+    { todHour :: {-# UNPACK #-}!Hour+    , todMin :: {-# UNPACK #-}!Minute+    , todSec :: {-# UNPACK #-}!DiffTime -- ^ Second.+    } deriving (INSTANCES_USUAL)++LENS(TimeOfDay,todHour,Hour)+LENS(TimeOfDay,todMin,Minute)+LENS(TimeOfDay,todSec,DiffTime)++derivingUnbox "TimeOfDay" [t| TimeOfDay -> Int64 |]+    [| \ TimeOfDay {..} -> fromIntegral (todHour .|. shiftL todMin 8)+        .|. shiftL (todSec ^. microseconds) 16 |]+    [| \ n -> TimeOfDay (fromIntegral $ n .&. 0xff)+        (fromIntegral $ shiftR n 8 .&. 0xff) (microseconds # shiftR n 16) |]++instance Hashable TimeOfDay+instance NFData TimeOfDay++#if SHOW_INTERNAL+deriving instance Show TimeOfDay+#else+instance Show TimeOfDay where+    showsPrec _ (TimeOfDay h m (DiffTime s))+            = shows02 h . (:) ':' . shows02 m . (:) ':'+            . shows02 (fromIntegral si) . frac where+        (si, Micro su) = microQuotRem s (Micro 1000000)+        frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su+#endif++instance Bounded TimeOfDay where+    minBound = TimeOfDay 0 0 zeroV+    maxBound = TimeOfDay 23 59 (microseconds # 60999999)++instance Random TimeOfDay where+    randomR = randomIsoR timeOfDay+    random = first (^. timeOfDay) . random++instance Arbitrary TimeOfDay where+    arbitrary = do+        h <- choose (0, 23)+        m <- choose (0, 59)+        let DiffTime ml = minuteLength h m+        TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml)+    shrink tod = view timeOfDay . (^+^) noon+            <$> shrink (timeOfDay # tod ^-^ noon) where+        noon = timeOfDay # midday -- shrink towards midday++instance CoArbitrary TimeOfDay where+    coarbitrary (TimeOfDay h m s)+        = coarbitrary h . coarbitrary m . coarbitrary s++-- | The maximum possible length of a minute. Always /60s/, except at+-- /23:59/ due to leap seconds.+--+-- @+-- 'minuteLength' 23 59 = 'fromSeconds'' 61+-- 'minuteLength' _  _  = 'fromSeconds'' 60+-- @+{-# INLINE minuteLength #-}+minuteLength :: Hour -> Minute -> DiffTime+minuteLength 23 59 = fromSeconds' 61+minuteLength _  _  = fromSeconds' 60++-- | Hour zero, midnight.+--+-- @+-- 'midnight' = 'TimeOfDay' 0 0 'zeroV'+-- @+midnight :: TimeOfDay+midnight = TimeOfDay 0 0 zeroV++-- | Hour twelve, noon.+--+-- @+-- 'midday' = 'TimeOfDay' 12 0 'zeroV'+-- @+midday :: TimeOfDay+midday = TimeOfDay 12 0 zeroV++-- | Construct a 'TimeOfDay' from the hour, minute, and second.+--+-- Returns 'Nothing' if these constraints are not satisfied:+--+-- * /0 ≤ @hour@ ≤ 23/+-- * /0 ≤ @minute@ ≤ 59/+-- * /0 ≤ @second@ < 'minuteLength' @hour@ @minute@/+{-# INLINE makeTimeOfDayValid #-}+makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay+makeTimeOfDayValid h m s = TimeOfDay h m s+    <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59)+    <* guard (zeroV <= s && s < minuteLength h m)++-- | Conversion between 'DiffTime' and 'TimeOfDay'.+--+-- @+-- > 'fromSeconds'' 100 '^.' 'timeOfDay'+-- 00:01:40+--+-- > 'timeOfDay' 'Control.Lens.#' 'TimeOfDay' 0 1 40+-- 100s+-- @+{-# INLINE timeOfDay #-}+timeOfDay :: Iso' DiffTime TimeOfDay+timeOfDay = iso fromDiff toDiff where++    {-# INLINEABLE fromDiff #-}+    fromDiff :: DiffTime -> TimeOfDay+    fromDiff (DiffTime t) = TimeOfDay+            (fromIntegral h) (fromIntegral m) (DiffTime s) where+        (h, ms) = microQuotRem t (Micro 3600000000)+        (m, s) = microQuotRem ms (Micro 60000000)++    {-# INLINEABLE toDiff #-}+    toDiff :: TimeOfDay -> DiffTime+    toDiff (TimeOfDay h m s) = s+        ^+^ fromIntegral m *^ DiffTime (Micro 60000000)+        ^+^ fromIntegral h *^ DiffTime (Micro 3600000000)++-- | Add some minutes to a 'TimeOfDay'; the result includes a day adjustment.+--+-- @+-- > 'addMinutes' 10 ('TimeOfDay' 23 55 0)+-- (1,00:05:00)+-- @+{-# INLINE addMinutes #-}+addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay)+addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where+    (dd, h') = divMod (h + dh) 24+    (dh, m') = divMod (m + dm) 60++-- | Conversion between 'TimeOfDay' and the fraction of a day.+--+-- @+-- > 'TimeOfDay' 6 0 0 '^.' 'dayFraction'+-- 1 % 4+-- > 'TimeOfDay' 8 0 0 '^.' 'dayFraction'+-- 1 % 3+--+-- > 'dayFraction' 'Control.Lens.#' (1 / 4)+-- 06:00:00+-- > 'dayFraction' 'Control.Lens.#' (1 / 3)+-- 08:00:00+-- @+{-# INLINE dayFraction #-}+dayFraction :: Iso' TimeOfDay Rational+dayFraction = from timeOfDay . iso toRatio fromRatio where++    {-# INLINEABLE toRatio #-}+    toRatio :: DiffTime -> Rational+    toRatio t = toSeconds t / toSeconds posixDayLength++    {-# INLINEABLE fromRatio #-}+    fromRatio :: Rational -> DiffTime+    fromRatio ((*^ posixDayLength) -> NominalDiffTime r) = DiffTime r++------------------------------------------------------------------------+-- * Local Time++-- | Local calendar date and time-of-day.+--+-- This type is appropriate for inputting from and outputting to the+-- outside world.+--+-- To actually perform logic and arithmetic on local date-times, a 'LocalTime'+-- should first be converted to a 'UTCTime' by the 'utcLocalTime' Iso.+--+-- See also: 'ZonedTime'.+data LocalTime = LocalTime+    { localDay :: {-# UNPACK #-}!Day+    -- ^ Local calendar date.+    , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay+    -- ^ Local time-of-day.+    } deriving (INSTANCES_USUAL)++LENS(LocalTime,localDay,Day)+LENS(LocalTime,localTimeOfDay,TimeOfDay)++derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |]+    [| \ LocalTime {..} -> (localDay, localTimeOfDay) |]+    [| \ (localDay, localTimeOfDay) -> LocalTime {..} |]++instance Hashable LocalTime+instance NFData LocalTime++#if SHOW_INTERNAL+deriving instance Show LocalTime+#else+instance Show LocalTime where+    showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t+#endif++instance Bounded LocalTime where+    minBound = minBound ^. utcLocalTime maxBound+    maxBound = maxBound ^. utcLocalTime minBound++instance Random LocalTime where+    randomR = randomIsoR (utcLocalTime utc)+    random = randomR (minBound, maxBound)++instance Arbitrary LocalTime where+    arbitrary = choose (minBound, maxBound)+    shrink lt@LocalTime {..}+        = [ lt {localDay = d} | d <- shrink localDay ]+        ++ [ lt {localTimeOfDay = d} | d <- shrink localTimeOfDay ]++instance CoArbitrary LocalTime where+    coarbitrary (LocalTime d t) = coarbitrary d . coarbitrary t++-- | Conversion between 'UTCTime' and 'LocalTime'.+--+-- @+-- > tz <- 'getCurrentTimeZone'+--+-- > 'timeZoneName' tz+-- \"JST\"+--+-- > 'timeZoneOffsetString' tz+-- \"+0900\"+--+-- > now <- 'getCurrentTime'+-- > now+-- 2016-04-23 02:00:00.000000 UTC+--+-- > let local = now '^.' 'utcLocalTime' tz+-- > local+-- 2016-04-23 11:00:00.000000+--+-- > 'utcLocalTime' tz 'Control.Lens.#' local+-- 2016-04-23 02:00:00.000000 UTC+-- @+--+-- See also: 'zonedTime'.+{-# INLINE utcLocalTime #-}+utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime+utcLocalTime TimeZone {..} = utcTime . iso localise globalise where++    {-# INLINEABLE localise #-}+    localise :: UTCView -> LocalTime+    localise (UTCView day dt) = LocalTime (day .+^ dd) tod where+        (dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay)++    {-# INLINEABLE globalise #-}+    globalise :: LocalTime -> UTCView+    globalise (LocalTime day tod) = UTCView (day .+^ dd)+            (timeOfDay # utcToD) where+        (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod++-- | Conversion between 'UniversalTime' and 'LocalTime'.+{-# INLINE ut1LocalTime #-}+ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime+ut1LocalTime long = iso localise globalise where+    NominalDiffTime posixDay@(Micro usDay) = posixDayLength++    {-# INLINEABLE localise #-}+    localise :: UniversalTime -> LocalTime+    localise (UniversalRep (NominalDiffTime t)) = LocalTime+            (ModifiedJulianDay $ fromIntegral day)+            (DiffTime dt ^. timeOfDay) where+        (day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay++    {-# INLINEABLE globalise #-}+    globalise :: LocalTime -> UniversalTime+    globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $+            Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where+        ModifiedJulianDay (fromIntegral -> mjd) = day+        DiffTime dt = timeOfDay # tod++------------------------------------------------------------------------+-- * Zoned Time++-- | A 'LocalTime' and its 'TimeZone'.+--+-- This type is appropriate for inputting from and outputting to the+-- outside world.+--+-- To actually perform logic and arithmetic on local date-times, a 'ZonedTime'+-- should first be converted to a 'UTCTime' by the 'zonedTime' Iso.+data ZonedTime = ZonedTime+    { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime+    , zonedTimeZone :: !TimeZone+    } deriving (INSTANCES_USUAL)++LENS(ZonedTime,zonedTimeToLocalTime,LocalTime)+LENS(ZonedTime,zonedTimeZone,TimeZone)++instance Hashable ZonedTime+instance NFData ZonedTime where+    rnf ZonedTime {..} = rnf zonedTimeZone++instance Bounded ZonedTime where+    minBound = ZonedTime minBound maxBound+    maxBound = ZonedTime maxBound minBound++instance Random ZonedTime where+    randomR (l, u) g0 = (view zonedTime . (,) tz)+            `first` randomR (l', u') g1 where+        (tz, g1) = random g0 -- ignore TimeZone from l and u+        l' = snd $ zonedTime # l+        u' = snd $ zonedTime # u+    random = randomR (minBound, maxBound)++instance Arbitrary ZonedTime where+    arbitrary = choose (minBound, maxBound)+    shrink zt@ZonedTime {..}+        = [ zt {zonedTimeToLocalTime = lt} | lt <- shrink zonedTimeToLocalTime ]+        ++ [ zt {zonedTimeZone = tz} | tz <- shrink zonedTimeZone ]++instance CoArbitrary ZonedTime where+    coarbitrary (ZonedTime lt tz) = coarbitrary lt . coarbitrary tz++-- | Conversion between ('TimeZone', 'UTCTime') and 'ZonedTime'.+--+-- @+-- > now <- 'getZonedTime'+-- > now+-- 2016-04-04 16:00:00.000000 JST+--+-- > 'zonedTime' 'Control.Lens.#' now+-- (JST,2016-04-04 07:00:00.000000 UTC)+--+-- > ('zonedTime' 'Control.Lens.#' now) '^.' 'zonedTime'+-- 2016-04-04 16:00:00.000000 JST+-- @+--+-- See also: 'utcLocalTime'.+{-# INLINE zonedTime #-}+zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime+zonedTime = iso toZoned fromZoned where++    {-# INLINE toZoned #-}+    toZoned :: (TimeZone, UTCTime) -> ZonedTime+    toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz++    {-# INLINE fromZoned #-}+    fromZoned :: ZonedTime -> (TimeZone, UTCTime)+    fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt)++#if SHOW_INTERNAL+deriving instance Show ZonedTime+instance Show UTCTime where+    showsPrec p = showsPrec p . view utcTime+#else+instance Show ZonedTime where+    showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz+instance Show UTCTime where+    showsPrec p = showsPrec p . view zonedTime . (,) utc+#endif++-- | Get the current local date, time, and time zone.+--+-- @+-- > 'getZonedTime'+-- 2016-04-23 11:57:22.516064 JST+-- @+--+-- See also: 'getCurrentTime', 'Data.Thyme.Clock.POSIX.getPOSIXTime'.+{-# INLINE getZonedTime #-}+getZonedTime :: IO ZonedTime+getZonedTime = utcToLocalZonedTime =<< getCurrentTime++-- | Convert a 'UTCTime' to a 'ZonedTime' according to the local time zone+-- returned by 'getTimeZone'.+--+-- See also: 'zonedTime'.+{-# INLINEABLE utcToLocalZonedTime #-}+utcToLocalZonedTime :: UTCTime -> IO ZonedTime+utcToLocalZonedTime time = do+    tz <- getTimeZone time+    return $ (tz, time) ^. zonedTime++-- * Compatibility++-- | Convert a UTC 'TimeOfDay' to a 'TimeOfDay' in some timezone, together+-- with a day adjustment.+--+-- @+-- 'utcToLocalTimeOfDay' = 'addMinutes' '.' 'timeZoneMinutes'+-- @+{-# INLINE utcToLocalTimeOfDay #-}+utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay)+utcToLocalTimeOfDay = addMinutes . timeZoneMinutes++-- | Convert a 'TimeOfDay' in some timezone to a UTC 'TimeOfDay', together+-- with a day adjustment.+--+-- @+-- 'localToUTCTimeOfDay' = 'addMinutes' '.' 'negate' '.' 'timeZoneMinutes'+-- @+{-# INLINE localToUTCTimeOfDay #-}+localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay)+localToUTCTimeOfDay = addMinutes . negate . timeZoneMinutes++-- | Convert a 'DiffTime' of the duration since midnight to a 'TimeOfDay'.+-- Durations exceeding 24 hours will be treated as leap-seconds.+--+-- @+-- 'timeToTimeOfDay' = 'view' 'timeOfDay'+-- 'timeToTimeOfDay' d ≡ d '^.' 'timeOfDay'+-- @+{-# INLINE timeToTimeOfDay #-}+timeToTimeOfDay :: DiffTime -> TimeOfDay+timeToTimeOfDay = view timeOfDay++-- | Convert a 'TimeOfDay' to a 'DiffTime' of the duration since midnight.+-- 'TimeOfDay' greater than 24 hours will be treated as leap-seconds.+--+-- @+-- 'timeOfDayToTime' = 'review' 'timeOfDay'+-- 'timeOfDayToTime' tod ≡ 'timeOfDay' 'Control.Lens.#' tod+-- @+{-# INLINE timeOfDayToTime #-}+timeOfDayToTime :: TimeOfDay -> DiffTime+timeOfDayToTime = review timeOfDay++-- | Convert a fraction of a day since midnight to a 'TimeOfDay'.+--+-- @+-- 'dayFractionToTimeOfDay' = 'review' 'dayFraction'+-- @+{-# INLINE dayFractionToTimeOfDay #-}+dayFractionToTimeOfDay :: Rational -> TimeOfDay+dayFractionToTimeOfDay = review dayFraction++-- | Convert a 'TimeOfDay' to a fraction of a day since midnight.+--+-- @+-- 'timeOfDayToDayFraction' = 'view' 'dayFraction'+-- @+{-# INLINE timeOfDayToDayFraction #-}+timeOfDayToDayFraction :: TimeOfDay -> Rational+timeOfDayToDayFraction = view dayFraction++-- | Convert a 'UTCTime' to a 'LocalTime' in the given 'TimeZone'.+--+-- @+-- 'utcToLocalTime' = 'view' '.' 'utcLocalTime'+-- @+{-# INLINE utcToLocalTime #-}+utcToLocalTime :: TimeZone -> UTCTime -> LocalTime+utcToLocalTime tz = view (utcLocalTime tz)++-- | Convert a 'LocalTime' in the given 'TimeZone' to a 'UTCTime'.+--+-- @+-- 'localTimeToUTC' = 'review' '.' 'utcLocalTime'+-- @+{-# INLINE localTimeToUTC #-}+localTimeToUTC :: TimeZone -> LocalTime -> UTCTime+localTimeToUTC tz = review (utcLocalTime tz)++-- | Convert a 'UniversalTime' to a 'LocalTime' at the given medidian in+-- degrees East.+--+-- @+-- 'ut1ToLocalTime' = 'view' '.' 'ut1LocalTime'+-- @+{-# INLINE ut1ToLocalTime #-}+ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime+ut1ToLocalTime l = view (ut1LocalTime l)++-- | Convert a 'LocalTime' at the given meridian in degrees East to+-- a 'UniversalTime'.+--+-- @+-- 'localTimeToUT1' = 'review' '.' 'ut1LocalTime'+-- @+{-# INLINE localTimeToUT1 #-}+localTimeToUT1 :: Rational -> LocalTime -> UniversalTime+localTimeToUT1 l = review (ut1LocalTime l)++-- | Convert a 'UTCTime' and the given 'TimeZone' into a 'ZonedTime'.+--+-- @+-- 'utcToZonedTime' z t = 'view' 'zonedTime' (z, t)+-- @+{-# INLINE utcToZonedTime #-}+utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime+utcToZonedTime z t = view zonedTime (z, t)++-- | Converts a 'ZonedTime' to a 'UTCTime'.+--+-- @+-- 'zonedTimeToUTC' = 'snd' '.' 'review' 'zonedTime'+-- @+{-# INLINE zonedTimeToUTC #-}+zonedTimeToUTC :: ZonedTime -> UTCTime+zonedTimeToUTC = snd . review zonedTime+

src/Data/Thyme/Time.hs view

@@ -1,78 +1,78 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | This module provides 'Num', 'Real', 'Fractional', and 'RealFrac'
--- instances for 'DiffTime' and 'NominalDiffTime'.
-module Data.Thyme.Time
-    ( module Data.Thyme.Time.Core
-    {- instance RealFrac {,Nominal}DiffTime -}
-    ) where
-
-import Prelude
-import Data.Thyme.Internal.Micro
-import Data.Ratio
-import Data.Thyme
-import Data.Thyme.Clock.Internal
-import Data.Thyme.Time.Core
-
-instance Num Micro where
-    {-# INLINE (+) #-}
-    {-# INLINE (-) #-}
-    {-# INLINE (*) #-}
-    {-# INLINE negate #-}
-    {-# INLINE abs #-}
-    {-# INLINE signum #-}
-    {-# INLINE fromInteger #-}
-    Micro a + Micro b = Micro (a + b)
-    Micro a - Micro b = Micro (a - b)
-    Micro a * Micro b = Micro (quot a 1000 * quot b 1000)
-    negate (Micro a) = Micro (negate a)
-    abs (Micro a) = Micro (abs a)
-    signum (Micro a) = Micro (signum a * 1000000)
-    fromInteger a = Micro (fromInteger a * 1000000)
-
-instance Real Micro where
-    {-# INLINE toRational #-}
-    toRational (Micro a) = toInteger a % 1000000
-
-instance Fractional Micro where
-    {-# INLINE (/) #-}
-    {-# INLINE recip #-}
-    {-# INLINE fromRational #-}
-    Micro a / Micro b = Micro (quot (a * 1000) (b `quot` 1000))
-    recip (Micro a) = Micro (quot 1000000 a)
-    fromRational r = Micro (round $ r * 1000000)
-
-instance RealFrac Micro where
-    {-# INLINE properFraction #-}
-    properFraction a = (fromIntegral q, r) where
-        (q, r) = microQuotRem a (Micro 1000000)
-
-deriving instance Num DiffTime
-deriving instance Real DiffTime
-deriving instance Fractional DiffTime
-deriving instance RealFrac DiffTime
-
-deriving instance Num NominalDiffTime
-deriving instance Real NominalDiffTime
-deriving instance Fractional NominalDiffTime
-deriving instance RealFrac NominalDiffTime
-
-{-# RULES
-
-"realToFrac/DiffTime-NominalDiffTime"
-    realToFrac = \ (DiffTime d) -> NominalDiffTime d
-"realToFrac/NominalDiffTime-DiffTime"
-    realToFrac = \ (NominalDiffTime d) -> DiffTime d
-
-"realToFrac/DiffTime-Fractional"
-    realToFrac = toSeconds :: (Fractional n) => DiffTime -> n
-"realToFrac/NominalDiffTime-Fractional"
-    realToFrac = toSeconds :: (Fractional n) => NominalDiffTime -> n
-
-"realToFrac/Real-DiffTime"
-    realToFrac = fromSeconds :: (Real n) => n -> DiffTime
-"realToFrac/Real-NominalDiffTime"
-    realToFrac = fromSeconds :: (Real n) => n -> NominalDiffTime #-}
-
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module provides 'Num', 'Real', 'Fractional', and 'RealFrac'+-- instances for 'DiffTime' and 'NominalDiffTime'.+module Data.Thyme.Time+    ( module Data.Thyme.Time.Core+    {- instance RealFrac {,Nominal}DiffTime -}+    ) where++import Prelude+import Data.Thyme.Internal.Micro+import Data.Ratio+import Data.Thyme+import Data.Thyme.Clock.Internal+import Data.Thyme.Time.Core++instance Num Micro where+    {-# INLINE (+) #-}+    {-# INLINE (-) #-}+    {-# INLINE (*) #-}+    {-# INLINE negate #-}+    {-# INLINE abs #-}+    {-# INLINE signum #-}+    {-# INLINE fromInteger #-}+    Micro a + Micro b = Micro (a + b)+    Micro a - Micro b = Micro (a - b)+    Micro a * Micro b = Micro (quot a 1000 * quot b 1000)+    negate (Micro a) = Micro (negate a)+    abs (Micro a) = Micro (abs a)+    signum (Micro a) = Micro (signum a * 1000000)+    fromInteger a = Micro (fromInteger a * 1000000)++instance Real Micro where+    {-# INLINE toRational #-}+    toRational (Micro a) = toInteger a % 1000000++instance Fractional Micro where+    {-# INLINE (/) #-}+    {-# INLINE recip #-}+    {-# INLINE fromRational #-}+    Micro a / Micro b = Micro (quot (a * 1000) (b `quot` 1000))+    recip (Micro a) = Micro (quot 1000000 a)+    fromRational r = Micro (round $ r * 1000000)++instance RealFrac Micro where+    {-# INLINE properFraction #-}+    properFraction a = (fromIntegral q, r) where+        (q, r) = microQuotRem a (Micro 1000000)++deriving instance Num DiffTime+deriving instance Real DiffTime+deriving instance Fractional DiffTime+deriving instance RealFrac DiffTime++deriving instance Num NominalDiffTime+deriving instance Real NominalDiffTime+deriving instance Fractional NominalDiffTime+deriving instance RealFrac NominalDiffTime++{-# RULES++"realToFrac/DiffTime-NominalDiffTime"+    realToFrac = \ (DiffTime d) -> NominalDiffTime d+"realToFrac/NominalDiffTime-DiffTime"+    realToFrac = \ (NominalDiffTime d) -> DiffTime d++"realToFrac/DiffTime-Fractional"+    realToFrac = toSeconds :: (Fractional n) => DiffTime -> n+"realToFrac/NominalDiffTime-Fractional"+    realToFrac = toSeconds :: (Fractional n) => NominalDiffTime -> n++"realToFrac/Real-DiffTime"+    realToFrac = fromSeconds :: (Real n) => n -> DiffTime+"realToFrac/Real-NominalDiffTime"+    realToFrac = fromSeconds :: (Real n) => n -> NominalDiffTime #-}+

src/Data/Thyme/Time/Core.hs view

@@ -1,155 +1,155 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
--- | This module provides the 'Thyme' typeclass, and instances for
--- converting between "Data.Time" and "Data.Thyme" types. It also provides
--- compatibility wrappers for existing code using "Data.Time".
---
--- Note that we do not provide 'Num' hierarchy instances for 'DiffTime' nor
--- 'NominalDiffTime' here. If you want to use them anyway despite parts of
--- them being ill-defined (e.g. @('*')@ on 'DiffTime'), import
--- "Data.Thyme.Time" instead.
-
-module Data.Thyme.Time.Core
-    ( module Data.Thyme
-    , module Data.Thyme.Time.Core
-    ) where
-
-import Prelude
-import Control.Lens
-import Data.AffineSpace
-import Data.Fixed
-import Data.Ratio
-import Data.Thyme
-import Data.Thyme.Clock.TAI
-import qualified Data.Time.Calendar as T
-import qualified Data.Time.Clock as T
-import qualified Data.Time.Clock.TAI as T
-import qualified Data.Time.LocalTime as T
-import Data.Thyme.TrueName
-
-------------------------------------------------------------------------
--- * Type conversion
-
--- | Typeclass for converting between "Data.Time" and "Data.Thyme" types.
-class Thyme time thyme | thyme -> time where
-    -- | Convert between "Data.Time" and "Data.Thyme" types.
-    --
-    -- @
-    -- > :set -t
-    -- > import qualified "Data.Time"
-    --
-    -- > 'thyme' 'Control.Lens.#' ('fromSeconds'' 10 :: 'DiffTime')
-    -- 10s
-    -- it :: 'Data.Time.DiffTime'
-    --
-    -- > 'Data.Time.secondsToDiffTime' 10 '^.' 'thyme' :: 'DiffTime'
-    -- 10s
-    -- it :: 'DiffTime'
-    -- @
-    thyme :: Iso' time thyme
-
-instance Thyme T.Day Day where
-    {-# INLINE thyme #-}
-    thyme = iso
-        (ModifiedJulianDay . fromInteger . T.toModifiedJulianDay)
-        (T.ModifiedJulianDay . toInteger . toModifiedJulianDay)
-
-instance Thyme T.UniversalTime UniversalTime where
-    {-# INLINE thyme #-}
-    thyme = iso T.getModJulianDate T.ModJulianDate . from modJulianDate
-
-instance Thyme T.DiffTime DiffTime where
-    {-# INLINE thyme #-}
-    thyme = dt . fixed . from picoseconds where
-        dt = iso (\ [truename| ''T.DiffTime MkDiffTime | ps |] -> ps )
-            [truename| ''T.DiffTime MkDiffTime |]
-#if MIN_VERSION_base(4,7,0)
-        fixed = iso (\ (MkFixed n) -> n ) MkFixed
-#else
-        fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n )
-            [truename| ''Fixed MkFixed |]
-#endif
-
-instance Thyme T.NominalDiffTime NominalDiffTime where
-    {-# INLINE thyme #-}
-    thyme = ndt . fixed . from picoseconds where
-        ndt = iso (\ [truename| ''T.NominalDiffTime MkNominalDiffTime | ps |] -> ps )
-            [truename| ''T.NominalDiffTime MkNominalDiffTime |]
-#if MIN_VERSION_base(4,7,0)
-        fixed = iso (\ (MkFixed n) -> n ) MkFixed
-#else
-        fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n )
-            [truename| ''Fixed MkFixed |]
-#endif
-
-instance Thyme T.UTCTime UTCView where
-    {-# INLINE thyme #-}
-    thyme = iso
-        (\ (T.UTCTime d t) -> UTCView (d ^. thyme) (t ^. thyme))
-        (\ (UTCView d t) -> T.UTCTime (thyme # d) (thyme # t))
-
-instance Thyme T.UTCTime UTCTime where
-    {-# INLINE thyme #-}
-    thyme = thyme . from utcTime
-
-instance Thyme T.AbsoluteTime AbsoluteTime where
-    {-# INLINE thyme #-}
-    thyme = iso (`T.diffAbsoluteTime` T.taiEpoch)
-            (`T.addAbsoluteTime` T.taiEpoch)
-        . thyme . iso (taiEpoch .+^) (.-. taiEpoch)
-
-instance Thyme T.TimeZone TimeZone where
-    {-# INLINE thyme #-}
-    thyme = iso (\ T.TimeZone {..} -> TimeZone {..})
-        (\ TimeZone {..} -> T.TimeZone {..})
-
-instance Thyme T.TimeOfDay TimeOfDay where
-    {-# INLINE thyme #-}
-    thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m $
-            microseconds # round (s * 1000000) )
-        ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational $
-            toInteger (s ^. microseconds) % 1000000 )
-
-instance Thyme T.LocalTime LocalTime where
-    {-# INLINE thyme #-}
-    thyme = iso
-        (\ (T.LocalTime d t) -> LocalTime (d ^. thyme) (t ^. thyme))
-        (\ (LocalTime d t) -> T.LocalTime (thyme # d) (thyme # t))
-
-instance Thyme T.ZonedTime ZonedTime where
-    {-# INLINE thyme #-}
-    thyme = iso
-        (\ (T.ZonedTime t z) -> ZonedTime (t ^. thyme) (z ^. thyme))
-        (\ (ZonedTime t z) -> T.ZonedTime (thyme # t) (thyme # z))
-
--- | Convert a "Data.Time" type to a "Data.Thyme" type, if you would rather
--- not use "Control.Lens" directly.
---
--- @
--- 'toThyme' = 'view' 'thyme'
--- 'toThyme' t ≡ t '^.' 'thyme'
--- @
-{-# INLINE toThyme #-}
-toThyme :: (Thyme time thyme) => time -> thyme
-toThyme = view thyme
-
--- | Convert a "Data.Thyme" type to a "Data.Time" type, if you would rather
--- not use "Control.Lens" directly.
---
--- @
--- 'fromThyme' = 'review' 'thyme'
--- 'fromThyme' t ≡ 'thyme' 'Control.Lens.#' t
--- @
-{-# INLINE fromThyme #-}
-fromThyme :: (Thyme time thyme) => thyme -> time
-fromThyme = review thyme
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++#if HLINT+#include "cabal_macros.h"+#endif++-- | This module provides the 'Thyme' typeclass, and instances for+-- converting between "Data.Time" and "Data.Thyme" types. It also provides+-- compatibility wrappers for existing code using "Data.Time".+--+-- Note that we do not provide 'Num' hierarchy instances for 'DiffTime' nor+-- 'NominalDiffTime' here. If you want to use them anyway despite parts of+-- them being ill-defined (e.g. @('*')@ on 'DiffTime'), import+-- "Data.Thyme.Time" instead.++module Data.Thyme.Time.Core+    ( module Data.Thyme+    , module Data.Thyme.Time.Core+    ) where++import Prelude+import Control.Lens+import Data.AffineSpace+import Data.Fixed+import Data.Ratio+import Data.Thyme+import Data.Thyme.Clock.TAI+import qualified Data.Time.Calendar as T+import qualified Data.Time.Clock as T+import qualified Data.Time.Clock.TAI as T+import qualified Data.Time.LocalTime as T+import Data.Thyme.TrueName++------------------------------------------------------------------------+-- * Type conversion++-- | Typeclass for converting between "Data.Time" and "Data.Thyme" types.+class Thyme time thyme | thyme -> time where+    -- | Convert between "Data.Time" and "Data.Thyme" types.+    --+    -- @+    -- > :set -t+    -- > import qualified "Data.Time"+    --+    -- > 'thyme' 'Control.Lens.#' ('fromSeconds'' 10 :: 'DiffTime')+    -- 10s+    -- it :: 'Data.Time.DiffTime'+    --+    -- > 'Data.Time.secondsToDiffTime' 10 '^.' 'thyme' :: 'DiffTime'+    -- 10s+    -- it :: 'DiffTime'+    -- @+    thyme :: Iso' time thyme++instance Thyme T.Day Day where+    {-# INLINE thyme #-}+    thyme = iso+        (ModifiedJulianDay . fromInteger . T.toModifiedJulianDay)+        (T.ModifiedJulianDay . toInteger . toModifiedJulianDay)++instance Thyme T.UniversalTime UniversalTime where+    {-# INLINE thyme #-}+    thyme = iso T.getModJulianDate T.ModJulianDate . from modJulianDate++instance Thyme T.DiffTime DiffTime where+    {-# INLINE thyme #-}+    thyme = dt . fixed . from picoseconds where+        dt = iso (\ [truename| ''T.DiffTime MkDiffTime | ps |] -> ps )+            [truename| ''T.DiffTime MkDiffTime |]+#if MIN_VERSION_base(4,7,0)+        fixed = iso (\ (MkFixed n) -> n ) MkFixed+#else+        fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n )+            [truename| ''Fixed MkFixed |]+#endif++instance Thyme T.NominalDiffTime NominalDiffTime where+    {-# INLINE thyme #-}+    thyme = ndt . fixed . from picoseconds where+        ndt = iso (\ [truename| ''T.NominalDiffTime MkNominalDiffTime | ps |] -> ps )+            [truename| ''T.NominalDiffTime MkNominalDiffTime |]+#if MIN_VERSION_base(4,7,0)+        fixed = iso (\ (MkFixed n) -> n ) MkFixed+#else+        fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n )+            [truename| ''Fixed MkFixed |]+#endif++instance Thyme T.UTCTime UTCView where+    {-# INLINE thyme #-}+    thyme = iso+        (\ (T.UTCTime d t) -> UTCView (d ^. thyme) (t ^. thyme))+        (\ (UTCView d t) -> T.UTCTime (thyme # d) (thyme # t))++instance Thyme T.UTCTime UTCTime where+    {-# INLINE thyme #-}+    thyme = thyme . from utcTime++instance Thyme T.AbsoluteTime AbsoluteTime where+    {-# INLINE thyme #-}+    thyme = iso (`T.diffAbsoluteTime` T.taiEpoch)+            (`T.addAbsoluteTime` T.taiEpoch)+        . thyme . iso (taiEpoch .+^) (.-. taiEpoch)++instance Thyme T.TimeZone TimeZone where+    {-# INLINE thyme #-}+    thyme = iso (\ T.TimeZone {..} -> TimeZone {..})+        (\ TimeZone {..} -> T.TimeZone {..})++instance Thyme T.TimeOfDay TimeOfDay where+    {-# INLINE thyme #-}+    thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m $+            microseconds # round (s * 1000000) )+        ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational $+            toInteger (s ^. microseconds) % 1000000 )++instance Thyme T.LocalTime LocalTime where+    {-# INLINE thyme #-}+    thyme = iso+        (\ (T.LocalTime d t) -> LocalTime (d ^. thyme) (t ^. thyme))+        (\ (LocalTime d t) -> T.LocalTime (thyme # d) (thyme # t))++instance Thyme T.ZonedTime ZonedTime where+    {-# INLINE thyme #-}+    thyme = iso+        (\ (T.ZonedTime t z) -> ZonedTime (t ^. thyme) (z ^. thyme))+        (\ (ZonedTime t z) -> T.ZonedTime (thyme # t) (thyme # z))++-- | Convert a "Data.Time" type to a "Data.Thyme" type, if you would rather+-- not use "Control.Lens" directly.+--+-- @+-- 'toThyme' = 'view' 'thyme'+-- 'toThyme' t ≡ t '^.' 'thyme'+-- @+{-# INLINE toThyme #-}+toThyme :: (Thyme time thyme) => time -> thyme+toThyme = view thyme++-- | Convert a "Data.Thyme" type to a "Data.Time" type, if you would rather+-- not use "Control.Lens" directly.+--+-- @+-- 'fromThyme' = 'review' 'thyme'+-- 'fromThyme' t ≡ 'thyme' 'Control.Lens.#' t+-- @+{-# INLINE fromThyme #-}+fromThyme :: (Thyme time thyme) => thyme -> time+fromThyme = review thyme+

src/Data/Thyme/TrueName.hs view

@@ -1,423 +1,423 @@-{-# LANGUAGE CPP #-}
-
--- | Refer to <https://github.com/liyang/true-name/blob/master/test/sanity.hs these examples>.
-
-module Data.Thyme.TrueName (summon, truename) where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Monad
-import Data.List (nub)
-import Language.Haskell.TH.Ppr
-import Language.Haskell.TH.PprLib
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH.Syntax
-
-conNames :: Con -> [Name]{- {{{ -}
-conNames con = case con of
-    NormalC name _ -> [name]
-    RecC name vbts -> name : [ fname | (fname, _, _) <- vbts ]
-    InfixC _ name _ -> [name]
-    ForallC _ _ con' -> conNames con'
-
-#if MIN_VERSION_template_haskell(2,11,0)
-    GadtC names _ typ -> names ++ typNames typ
-    RecGadtC names vbts typ -> names ++ typNames typ
-         ++ [ fname | (fname, _, _) <- vbts]
-#endif
-{- }}} -}
-
-decNames :: Dec -> [Name]{- {{{ -}
-decNames dec = case dec of
-    FunD _ _ -> []
-    ValD _ _ _ -> []
-    TySynD _ _ typ -> typNames typ
-    ClassD _ _ _ _ decs -> decNames =<< decs
-#if MIN_VERSION_template_haskell(2,11,0)
-    InstanceD _ cxt typ decs ->
-#else
-    InstanceD cxt typ decs ->
-#endif
-        (predNames =<< cxt) ++ typNames typ ++ (decNames =<< decs)
-    SigD name typ -> name : typNames typ
-
-#if MIN_VERSION_template_haskell(2,16,0)
-    KiSigD name kind -> name : typNames kind
-#endif
-
-    ForeignD frgn -> case frgn of
-        ImportF _ _ _ name t -> name : typNames t
-        ExportF _ _ name t -> name : typNames t
-    PragmaD _ -> []
-
-#if MIN_VERSION_template_haskell(2,11,0)
-    DataD _ _ _ _ cons _ -> conNames =<< cons
-    NewtypeD _ _ _ _ con _ -> conNames con
-#else
-    DataD _ _ _ cons _ -> conNames =<< cons
-    NewtypeD _ _ _ con _ -> conNames con
-#endif
-
-#if MIN_VERSION_template_haskell(2,12,0)
-    PatSynD _name _args _dir _pat -> []
-    PatSynSigD _name typ -> typNames typ
-#endif
-
-#if MIN_VERSION_template_haskell(2,8,0)
-    InfixD _ _ -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,12,0)
-    DataInstD cxt _name _typs _kind cons derivs   ->
-        datatypeNames cxt cons  ++ derivNames derivs
-    NewtypeInstD cxt _name _typs _kind con derivs ->
-        datatypeNames cxt [con] ++ derivNames derivs
-#elif MIN_VERSION_template_haskell(2,11,0)
-    DataInstD cxt _ _ _ cons derivs ->
-        datatypeNames cxt cons  ++ (predNames =<< derivs)
-    NewtypeInstD cxt _ _ _ con derivs ->
-        datatypeNames cxt [con] ++ (predNames =<< derivs)
-#else
-    DataInstD cxt _ _ cons derivs   -> datatypeNames cxt cons  ++ derivs
-    NewtypeInstD cxt _ _ con derivs -> datatypeNames cxt [con] ++ derivs
-#endif
-
-#if MIN_VERSION_template_haskell(2,11,0)
-    DataFamilyD _ _ _ -> []
-    OpenTypeFamilyD _ -> []
-#else
-    FamilyD _ _ _ _ -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,11,0)
-    ClosedTypeFamilyD _ tses -> tseNames =<< tses
-#elif MIN_VERSION_template_haskell(2,9,0)
-    ClosedTypeFamilyD _ _ _ tses -> tseNames =<< tses
-#endif
-
-#if MIN_VERSION_template_haskell(2,15,0)
-    TySynInstD tse -> tseNames tse
-#elif MIN_VERSION_template_haskell(2,9,0)
-    TySynInstD _ tse -> tseNames tse
-#else
-    TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t
-#endif
-
-#if MIN_VERSION_template_haskell(2,9,0)
-    RoleAnnotD _ _ -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,12,0)
-    StandaloneDerivD _strat cxt typ -> (predNames =<< cxt) ++ typNames typ
-#elif MIN_VERSION_template_haskell(2,10,0)
-    StandaloneDerivD cxt typ -> (predNames =<< cxt) ++ typNames typ
-#endif
-
-#if MIN_VERSION_template_haskell(2,10,0)
-    DefaultSigD _ _ -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,15,0)
-    ImplicitParamBindD _ _ -> []
-#endif
-
-{- }}} -}
-
-datatypeNames :: Cxt -> [Con] -> [Name]
-datatypeNames cxt cons = (conNames =<< cons) ++ (predNames =<< cxt)
-
-#if MIN_VERSION_template_haskell(2,12,0)
-derivNames :: [DerivClause] -> [Name]
-derivNames derivs = predNames =<<
-    [ p | DerivClause _strat cxt <- derivs, p <- cxt ]
-#endif
-
-tseNames :: TySynEqn -> [Name]
-#if MIN_VERSION_template_haskell(2,15,0)
-tseNames (TySynEqn _ l r) = typNames l ++ typNames r
-#elif MIN_VERSION_template_haskell(2,9,0)
-tseNames (TySynEqn ts t) = (typNames =<< ts) ++ typNames t
-#endif
-
-predNames :: Pred -> [Name]{- {{{ -}
-#if MIN_VERSION_template_haskell(2,10,0)
-predNames = typNames
-#else
-predNames p = case p of
-    ClassP n ts -> n : (typNames =<< ts)
-    EqualP s t -> typNames s ++ typNames t
-#endif
-{- }}} -}
-
-typNames :: Type -> [Name]{- {{{ -}
-typNames typ = case typ of
-    ForallT _ c t -> (predNames =<< c) ++ typNames t
-    AppT s t -> typNames s ++ typNames t
-    SigT t _ -> typNames t
-    VarT _ -> []
-    ConT name -> [name]
-    TupleT _ -> []
-    UnboxedTupleT _ -> []
-    ArrowT -> []
-    ListT -> []
-
-#if MIN_VERSION_template_haskell(2,8,0)
-    PromotedT _ -> []
-    PromotedTupleT _ -> []
-    PromotedNilT -> []
-    PromotedConsT -> []
-    StarT -> []
-    ConstraintT -> []
-    LitT _ -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,10,0)
-    EqualityT -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,11,0)
-    InfixT s n t -> n : typNames s ++ typNames t
-    UInfixT s n t -> n : typNames s ++ typNames t
-    ParensT t -> typNames t
-    WildCardT -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,12,0)
-    UnboxedSumT _arity -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,15,0)
-    AppKindT k t -> typNames k ++ typNames t
-    ImplicitParamT _ t -> typNames t
-#endif
-
-#if MIN_VERSION_template_haskell(2,16,0)
-    ForallVisT _ t -> typNames t
-#endif
-
-#if MIN_VERSION_template_haskell(2,17,0)
-    MulArrowT -> []
-#endif
-
-#if MIN_VERSION_template_haskell(2,19,0)
-    PromotedInfixT s n t -> n : typNames s ++ typNames t
-    PromotedUInfixT s n t -> n : typNames s ++ typNames t
-#endif
-{- }}} -}
-
-infoNames :: Info -> [Name]{- {{{ -}
-infoNames info = case info of
-    ClassI dec _ -> decNames dec
-    TyConI dec -> decNames dec
-    FamilyI _ decs -> decNames =<< decs
-    PrimTyConI _ _ _ -> []
-    TyVarI _ typ -> typNames typ
-
-#if MIN_VERSION_template_haskell(2,11,0)
-    ClassOpI _ typ _ -> typNames typ
-    DataConI _ typ parent -> parent : typNames typ
-    VarI _ typ _ -> typNames typ
-#else
-    ClassOpI _ typ _ _ -> typNames typ
-    DataConI _ typ parent _ -> parent : typNames typ
-    VarI _ typ _ _ -> typNames typ
-#endif
-
-#if MIN_VERSION_template_haskell(2,12,0)
-    PatSynI _name typ -> typNames typ
-#endif
-{- }}} -}
-
-{- {{{ -}
--- | Summons a 'Name' using @template-haskell@'s 'reify' function.
---
--- The first argument is a 'String' matching the 'Name' we want: either its
--- 'nameBase', or qualified with its module. The second argument gives the
--- 'Name' to 'reify'.
---
--- If no match is found or there is some ambiguity, 'summon' will fail with
--- a list of 'Name's found, along with the output of 'reify' for reference.
---
--- Suppose we are given a module @M@ that exports a function @s@, but not
--- the type @T@, the constrcutor @C@, nor the field @f@:
---
--- > module M (s) where
--- > newtype T = C { f :: Int }
--- > s :: T -> T
--- > s = C . succ . f
---
--- In our own module we have no legitimate way of passing @s@ an argument of
--- type @T@. We can get around this in a type-safe way with 'summon':
---
--- >{-# LANGUAGE TemplateHaskell #-}
--- >module Main where
--- >import Language.Haskell.TH.Syntax
--- >import Unsafe.TrueName
--- >import M
--- >
--- >type T = $(fmap ConT $ summon "T" 's)
--- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int
--- >mkC = $(fmap ConE $ summon "C" =<< summon "T" 's)
--- >unC $(fmap (`ConP` [VarP $ mkName "n"]) $ summon "C" =<< summon "T" 's) = n
--- >f = $(fmap VarE $ summon "f" =<< summon "T" 's)
--- >
--- >main :: IO ()
--- >main = print (unC t, n) where
--- >    t = s (mkC 42 :: T)
--- >    n = f (s t)
---
--- Note that 'summon' cannot obtain the 'Name' for an unexported function,
--- since GHC <http://hackage.haskell.org/package/template-haskell/docs/Language-Haskell-TH.html#v:VarI does not currently return the RHS of function definitons>.
--- The only workaround is to copypasta the definition. D:
-{- }}} -}
-summon :: String -> Name -> Q Name{- {{{ -}
-summon name thing = do
-    info <- reify thing
-    let ns = nub (infoNames info)
-    case filter (\ n -> name == nameBase n || name == show n) ns of
-        [n] -> return n
-        _ -> fail $ "summon: you wanted " ++ show name ++ ", but I have:\n"
-            ++ unlines ((++) "        " . namespace <$> ns)
-            ++ "    reify " ++ show thing ++ " returned:\n"
-            ++ show (nest 8 $ ppr info)
-  where
-    namespace n@(Name _ flavour) = show n ++ case flavour of
-        NameG VarName _ _ -> " (var)"
-        NameG DataName _ _ -> " (cons)"
-        NameG TcClsName _ _ -> " (type)"
-        _ -> " (?)"
-{- }}} -}
-
-{- {{{ -}
--- | A more convenient 'QuasiQuoter' interface to 'summon'.
---
--- The first space-delimited token gives the initial 'Name' passed to
--- 'summon': it must be ‘quoted’ with a @'@ or @''@ prefix to indicate
--- whether it should be interpreted in an expression or a type context,
--- as per <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/template-haskell.html#th-syntax the usual TH syntax>.
--- Subsequent tokens correspond to the 'String' argument of 'summon', and
--- are iterated over. Thus
---
--- > [truename| ''A B C D |]
---
--- is roughly equivalent to:
---
--- > summon "D" =<< summon "C" =<< summon "B" ''A
---
--- but with the resulting 'Name' wrapped up in 'ConE', 'VarE', 'ConP', or
--- 'ConT', depending on the context. (There is no 'quoteDec'.)
---
--- Variable bindings are given after a @|@ token in a 'Pat' context:
---
--- > [truename| ''Chan Chan | chanR chanW |] <- newChan
---
--- These may be prefixed with @!@ or @~@ to give the usual semantics.
--- A single @..@ token invokes @RecordWildCards@ in 'Pat' contexts, and for
--- record construction in 'Exp' contexts.
--- Nested or more exotic patterns are not supported.
---
--- With this, the example from 'summon' may be more succinctly written:
---
--- >{-# LANGUAGE QuasiQuotes #-}
--- >module Main where
--- >import Unsafe.TrueName
--- >import M
--- >
--- >type T = [truename| 's T |]
--- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int
--- >mkC = [truename| 's T C |]
--- >unC [truename| 's T C | n |] = n
--- >f = [truename| 's T f |]
--- >
--- >main :: IO ()
--- >main = print (unC t, n) where
--- >    t = s (mkC 42 :: T)
--- >    n = f (s t)
-{- }}} -}
-truename :: QuasiQuoter{- {{{ -}
-truename = QuasiQuoter
-    { quoteExp = makeE <=< nameVars
-    , quotePat = makeP <=< nameVars
-    , quoteType = makeT <=< nameVars
-    , quoteDec = \ _ -> err "I'm not sure how this would work"
-    } where
-    err = fail . (++) "truename: "
-    noPat = err . (++) "unexpected pattern variables: " . unwords
-
-    makeT (name, vars) = ConT name <$ unless (null vars) (noPat vars)
-    makeE (name@(Name occ flavour), vars) = case flavour of
-        NameG VarName _ _ -> VarE name <$ unless (null vars) (noPat vars)
-        NameG DataName _ _ -> case vars of
-            [] -> return (ConE name)
-            [".."] -> RecConE name . capture VarE <$> recFields name
-            _ -> noPat vars
-        _ -> err $ occString occ ++ " has a strange flavour"
-    makeP (name, vars) = if vars == [".."]
-            then RecP name . capture VarP <$> recFields name
-            else
-#if MIN_VERSION_template_haskell(2,18,0)
-              return $ ConP name [] (map pat vars) where
-#else
-              return $ ConP name (map pat vars) where
-#endif
-        pat n = case n of
-            "_" -> WildP
-            '!' : ns -> BangP (pat ns)
-            '~' : ns -> TildeP (pat ns)
-            _ -> VarP (mkName n)
-    capture v = map $ \ f -> (f, v (mkName $ nameBase f))
-
-    recFields :: Name -> Q [Name]
-    recFields name = do
-        parent <- reify name >>= \ info -> case info of
-#if MIN_VERSION_template_haskell(2,11,0)
-            DataConI _ _ p -> return p
-#else
-            DataConI _ _ p _ -> return p
-#endif
-            _ -> err $ show name ++ " is not a data constructor"
-        dec <- reify parent >>= \ info -> case info of
-            TyConI d -> return d
-            _ -> err $ "parent " ++ show parent ++ " is not a plain type"
-        case dec of
-#if MIN_VERSION_template_haskell(2,11,0)
-            DataD _ _ _ _ cs _ -> return (fields =<< cs)
-            NewtypeD _ _ _ _ c _ -> return (fields c)
-#else
-            DataD _ _ _ cs _ -> return (fields =<< cs)
-            NewtypeD _ _ _ c _ -> return (fields c)
-#endif
-            _ -> err $ "parent " ++ show parent ++ " neither data nor newtype"
-      where
-        fields :: Con -> [Name]
-        fields con = case con of
-            NormalC _ _ -> []
-            RecC n vbts -> if n /= name then [] else [ v | (v, _, _) <- vbts ]
-            InfixC _ _ _ -> []
-            ForallC _ _ c -> fields c
-#if MIN_VERSION_template_haskell(2,11,0)
-            GadtC _ _ _ -> []
-            RecGadtC ns vbts _ -> if name `notElem` ns then []
-                else [ v | (v, _, _) <- vbts ]
-#endif
-
-    lookupThing :: String -> Q Name
-    lookupThing s0 = case s0 of
-        '\'' : s1 -> case s1 of
-            '\'' : s2 -> hmm s2 "lookupTypeName" =<< lookupTypeName s2
-            _ -> hmm s1 "lookupValueName" =<< lookupValueName s1
-        _ -> err $ "please specify either '" ++ s0 ++ " or ''" ++ s0
-      where
-        hmm s l = maybe (err $ unwords [l, show s, "failed"]) return
-
-    nameVars :: String -> Q (Name, [String])
-    nameVars spec = case words spec of
-        [] -> err "expecting at least one token"
-        start : rest -> do
-            thing <- lookupThing start
-            let (names, vars) = break ("|" ==) rest
-            name <- foldM (flip summon) thing names
-            return (name, dropWhile ("|" ==) vars)
-{- }}} -}
+{-# LANGUAGE CPP #-}++-- | Refer to <https://github.com/liyang/true-name/blob/master/test/sanity.hs these examples>.++module Data.Thyme.TrueName (summon, truename) where++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad+import Data.List (nub)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.PprLib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++conNames :: Con -> [Name]{- {{{ -}+conNames con = case con of+    NormalC name _ -> [name]+    RecC name vbts -> name : [ fname | (fname, _, _) <- vbts ]+    InfixC _ name _ -> [name]+    ForallC _ _ con' -> conNames con'++#if MIN_VERSION_template_haskell(2,11,0)+    GadtC names _ typ -> names ++ typNames typ+    RecGadtC names vbts typ -> names ++ typNames typ+         ++ [ fname | (fname, _, _) <- vbts]+#endif+{- }}} -}++decNames :: Dec -> [Name]{- {{{ -}+decNames dec = case dec of+    FunD _ _ -> []+    ValD _ _ _ -> []+    TySynD _ _ typ -> typNames typ+    ClassD _ _ _ _ decs -> decNames =<< decs+#if MIN_VERSION_template_haskell(2,11,0)+    InstanceD _ cxt typ decs ->+#else+    InstanceD cxt typ decs ->+#endif+        (predNames =<< cxt) ++ typNames typ ++ (decNames =<< decs)+    SigD name typ -> name : typNames typ++#if MIN_VERSION_template_haskell(2,16,0)+    KiSigD name kind -> name : typNames kind+#endif++    ForeignD frgn -> case frgn of+        ImportF _ _ _ name t -> name : typNames t+        ExportF _ _ name t -> name : typNames t+    PragmaD _ -> []++#if MIN_VERSION_template_haskell(2,11,0)+    DataD _ _ _ _ cons _ -> conNames =<< cons+    NewtypeD _ _ _ _ con _ -> conNames con+#else+    DataD _ _ _ cons _ -> conNames =<< cons+    NewtypeD _ _ _ con _ -> conNames con+#endif++#if MIN_VERSION_template_haskell(2,12,0)+    PatSynD _name _args _dir _pat -> []+    PatSynSigD _name typ -> typNames typ+#endif++#if MIN_VERSION_template_haskell(2,8,0)+    InfixD _ _ -> []+#endif++#if MIN_VERSION_template_haskell(2,12,0)+    DataInstD cxt _name _typs _kind cons derivs   ->+        datatypeNames cxt cons  ++ derivNames derivs+    NewtypeInstD cxt _name _typs _kind con derivs ->+        datatypeNames cxt [con] ++ derivNames derivs+#elif MIN_VERSION_template_haskell(2,11,0)+    DataInstD cxt _ _ _ cons derivs ->+        datatypeNames cxt cons  ++ (predNames =<< derivs)+    NewtypeInstD cxt _ _ _ con derivs ->+        datatypeNames cxt [con] ++ (predNames =<< derivs)+#else+    DataInstD cxt _ _ cons derivs   -> datatypeNames cxt cons  ++ derivs+    NewtypeInstD cxt _ _ con derivs -> datatypeNames cxt [con] ++ derivs+#endif++#if MIN_VERSION_template_haskell(2,11,0)+    DataFamilyD _ _ _ -> []+    OpenTypeFamilyD _ -> []+#else+    FamilyD _ _ _ _ -> []+#endif++#if MIN_VERSION_template_haskell(2,11,0)+    ClosedTypeFamilyD _ tses -> tseNames =<< tses+#elif MIN_VERSION_template_haskell(2,9,0)+    ClosedTypeFamilyD _ _ _ tses -> tseNames =<< tses+#endif++#if MIN_VERSION_template_haskell(2,15,0)+    TySynInstD tse -> tseNames tse+#elif MIN_VERSION_template_haskell(2,9,0)+    TySynInstD _ tse -> tseNames tse+#else+    TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t+#endif++#if MIN_VERSION_template_haskell(2,9,0)+    RoleAnnotD _ _ -> []+#endif++#if MIN_VERSION_template_haskell(2,12,0)+    StandaloneDerivD _strat cxt typ -> (predNames =<< cxt) ++ typNames typ+#elif MIN_VERSION_template_haskell(2,10,0)+    StandaloneDerivD cxt typ -> (predNames =<< cxt) ++ typNames typ+#endif++#if MIN_VERSION_template_haskell(2,10,0)+    DefaultSigD _ _ -> []+#endif++#if MIN_VERSION_template_haskell(2,15,0)+    ImplicitParamBindD _ _ -> []+#endif++{- }}} -}++datatypeNames :: Cxt -> [Con] -> [Name]+datatypeNames cxt cons = (conNames =<< cons) ++ (predNames =<< cxt)++#if MIN_VERSION_template_haskell(2,12,0)+derivNames :: [DerivClause] -> [Name]+derivNames derivs = predNames =<<+    [ p | DerivClause _strat cxt <- derivs, p <- cxt ]+#endif++tseNames :: TySynEqn -> [Name]+#if MIN_VERSION_template_haskell(2,15,0)+tseNames (TySynEqn _ l r) = typNames l ++ typNames r+#elif MIN_VERSION_template_haskell(2,9,0)+tseNames (TySynEqn ts t) = (typNames =<< ts) ++ typNames t+#endif++predNames :: Pred -> [Name]{- {{{ -}+#if MIN_VERSION_template_haskell(2,10,0)+predNames = typNames+#else+predNames p = case p of+    ClassP n ts -> n : (typNames =<< ts)+    EqualP s t -> typNames s ++ typNames t+#endif+{- }}} -}++typNames :: Type -> [Name]{- {{{ -}+typNames typ = case typ of+    ForallT _ c t -> (predNames =<< c) ++ typNames t+    AppT s t -> typNames s ++ typNames t+    SigT t _ -> typNames t+    VarT _ -> []+    ConT name -> [name]+    TupleT _ -> []+    UnboxedTupleT _ -> []+    ArrowT -> []+    ListT -> []++#if MIN_VERSION_template_haskell(2,8,0)+    PromotedT _ -> []+    PromotedTupleT _ -> []+    PromotedNilT -> []+    PromotedConsT -> []+    StarT -> []+    ConstraintT -> []+    LitT _ -> []+#endif++#if MIN_VERSION_template_haskell(2,10,0)+    EqualityT -> []+#endif++#if MIN_VERSION_template_haskell(2,11,0)+    InfixT s n t -> n : typNames s ++ typNames t+    UInfixT s n t -> n : typNames s ++ typNames t+    ParensT t -> typNames t+    WildCardT -> []+#endif++#if MIN_VERSION_template_haskell(2,12,0)+    UnboxedSumT _arity -> []+#endif++#if MIN_VERSION_template_haskell(2,15,0)+    AppKindT k t -> typNames k ++ typNames t+    ImplicitParamT _ t -> typNames t+#endif++#if MIN_VERSION_template_haskell(2,16,0)+    ForallVisT _ t -> typNames t+#endif++#if MIN_VERSION_template_haskell(2,17,0)+    MulArrowT -> []+#endif++#if MIN_VERSION_template_haskell(2,19,0)+    PromotedInfixT s n t -> n : typNames s ++ typNames t+    PromotedUInfixT s n t -> n : typNames s ++ typNames t+#endif+{- }}} -}++infoNames :: Info -> [Name]{- {{{ -}+infoNames info = case info of+    ClassI dec _ -> decNames dec+    TyConI dec -> decNames dec+    FamilyI _ decs -> decNames =<< decs+    PrimTyConI _ _ _ -> []+    TyVarI _ typ -> typNames typ++#if MIN_VERSION_template_haskell(2,11,0)+    ClassOpI _ typ _ -> typNames typ+    DataConI _ typ parent -> parent : typNames typ+    VarI _ typ _ -> typNames typ+#else+    ClassOpI _ typ _ _ -> typNames typ+    DataConI _ typ parent _ -> parent : typNames typ+    VarI _ typ _ _ -> typNames typ+#endif++#if MIN_VERSION_template_haskell(2,12,0)+    PatSynI _name typ -> typNames typ+#endif+{- }}} -}++{- {{{ -}+-- | Summons a 'Name' using @template-haskell@'s 'reify' function.+--+-- The first argument is a 'String' matching the 'Name' we want: either its+-- 'nameBase', or qualified with its module. The second argument gives the+-- 'Name' to 'reify'.+--+-- If no match is found or there is some ambiguity, 'summon' will fail with+-- a list of 'Name's found, along with the output of 'reify' for reference.+--+-- Suppose we are given a module @M@ that exports a function @s@, but not+-- the type @T@, the constrcutor @C@, nor the field @f@:+--+-- > module M (s) where+-- > newtype T = C { f :: Int }+-- > s :: T -> T+-- > s = C . succ . f+--+-- In our own module we have no legitimate way of passing @s@ an argument of+-- type @T@. We can get around this in a type-safe way with 'summon':+--+-- >{-# LANGUAGE TemplateHaskell #-}+-- >module Main where+-- >import Language.Haskell.TH.Syntax+-- >import Unsafe.TrueName+-- >import M+-- >+-- >type T = $(fmap ConT $ summon "T" 's)+-- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int+-- >mkC = $(fmap ConE $ summon "C" =<< summon "T" 's)+-- >unC $(fmap (`ConP` [VarP $ mkName "n"]) $ summon "C" =<< summon "T" 's) = n+-- >f = $(fmap VarE $ summon "f" =<< summon "T" 's)+-- >+-- >main :: IO ()+-- >main = print (unC t, n) where+-- >    t = s (mkC 42 :: T)+-- >    n = f (s t)+--+-- Note that 'summon' cannot obtain the 'Name' for an unexported function,+-- since GHC <http://hackage.haskell.org/package/template-haskell/docs/Language-Haskell-TH.html#v:VarI does not currently return the RHS of function definitons>.+-- The only workaround is to copypasta the definition. D:+{- }}} -}+summon :: String -> Name -> Q Name{- {{{ -}+summon name thing = do+    info <- reify thing+    let ns = nub (infoNames info)+    case filter (\ n -> name == nameBase n || name == show n) ns of+        [n] -> return n+        _ -> fail $ "summon: you wanted " ++ show name ++ ", but I have:\n"+            ++ unlines ((++) "        " . namespace <$> ns)+            ++ "    reify " ++ show thing ++ " returned:\n"+            ++ show (nest 8 $ ppr info)+  where+    namespace n@(Name _ flavour) = show n ++ case flavour of+        NameG VarName _ _ -> " (var)"+        NameG DataName _ _ -> " (cons)"+        NameG TcClsName _ _ -> " (type)"+        _ -> " (?)"+{- }}} -}++{- {{{ -}+-- | A more convenient 'QuasiQuoter' interface to 'summon'.+--+-- The first space-delimited token gives the initial 'Name' passed to+-- 'summon': it must be ‘quoted’ with a @'@ or @''@ prefix to indicate+-- whether it should be interpreted in an expression or a type context,+-- as per <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/template-haskell.html#th-syntax the usual TH syntax>.+-- Subsequent tokens correspond to the 'String' argument of 'summon', and+-- are iterated over. Thus+--+-- > [truename| ''A B C D |]+--+-- is roughly equivalent to:+--+-- > summon "D" =<< summon "C" =<< summon "B" ''A+--+-- but with the resulting 'Name' wrapped up in 'ConE', 'VarE', 'ConP', or+-- 'ConT', depending on the context. (There is no 'quoteDec'.)+--+-- Variable bindings are given after a @|@ token in a 'Pat' context:+--+-- > [truename| ''Chan Chan | chanR chanW |] <- newChan+--+-- These may be prefixed with @!@ or @~@ to give the usual semantics.+-- A single @..@ token invokes @RecordWildCards@ in 'Pat' contexts, and for+-- record construction in 'Exp' contexts.+-- Nested or more exotic patterns are not supported.+--+-- With this, the example from 'summon' may be more succinctly written:+--+-- >{-# LANGUAGE QuasiQuotes #-}+-- >module Main where+-- >import Unsafe.TrueName+-- >import M+-- >+-- >type T = [truename| 's T |]+-- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int+-- >mkC = [truename| 's T C |]+-- >unC [truename| 's T C | n |] = n+-- >f = [truename| 's T f |]+-- >+-- >main :: IO ()+-- >main = print (unC t, n) where+-- >    t = s (mkC 42 :: T)+-- >    n = f (s t)+{- }}} -}+truename :: QuasiQuoter{- {{{ -}+truename = QuasiQuoter+    { quoteExp = makeE <=< nameVars+    , quotePat = makeP <=< nameVars+    , quoteType = makeT <=< nameVars+    , quoteDec = \ _ -> err "I'm not sure how this would work"+    } where+    err = fail . (++) "truename: "+    noPat = err . (++) "unexpected pattern variables: " . unwords++    makeT (name, vars) = ConT name <$ unless (null vars) (noPat vars)+    makeE (name@(Name occ flavour), vars) = case flavour of+        NameG VarName _ _ -> VarE name <$ unless (null vars) (noPat vars)+        NameG DataName _ _ -> case vars of+            [] -> return (ConE name)+            [".."] -> RecConE name . capture VarE <$> recFields name+            _ -> noPat vars+        _ -> err $ occString occ ++ " has a strange flavour"+    makeP (name, vars) = if vars == [".."]+            then RecP name . capture VarP <$> recFields name+            else+#if MIN_VERSION_template_haskell(2,18,0)+              return $ ConP name [] (map pat vars) where+#else+              return $ ConP name (map pat vars) where+#endif+        pat n = case n of+            "_" -> WildP+            '!' : ns -> BangP (pat ns)+            '~' : ns -> TildeP (pat ns)+            _ -> VarP (mkName n)+    capture v = map $ \ f -> (f, v (mkName $ nameBase f))++    recFields :: Name -> Q [Name]+    recFields name = do+        parent <- reify name >>= \ info -> case info of+#if MIN_VERSION_template_haskell(2,11,0)+            DataConI _ _ p -> return p+#else+            DataConI _ _ p _ -> return p+#endif+            _ -> err $ show name ++ " is not a data constructor"+        dec <- reify parent >>= \ info -> case info of+            TyConI d -> return d+            _ -> err $ "parent " ++ show parent ++ " is not a plain type"+        case dec of+#if MIN_VERSION_template_haskell(2,11,0)+            DataD _ _ _ _ cs _ -> return (fields =<< cs)+            NewtypeD _ _ _ _ c _ -> return (fields c)+#else+            DataD _ _ _ cs _ -> return (fields =<< cs)+            NewtypeD _ _ _ c _ -> return (fields c)+#endif+            _ -> err $ "parent " ++ show parent ++ " neither data nor newtype"+      where+        fields :: Con -> [Name]+        fields con = case con of+            NormalC _ _ -> []+            RecC n vbts -> if n /= name then [] else [ v | (v, _, _) <- vbts ]+            InfixC _ _ _ -> []+            ForallC _ _ c -> fields c+#if MIN_VERSION_template_haskell(2,11,0)+            GadtC _ _ _ -> []+            RecGadtC ns vbts _ -> if name `notElem` ns then []+                else [ v | (v, _, _) <- vbts ]+#endif++    lookupThing :: String -> Q Name+    lookupThing s0 = case s0 of+        '\'' : s1 -> case s1 of+            '\'' : s2 -> hmm s2 "lookupTypeName" =<< lookupTypeName s2+            _ -> hmm s1 "lookupValueName" =<< lookupValueName s1+        _ -> err $ "please specify either '" ++ s0 ++ " or ''" ++ s0+      where+        hmm s l = maybe (err $ unwords [l, show s, "failed"]) return++    nameVars :: String -> Q (Name, [String])+    nameVars spec = case words spec of+        [] -> err "expecting at least one token"+        start : rest -> do+            thing <- lookupThing start+            let (names, vars) = break ("|" ==) rest+            name <- foldM (flip summon) thing names+            return (name, dropWhile ("|" ==) vars)+{- }}} -}

tests/Common.hs view

@@ -1,78 +1,78 @@-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Common where
-
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Lens
-import Data.AdditiveGroup
-import Data.Char
-import Data.Thyme
-import Data.Thyme.Clock.POSIX
-import System.Exit
-import Test.QuickCheck
-import qualified Test.QuickCheck.Gen as Gen
-
-exit :: Bool -> IO ()
-exit b = exitWith $ if b then ExitSuccess else ExitFailure 1
-
-------------------------------------------------------------------------
-
--- FIXME: We disagree with time on how many digits to use for year.
-newtype RecentTime = RecentTime UTCTime deriving (Show)
-
-instance Arbitrary RecentTime where
-    arbitrary = fmap (RecentTime . review utcTime) $ UTCView
-            <$> choose (minDay, maxDay)
-            <*> choose (zeroV, pred dayLength) where
-        minDay = gregorian # YearMonthDay 1000 1 1
-        maxDay = gregorian # YearMonthDay 9999 12 13
-        dayLength = posixDayLength ^. microseconds . from microseconds
-
-------------------------------------------------------------------------
-
-newtype Spec = Spec String deriving (Show)
-
-instance Arbitrary Spec where
-    arbitrary = do
-        -- Pick a non-overlapping day spec generator.
-        day <- Gen.elements
-            [ spec {-YearMonthDay-}"DFYyCBbhmde"
-            , spec {-OrdinalDate-}"YyCj"
-            -- TODO: time only consider the presence of %V as
-            -- indication that it should parse as WeekDate
-            , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa"
-            , spec {-SundayWeek-}"YyCUuwAa"
-            , spec {-MondayWeek-}"YyCWuwAa"
-            ] :: Gen (Gen String)
-        -- Pick a non-overlapping day & tod spec generator.
-        time <- Gen.frequency
-            [ (16, pure $ Gen.frequency
-                [ (8, day)
-                , (4, rod)
-                , (2, h12)
-                , (1, sec)
-                , (1, spec {-TimeZone-}"zZ")
-                ] )
-            -- TODO: these are broken due to issues above and below
-            -- , (2, pure $ spec {-aggregate-}"crXx")
-            , (1, pure $ spec {-UTCTime-}"s")
-            ] :: Gen (Gen String)
-        fmap (Spec . dropWhile isSpace . unwords) . listOf1 $ frequency
-            [(16, time), (4, string), (1, pure "%%")]
-      where
-        spec = Gen.elements . fmap (\ c -> ['%', c])
-        string = filter ('%' /=) <$> arbitrary
-        -- TODO: time discards %q %Q or %p %P after setting %S or hours
-        -- respectively. Fudge it by always including %q and %p at end.
-        -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ"
-        rod = spec {-RestOfDay-}"RHkMqQ"
-        sec = (++ " %q") <$> spec {-seconds-}"ST"
-        h12 = (++ " %p") <$> spec {-12-hour-}"Il"
-
+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Common where++#if HLINT+#include "cabal_macros.h"+#endif++import Prelude+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Lens+import Data.AdditiveGroup+import Data.Char+import Data.Thyme+import Data.Thyme.Clock.POSIX+import System.Exit+import Test.QuickCheck+import qualified Test.QuickCheck.Gen as Gen++exit :: Bool -> IO ()+exit b = exitWith $ if b then ExitSuccess else ExitFailure 1++------------------------------------------------------------------------++-- FIXME: We disagree with time on how many digits to use for year.+newtype RecentTime = RecentTime UTCTime deriving (Show)++instance Arbitrary RecentTime where+    arbitrary = fmap (RecentTime . review utcTime) $ UTCView+            <$> choose (minDay, maxDay)+            <*> choose (zeroV, pred dayLength) where+        minDay = gregorian # YearMonthDay 1000 1 1+        maxDay = gregorian # YearMonthDay 9999 12 13+        dayLength = posixDayLength ^. microseconds . from microseconds++------------------------------------------------------------------------++newtype Spec = Spec String deriving (Show)++instance Arbitrary Spec where+    arbitrary = do+        -- Pick a non-overlapping day spec generator.+        day <- Gen.elements+            [ spec {-YearMonthDay-}"DFYyCBbhmde"+            , spec {-OrdinalDate-}"YyCj"+            -- TODO: time only consider the presence of %V as+            -- indication that it should parse as WeekDate+            , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa"+            , spec {-SundayWeek-}"YyCUuwAa"+            , spec {-MondayWeek-}"YyCWuwAa"+            ] :: Gen (Gen String)+        -- Pick a non-overlapping day & tod spec generator.+        time <- Gen.frequency+            [ (16, pure $ Gen.frequency+                [ (8, day)+                , (4, rod)+                , (2, h12)+                , (1, sec)+                , (1, spec {-TimeZone-}"zZ")+                ] )+            -- TODO: these are broken due to issues above and below+            -- , (2, pure $ spec {-aggregate-}"crXx")+            , (1, pure $ spec {-UTCTime-}"s")+            ] :: Gen (Gen String)+        fmap (Spec . dropWhile isSpace . unwords) . listOf1 $ frequency+            [(16, time), (4, string), (1, pure "%%")]+      where+        spec = Gen.elements . fmap (\ c -> ['%', c])+        string = filter ('%' /=) <$> arbitrary+        -- TODO: time discards %q %Q or %p %P after setting %S or hours+        -- respectively. Fudge it by always including %q and %p at end.+        -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ"+        rod = spec {-RestOfDay-}"RHkMqQ"+        sec = (++ " %q") <$> spec {-seconds-}"ST"+        h12 = (++ " %p") <$> spec {-12-hour-}"Il"+

tests/bench.hs view

@@ -1,2 +1,2 @@-main :: IO ()
-main = return ()
+main :: IO ()+main = return ()

tests/hlint.hs view

@@ -1,19 +1,19 @@-module Main where
-
-import Control.Monad
-import Language.Haskell.HLint
-import System.Exit
-
-main :: IO ()
-main = (`unless` exitFailure) . null =<< hlint
-    [ "src", "tests"
-    , "--cpp-define=HLINT=1"
-    , "--cpp-include=include"
-    , "--cpp-include=dist/build/autogen"
-    , "--cpp-define=SHOW_INTERNAL=1"
-    , "-i", "Reduce duplication"
-    , "-i", "Redundant lambda"
-    , "-i", "Use if"
-    , "-i", "Use import/export shortcut"
-    ]
-
+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Exit++main :: IO ()+main = (`unless` exitFailure) . null =<< hlint+    [ "src", "tests"+    , "--cpp-define=HLINT=1"+    , "--cpp-include=include"+    , "--cpp-include=dist/build/autogen"+    , "--cpp-define=SHOW_INTERNAL=1"+    , "-i", "Reduce duplication"+    , "-i", "Redundant lambda"+    , "-i", "Use if"+    , "-i", "Use import/export shortcut"+    ]+

tests/rewrite.hs view

@@ -1,59 +1,59 @@-{-# OPTIONS_GHC -O2 -dumpdir dump -ddump-to-file -ddump-rule-firings #-}
-
-import Prelude
-import Data.Int
-import Data.List (stripPrefix)
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Thyme.Time
-import System.Exit
-import System.Random
-
-main :: IO ()
-main = do
-    useless
-    checkRuleFirings "dump/tests/rewrite.dump-rule-firings"
-
-checkRuleFirings :: FilePath -> IO ()
-checkRuleFirings file = do
-    dump <- readFile file
-    let strip = maybe id Set.insert . stripPrefix "Rule fired: "
-    let fired = foldr strip Set.empty (lines dump)
-    let unmatched = wanted `Set.difference` fired
-    case Set.null unmatched of
-        True -> do
-            putStrLn "All wanted rules fired."
-            exitSuccess
-        False -> do
-            putStrLn "Unmatched rules:"
-            mapM_ (putStrLn . (++) "  ") (Set.toList unmatched)
-            exitWith (ExitFailure 1)
-
-useless :: IO ()
-useless = do
-    print =<< (fmap fromSeconds (randomIO :: IO Float)   :: IO DiffTime)
-    print =<< (fmap fromSeconds (randomIO :: IO Double)  :: IO NominalDiffTime)
-    print =<< (fmap fromSeconds (randomIO :: IO Int)     :: IO NominalDiffTime)
-    print =<< (fmap fromSeconds (randomIO :: IO Int64)   :: IO DiffTime)
-    print =<< (fmap fromSeconds (randomIO :: IO Integer) :: IO DiffTime)
-    print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO NominalDiffTime)
-    print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO DiffTime)
-    print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO Double)
-    print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO Double)
-    print =<< (fmap realToFrac (randomIO :: IO Float) :: IO NominalDiffTime)
-    print =<< (fmap realToFrac (randomIO :: IO Integer) :: IO DiffTime)
-
-wanted :: Set String
-wanted = Set.fromList
-    [ "fromSeconds/Float (Data.Thyme.Clock.Internal)"
-    , "fromSeconds/Double (Data.Thyme.Clock.Internal)"
-    , "fromSeconds/Int (Data.Thyme.Clock.Internal)"
-    , "fromSeconds/Int64 (Data.Thyme.Clock.Internal)"
-    , "fromSeconds/Integer (Data.Thyme.Clock.Internal)"
-    , "realToFrac/DiffTime-NominalDiffTime (Data.Thyme.Time)"
-    , "realToFrac/NominalDiffTime-DiffTime (Data.Thyme.Time)"
-    , "realToFrac/DiffTime-Fractional (Data.Thyme.Time)"
-    , "realToFrac/NominalDiffTime-Fractional (Data.Thyme.Time)"
-    , "realToFrac/Real-DiffTime (Data.Thyme.Time)"
-    , "realToFrac/Real-NominalDiffTime (Data.Thyme.Time)"
+{-# OPTIONS_GHC -O2 -dumpdir dump -ddump-to-file -ddump-rule-firings #-}++import Prelude+import Data.Int+import Data.List (stripPrefix)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Thyme.Time+import System.Exit+import System.Random++main :: IO ()+main = do+    useless+    checkRuleFirings "dump/tests/rewrite.dump-rule-firings"++checkRuleFirings :: FilePath -> IO ()+checkRuleFirings file = do+    dump <- readFile file+    let strip = maybe id Set.insert . stripPrefix "Rule fired: "+    let fired = foldr strip Set.empty (lines dump)+    let unmatched = wanted `Set.difference` fired+    case Set.null unmatched of+        True -> do+            putStrLn "All wanted rules fired."+            exitSuccess+        False -> do+            putStrLn "Unmatched rules:"+            mapM_ (putStrLn . (++) "  ") (Set.toList unmatched)+            exitWith (ExitFailure 1)++useless :: IO ()+useless = do+    print =<< (fmap fromSeconds (randomIO :: IO Float)   :: IO DiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Double)  :: IO NominalDiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Int)     :: IO NominalDiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Int64)   :: IO DiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Integer) :: IO DiffTime)+    print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO NominalDiffTime)+    print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO DiffTime)+    print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO Double)+    print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO Double)+    print =<< (fmap realToFrac (randomIO :: IO Float) :: IO NominalDiffTime)+    print =<< (fmap realToFrac (randomIO :: IO Integer) :: IO DiffTime)++wanted :: Set String+wanted = Set.fromList+    [ "fromSeconds/Float (Data.Thyme.Clock.Internal)"+    , "fromSeconds/Double (Data.Thyme.Clock.Internal)"+    , "fromSeconds/Int (Data.Thyme.Clock.Internal)"+    , "fromSeconds/Int64 (Data.Thyme.Clock.Internal)"+    , "fromSeconds/Integer (Data.Thyme.Clock.Internal)"+    , "realToFrac/DiffTime-NominalDiffTime (Data.Thyme.Time)"+    , "realToFrac/NominalDiffTime-DiffTime (Data.Thyme.Time)"+    , "realToFrac/DiffTime-Fractional (Data.Thyme.Time)"+    , "realToFrac/NominalDiffTime-Fractional (Data.Thyme.Time)"+    , "realToFrac/Real-DiffTime (Data.Thyme.Time)"+    , "realToFrac/Real-NominalDiffTime (Data.Thyme.Time)"     ]

tests/sanity.hs view

@@ -1,98 +1,98 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ViewPatterns #-}
-
-#if HLINT
-#include "cabal_macros.h"
-#endif
-
-import Prelude
-
-import Control.Arrow
-import Control.Lens
-import qualified Data.Attoparsec.ByteString.Char8 as P
-import Data.ByteString (ByteString)
-import Data.Thyme
-import Data.Thyme.Calendar.OrdinalDate
-import Data.Thyme.Time
-import qualified Data.Time as T
-import qualified Data.Time.Calendar.OrdinalDate as T
-import Test.QuickCheck
-
-import Common
-
-#if MIN_VERSION_bytestring(0,10,0)
-# if MIN_VERSION_bytestring(0,10,2)
-import qualified Data.ByteString.Builder as B
-# else
-import qualified Data.ByteString.Lazy.Builder as B
-# endif
-import qualified Data.ByteString.Lazy as L
-#else
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-#endif
-
-{-# INLINE utf8String #-}
-utf8String :: String -> ByteString
-#if MIN_VERSION_bytestring(0,10,0)
-utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8
-#else
-utf8String = Text.encodeUtf8 . Text.pack
-#endif
-
-------------------------------------------------------------------------
-
-prop_ShowRead :: (Eq a, Show a, Read a) => a -> Bool
-prop_ShowRead a = (a, "") `elem` reads (show a)
-
-prop_toOrdinalDate :: Day -> Bool
-prop_toOrdinalDate day =
-    fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day)
-
-prop_formatTime :: Spec -> RecentTime -> Property
-prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t'))
-#if MIN_VERSION_QuickCheck(2,7,0)
-        = counterexample desc (s == s') where
-#else
-        = printTestCase desc (s == s') where
-#endif
-    s = formatTime defaultTimeLocale spec t
-    s' = T.formatTime defaultTimeLocale spec t'
-    desc = "thyme: " ++ s ++ "\ntime:  " ++ s'
-
-prop_parseTime :: Spec -> RecentTime -> Property
-prop_parseTime (Spec spec) (RecentTime orig)
-#if MIN_VERSION_QuickCheck(2,7,0)
-        = counterexample desc (fmap (review thyme) t == t') where
-#else
-        = printTestCase desc (fmap (review thyme) t == t') where
-#endif
-    s = T.formatTime defaultTimeLocale spec (thyme # orig)
-    t = parseTime defaultTimeLocale spec s :: Maybe UTCTime
-#if MIN_VERSION_time(1,5,0)
-    t' = T.parseTimeM True defaultTimeLocale spec s
-#else
-    t' = T.parseTime defaultTimeLocale spec s
-#endif
-    tp = P.parse (timeParser defaultTimeLocale spec) . utf8String
-    desc = "input: " ++ show s ++ "\nthyme: " ++ show t
-        ++ "\ntime:  " ++ show t' ++ "\nstate: " ++ show (tp s)
-
-------------------------------------------------------------------------
-
-{-# ANN main "HLint: ignore Use list literal" #-}
-main :: IO ()
-main = exit . all isSuccess =<< sequence
-    [ qc 10000 (prop_ShowRead :: Day -> Bool)
-    , qc 10000 (prop_ShowRead :: DiffTime -> Bool)
-    , qc 10000 (prop_ShowRead :: NominalDiffTime -> Bool)
-    , qc 10000 (prop_ShowRead :: UTCTime -> Bool)
-    , qc 10000 prop_toOrdinalDate
-    , qc  1000 prop_formatTime
-    , qc  1000 prop_parseTime
-
-    ] where
-    isSuccess r = case r of Success {} -> True; _ -> False
-    qc :: Testable prop => Int -> prop -> IO Result
-    qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n}
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++#if HLINT+#include "cabal_macros.h"+#endif++import Prelude++import Control.Arrow+import Control.Lens+import qualified Data.Attoparsec.ByteString.Char8 as P+import Data.ByteString (ByteString)+import Data.Thyme+import Data.Thyme.Calendar.OrdinalDate+import Data.Thyme.Time+import qualified Data.Time as T+import qualified Data.Time.Calendar.OrdinalDate as T+import Test.QuickCheck++import Common++#if MIN_VERSION_bytestring(0,10,0)+# if MIN_VERSION_bytestring(0,10,2)+import qualified Data.ByteString.Builder as B+# else+import qualified Data.ByteString.Lazy.Builder as B+# endif+import qualified Data.ByteString.Lazy as L+#else+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+#endif++{-# INLINE utf8String #-}+utf8String :: String -> ByteString+#if MIN_VERSION_bytestring(0,10,0)+utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8+#else+utf8String = Text.encodeUtf8 . Text.pack+#endif++------------------------------------------------------------------------++prop_ShowRead :: (Eq a, Show a, Read a) => a -> Bool+prop_ShowRead a = (a, "") `elem` reads (show a)++prop_toOrdinalDate :: Day -> Bool+prop_toOrdinalDate day =+    fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day)++prop_formatTime :: Spec -> RecentTime -> Property+prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t'))+#if MIN_VERSION_QuickCheck(2,7,0)+        = counterexample desc (s == s') where+#else+        = printTestCase desc (s == s') where+#endif+    s = formatTime defaultTimeLocale spec t+    s' = T.formatTime defaultTimeLocale spec t'+    desc = "thyme: " ++ s ++ "\ntime:  " ++ s'++prop_parseTime :: Spec -> RecentTime -> Property+prop_parseTime (Spec spec) (RecentTime orig)+#if MIN_VERSION_QuickCheck(2,7,0)+        = counterexample desc (fmap (review thyme) t == t') where+#else+        = printTestCase desc (fmap (review thyme) t == t') where+#endif+    s = T.formatTime defaultTimeLocale spec (thyme # orig)+    t = parseTime defaultTimeLocale spec s :: Maybe UTCTime+#if MIN_VERSION_time(1,5,0)+    t' = T.parseTimeM True defaultTimeLocale spec s+#else+    t' = T.parseTime defaultTimeLocale spec s+#endif+    tp = P.parse (timeParser defaultTimeLocale spec) . utf8String+    desc = "input: " ++ show s ++ "\nthyme: " ++ show t+        ++ "\ntime:  " ++ show t' ++ "\nstate: " ++ show (tp s)++------------------------------------------------------------------------++{-# ANN main "HLint: ignore Use list literal" #-}+main :: IO ()+main = exit . all isSuccess =<< sequence+    [ qc 10000 (prop_ShowRead :: Day -> Bool)+    , qc 10000 (prop_ShowRead :: DiffTime -> Bool)+    , qc 10000 (prop_ShowRead :: NominalDiffTime -> Bool)+    , qc 10000 (prop_ShowRead :: UTCTime -> Bool)+    , qc 10000 prop_toOrdinalDate+    , qc  1000 prop_formatTime+    , qc  1000 prop_parseTime++    ] where+    isSuccess r = case r of Success {} -> True; _ -> False+    qc :: Testable prop => Int -> prop -> IO Result+    qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n}+

thyme.cabal view

@@ -1,202 +1,200 @@-name:           thyme
-version:        0.3.6
-synopsis:       A faster time library
-description:
-    @thyme@ is a performance-optimized rewrite of the excellent
-    @<http://hackage.haskell.org/package/time time>@ library.
-    .
-    See @<http://hackage.haskell.org/package/thyme/docs/Data-Thyme-Docs.html Data.Thyme.Docs>@
-    for a full description.
-homepage:       https://github.com/liyang/thyme
-license:        BSD3
-license-file:   LICENSE
-author:         Liyang HU, Ashley Yakeley
-maintainer:     Fumiaki Kinoshita <fumiexcel@gmail.com>
-copyright:      © 2013−2014 Liyang HU
-category:       Data, System
-build-type:     Simple
-cabal-version:  >= 1.10
-stability:      experimental
-extra-source-files:
-    CHANGELOG.md
-    README.md
-    include/thyme.h
-tested-with:
-    GHC == 7.6.3, GHC == 7.8.4,
-    GHC == 7.10.2, GHC == 7.10.3,
-    GHC >= 8.0 && < 8.2
-
-source-repository head
-    type:       git
-    location:   https://github.com/fumieval/thyme
-
-flag bug-for-bug
-    description: bug-for-bug compatibility with time
-    default: True
-    manual: True
-
-flag docs
-    description: include extra packages for Data.Thyme.Docs; implies -flens
-    default: False
-    manual: True
-
-flag HLint
-    description: include HLint as a Cabal test-suite
-    default: False
-    manual: True
-
-flag lens
-    description: use the full lens package
-    default: False
-    manual: True
-
-flag show-internal
-    description: instance Show of internal representation
-    default: False
-    manual: True
-
-library
-    default-language: Haskell2010
-    include-dirs: include
-    hs-source-dirs: src
-    if !(flag(lens) || flag(docs))
-        hs-source-dirs: lens
-    exposed-modules:
-        Data.Thyme
-        Data.Thyme.Docs
-        Data.Thyme.Calendar
-        Data.Thyme.Calendar.MonthDay
-        Data.Thyme.Calendar.OrdinalDate
-        Data.Thyme.Calendar.WeekDate
-        Data.Thyme.Calendar.WeekdayOfMonth
-        Data.Thyme.Clock
-        Data.Thyme.Clock.POSIX
-        Data.Thyme.Clock.TAI
-        Data.Thyme.Format
-        Data.Thyme.Format.Human
-        Data.Thyme.Format.Aeson
-        Data.Thyme.Internal.Micro
-        Data.Thyme.LocalTime
-        Data.Thyme.Time
-        Data.Thyme.Time.Core
-    other-modules:
-        Data.Thyme.Calendar.Internal
-        Data.Thyme.Clock.Internal
-        Data.Thyme.Format.Internal
-        Data.Thyme.TrueName
-    if !(flag(lens) || flag(docs))
-        other-modules: Control.Lens
-    build-depends:
-        QuickCheck >= 2.4,
-        attoparsec >= 0.10,
-        aeson >= 0.6,
-        base >= 4.5 && < 5,
-        bytestring >= 0.9,
-        containers >= 0.5,
-        deepseq >= 1.2,
-        hashable >= 1.2,
-        mtl >= 1.1,
-        old-locale >= 1.0,
-        random,
-        text >= 0.11,
-        template-haskell >= 2.7 && < 2.20,
-        time >= 1.4,
-        vector >= 0.9,
-        vector-th-unbox >= 0.2.1.0,
-        vector-space >= 0.8
-
-    if os(windows)
-        build-depends: Win32
-    if os(darwin) || os(freebsd)
-        build-tools: cpphs
-        ghc-options: "-pgmP cpphs --cpp"
-    if flag(lens) || flag(docs)
-        build-depends: lens >= 3.9
-    else
-        build-depends: profunctors >= 3.1.2
-    if flag(docs)
-        build-depends: integer-gmp, ghc-prim
-    ghc-options: -Wall
-    if flag(bug-for-bug)
-        cpp-options: -DBUG_FOR_BUG=1
-    if flag(show-internal)
-        cpp-options: -DSHOW_INTERNAL=1
-
-test-suite sanity
-    default-language: Haskell2010
-    type: exitcode-stdio-1.0
-    hs-source-dirs: tests
-    if !flag(lens)
-        hs-source-dirs: lens
-    main-is: sanity.hs
-    other-modules: Common
-    if !flag(lens)
-        other-modules: Control.Lens
-    build-depends:
-        QuickCheck,
-        attoparsec,
-        base,
-        bytestring,
-        old-locale,
-        text,
-        thyme,
-        time,
-        vector-space
-    if flag(lens)
-        build-depends: lens
-    else
-        build-depends: profunctors, mtl
-    ghc-options: -Wall
-
-test-suite rewrite
-    default-language: Haskell2010
-    type: exitcode-stdio-1.0
-    hs-source-dirs: tests
-    main-is: rewrite.hs
-    build-depends:
-        base,
-        containers,
-        random,
-        thyme
-    ghc-options: -Wall
-
-test-suite hlint
-    default-language: Haskell2010
-    type: exitcode-stdio-1.0
-    hs-source-dirs: tests
-    main-is: hlint.hs
-    ghc-options: -threaded -rtsopts -with-rtsopts=-N
-    if flag(HLint)
-        build-depends: base, hlint >= 1.9
-    else
-        buildable: False
-
-benchmark bench
-    default-language: Haskell2010
-    type: exitcode-stdio-1.0
-    hs-source-dirs: tests
-    if !flag(lens)
-        hs-source-dirs: lens
-    main-is: bench.hs
-    other-modules: Common
-    if !flag(lens)
-        other-modules: Control.Lens
-    build-depends:
-        QuickCheck,
-        base,
-        criterion,
-        mtl,
-        old-locale,
-        random,
-        thyme,
-        time,
-        vector,
-        vector-space
-    if flag(lens)
-        build-depends: lens
-    else
-        build-depends: profunctors
-    ghc-options: -Wall
-
--- vim: et sw=4 ts=4 sts=4:
-
+name:           thyme+version:        0.4+synopsis:       A faster time library+description:+    @thyme@ is a performance-optimized rewrite of the excellent+    @<http://hackage.haskell.org/package/time time>@ library.+    .+    See @<http://hackage.haskell.org/package/thyme/docs/Data-Thyme-Docs.html Data.Thyme.Docs>@+    for a full description.+homepage:       https://github.com/fumieval/thyme+license:        BSD3+license-file:   LICENSE+author:         Liyang HU, Ashley Yakeley+maintainer:     Fumiaki Kinoshita <fumiexcel@gmail.com>+copyright:      © 2013−2014 Liyang HU+category:       Data, System+build-type:     Simple+cabal-version:  >= 1.10+stability:      experimental+extra-source-files:+    CHANGELOG.md+    README.md+    include/thyme.h+tested-with:+    GHC >= 8.4 && < 9.6++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:+