├── .gitignore ├── tests ├── bench.hs ├── hlint.hs ├── rewrite.hs ├── Common.hs └── sanity.hs ├── Setup.hs ├── renovate.json ├── CHANGELOG.md ├── src └── Data │ ├── Thyme.hs │ └── Thyme │ ├── Calendar │ ├── MonthDay.hs │ ├── WeekDate.hs │ ├── WeekdayOfMonth.hs │ ├── OrdinalDate.hs │ └── Internal.hs │ ├── Time.hs │ ├── Format │ ├── Human.hs │ ├── Aeson.hs │ └── Internal.hs │ ├── Internal │ └── Micro.hs │ ├── Clock │ ├── POSIX.hsc │ ├── TAI.hs │ └── Internal.hs │ ├── Time │ └── Core.hs │ ├── Clock.hs │ ├── Calendar.hs │ ├── Docs.hs │ ├── TrueName.hs │ └── LocalTime.hs ├── config-dev ├── include └── thyme.h ├── README.md ├── upload-docs ├── LICENSE ├── .github └── workflows │ └── haskell.yml ├── lens └── Control │ └── Lens.hs └── thyme.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /dist-newstyle/ 3 | -------------------------------------------------------------------------------- /tests/bench.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = return () 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /renovate.json: -------------------------------------------------------------------------------- 1 | { 2 | "$schema": "https://docs.renovatebot.com/renovate-schema.json", 3 | "extends": [ 4 | "config:recommended" 5 | ] 6 | } 7 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## unreleased 2 | 3 | ## 0.4 4 | 5 | * Supported GHC 9 and older 6 | * 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. 7 | * Miscellaneous API additions and refactors -------------------------------------------------------------------------------- /src/Data/Thyme.hs: -------------------------------------------------------------------------------- 1 | -- | This simply re-exports some commonly-used modules. 2 | module Data.Thyme 3 | ( module Data.Thyme.Calendar 4 | , module Data.Thyme.Clock 5 | , module Data.Thyme.Format 6 | , module Data.Thyme.LocalTime 7 | ) where 8 | 9 | import Data.Thyme.Calendar 10 | import Data.Thyme.Clock 11 | import Data.Thyme.Format 12 | import Data.Thyme.LocalTime 13 | -------------------------------------------------------------------------------- /config-dev: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | set -x 3 | 4 | case "$1" in 5 | (--dump) shift && DUMP="-dumpdir dump -ddump-to-file -ddump-simpl \ 6 | -dsuppress-coercions -dsuppress-type-applications" ;; 7 | esac 8 | 9 | declare -a FLAGS=(-fWerror -fHLint --enable-tests --enable-benchmarks -O2) 10 | cabal configure "${FLAGS[@]}" ${DUMP:+"--ghc-options=$DUMP"} "$@" \ 11 | || cabal install --only-dependencies ${FLAGS[@]} "$@" 12 | 13 | -------------------------------------------------------------------------------- /include/thyme.h: -------------------------------------------------------------------------------- 1 | #define INSTANCES_USUAL Eq, Ord, Data, Typeable, Generic 2 | #define INSTANCES_NEWTYPE INSTANCES_USUAL, Enum, Ix, Hashable, NFData 3 | #define INSTANCES_MICRO INSTANCES_NEWTYPE, Bounded, Random, Arbitrary, CoArbitrary 4 | #define LensP Lens' 5 | #define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \ S {..} F/**/_ -> S {F = F/**/_, ..} 6 | 7 | #define W_GREGORIAN 8 | -------------------------------------------------------------------------------- /tests/hlint.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Language.Haskell.HLint 5 | import System.Exit 6 | 7 | main :: IO () 8 | main = (`unless` exitFailure) . null =<< hlint 9 | [ "src", "tests" 10 | , "--cpp-define=HLINT=1" 11 | , "--cpp-include=include" 12 | , "--cpp-include=dist/build/autogen" 13 | , "--cpp-define=SHOW_INTERNAL=1" 14 | , "-i", "Reduce duplication" 15 | , "-i", "Redundant lambda" 16 | , "-i", "Use if" 17 | , "-i", "Use import/export shortcut" 18 | ] 19 | 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # thyme 2 | 3 | [![CI](https://github.com/haskell-github-trust/thyme/actions/workflows/haskell.yml/badge.svg)](https://github.com/haskell-github-trust/thyme/actions/workflows/haskell.yml) [![Hackage](https://img.shields.io/hackage/v/thyme.svg?logo=haskell)](http://hackage.haskell.org/package/thyme) 4 | 5 | A faster date and time library based on [time][]. 6 | 7 | * Trades speed for slightly less precision: micro- (μs; 10-6) 8 | versus pico-seconds (ps; 10-12). 9 | * Better type-safety for date and time arithmetic. 10 | * Ships with a selection of [Iso'][]s and [Lens'][]s for [lens][]. 11 | 12 | ## Building 13 | 14 | ### Library 15 | 16 | ``` 17 | cabal build 18 | ``` 19 | 20 | ### Haddock 21 | 22 | ``` 23 | cabal haddock 24 | ``` 25 | 26 | [Iso']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Iso.html#t:Iso-39- 27 | [Lens']: http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens-39- 28 | [lens]: http://hackage.haskell.org/package/lens 29 | [time]: http://hackage.haskell.org/package/time 30 | 31 | -------------------------------------------------------------------------------- /upload-docs: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | set -e 3 | 4 | # Maintainer script to upload docs configured with -flens 5 | 6 | # http://fuuzetsu.co.uk/blog/posts/2014-01-06-Fix-your-Hackage-documentation.html 7 | # http://fuuzetsu.co.uk/blog/posts/2014-01-06-Hackage-documentation-v2.html 8 | # https://gist.github.com/Fuuzetsu/8276421 9 | 10 | PKG=thyme 11 | VER="$(sed -ne 's/^version: *//p' < $PKG.cabal)" 12 | TAR="$PKG-$VER-docs" 13 | USR="$(sed -ne 's/^username: *//p' < ~/.cabal/config)" 14 | PAS="$(sed -ne 's/^password: *//p' < ~/.cabal/config)" 15 | 16 | # link to real lens for documentation 17 | cabal configure -fdocs -flens 18 | 19 | cabal haddock --hyperlink-source --hoogle \ 20 | --contents-location='/package/$pkg' \ 21 | --html-location='/package/$pkg-$version/docs' 22 | 23 | tar -C dist/doc/html --format=ustar --show-transformed-names \ 24 | --transform="s#^$PKG#$TAR#" -c -v -z -f "dist/$TAR.tar.gz" "$PKG" 25 | 26 | curl -X PUT -u "$USR:$PAS" \ 27 | -H 'Content-Type: application/x-tar' \ 28 | -H 'Content-Encoding: gzip' \ 29 | --data-binary "@dist/$TAR.tar.gz" \ 30 | "http://hackage.haskell.org/package/$PKG-$VER/docs" 31 | 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Liyang HU 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Liyang HU nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: [macos-latest, ubuntu-latest] 16 | cabal: ["3.12"] 17 | ghc: ["8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.2.8", "9.4.8", "9.6.6", "9.8.4", "9.10.1"] 18 | exclude: 19 | - os: macos-latest 20 | ghc: "8.4.4" 21 | - os: macos-latest 22 | ghc: "8.6.5" 23 | - os: macos-latest 24 | ghc: "8.8.4" 25 | - os: macos-latest 26 | ghc: "8.10.7" 27 | - os: macos-latest 28 | ghc: "9.0.2" 29 | 30 | runs-on: ${{ matrix.os }} 31 | 32 | steps: 33 | - uses: actions/checkout@v4 34 | - uses: haskell-actions/setup@v2 35 | id: setup-haskell-cabal 36 | with: 37 | ghc-version: ${{ matrix.ghc }} 38 | cabal-version: ${{ matrix.cabal }} 39 | - name: Cabal Update 40 | run: | 41 | cabal v2-update 42 | cabal v2-freeze $CONFIG 43 | - uses: actions/cache@v4 44 | with: 45 | path: | 46 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 47 | dist-newstyle 48 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 49 | restore-keys: | 50 | ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}- 51 | - name: Build all 52 | run: | 53 | cabal build all 54 | cabal sdist all 55 | - name: Run tests 56 | run: | 57 | cabal test all 58 | - name: Build haddock 59 | run: | 60 | cabal haddock all 61 | -------------------------------------------------------------------------------- /src/Data/Thyme/Calendar/MonthDay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | #include "thyme.h" 6 | 7 | -- | Calendar months and day-of-months. 8 | module Data.Thyme.Calendar.MonthDay 9 | ( Month, DayOfMonth 10 | , MonthDay (..), _mdMonth, _mdDay 11 | , monthDay, monthDayValid, monthLength 12 | , module Data.Thyme.Calendar.MonthDay 13 | ) where 14 | 15 | import Prelude 16 | import Control.Lens 17 | import Data.Thyme.Calendar.Internal 18 | 19 | -- * Compatibility 20 | 21 | -- | Predicated on whether or not it is a leap year, convert an ordinal 22 | -- 'DayOfYear' to its corresponding 'Month' and 'DayOfMonth'. 23 | -- 24 | -- @ 25 | -- 'dayOfYearToMonthAndDay' leap ('view' ('monthDay' leap) -> 'MonthDay' m d) = (m, d) 26 | -- @ 27 | {-# INLINE dayOfYearToMonthAndDay #-} 28 | dayOfYearToMonthAndDay 29 | :: Bool -- ^ 'isLeapYear'? 30 | -> DayOfYear 31 | -> (Month, DayOfMonth) 32 | dayOfYearToMonthAndDay leap (view (monthDay leap) -> MonthDay m d) = (m, d) 33 | 34 | -- | Predicated on whether or not it is a leap year, convert a 'Month' and 35 | -- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'. 36 | -- Does not validate the input. 37 | -- 38 | -- @ 39 | -- 'monthAndDayToDayOfYear' leap m d = 'monthDay' leap 'Control.Lens.#' 'MonthDay' m d 40 | -- @ 41 | {-# INLINE monthAndDayToDayOfYear #-} 42 | monthAndDayToDayOfYear 43 | :: Bool -- ^ 'isLeapYear'? 44 | -> Month 45 | -> DayOfMonth 46 | -> DayOfYear 47 | monthAndDayToDayOfYear leap m d = monthDay leap # MonthDay m d 48 | 49 | -- | Predicated on whether or not it is a leap year, convert a 'Month' and 50 | -- 'DayOfMonth' to its corresponding ordinal 'DayOfYear'. 51 | -- Returns 'Nothing' for invalid input. 52 | -- 53 | -- @ 54 | -- 'monthAndDayToDayOfYearValid' leap m d = 'monthDayValid' leap ('MonthDay' m d) 55 | -- @ 56 | {-# INLINE monthAndDayToDayOfYearValid #-} 57 | monthAndDayToDayOfYearValid 58 | :: Bool -- ^ 'isLeapYear'? 59 | -> Month 60 | -> DayOfMonth 61 | -> Maybe DayOfYear 62 | monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d) 63 | 64 | -------------------------------------------------------------------------------- /tests/rewrite.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 -dumpdir dump -ddump-to-file -ddump-rule-firings #-} 2 | 3 | import Prelude 4 | import Data.Int 5 | import Data.List (stripPrefix) 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | import Data.Thyme.Time 9 | import System.Exit 10 | import System.Random 11 | 12 | main :: IO () 13 | main = do 14 | useless 15 | checkRuleFirings "dump/tests/rewrite.dump-rule-firings" 16 | 17 | checkRuleFirings :: FilePath -> IO () 18 | checkRuleFirings file = do 19 | dump <- readFile file 20 | let strip = maybe id Set.insert . stripPrefix "Rule fired: " 21 | let fired = foldr strip Set.empty (lines dump) 22 | let unmatched = wanted `Set.difference` fired 23 | case Set.null unmatched of 24 | True -> do 25 | putStrLn "All wanted rules fired." 26 | exitSuccess 27 | False -> do 28 | putStrLn "Unmatched rules:" 29 | mapM_ (putStrLn . (++) " ") (Set.toList unmatched) 30 | exitWith (ExitFailure 1) 31 | 32 | useless :: IO () 33 | useless = do 34 | print =<< (fmap fromSeconds (randomIO :: IO Float) :: IO DiffTime) 35 | print =<< (fmap fromSeconds (randomIO :: IO Double) :: IO NominalDiffTime) 36 | print =<< (fmap fromSeconds (randomIO :: IO Int) :: IO NominalDiffTime) 37 | print =<< (fmap fromSeconds (randomIO :: IO Int64) :: IO DiffTime) 38 | print =<< (fmap fromSeconds (randomIO :: IO Integer) :: IO DiffTime) 39 | print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO NominalDiffTime) 40 | print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO DiffTime) 41 | print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO Double) 42 | print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO Double) 43 | print =<< (fmap realToFrac (randomIO :: IO Float) :: IO NominalDiffTime) 44 | print =<< (fmap realToFrac (randomIO :: IO Integer) :: IO DiffTime) 45 | 46 | wanted :: Set String 47 | wanted = Set.fromList 48 | [ "fromSeconds/Float (Data.Thyme.Clock.Internal)" 49 | , "fromSeconds/Double (Data.Thyme.Clock.Internal)" 50 | , "fromSeconds/Int (Data.Thyme.Clock.Internal)" 51 | , "fromSeconds/Int64 (Data.Thyme.Clock.Internal)" 52 | , "fromSeconds/Integer (Data.Thyme.Clock.Internal)" 53 | , "realToFrac/DiffTime-NominalDiffTime (Data.Thyme.Time)" 54 | , "realToFrac/NominalDiffTime-DiffTime (Data.Thyme.Time)" 55 | , "realToFrac/DiffTime-Fractional (Data.Thyme.Time)" 56 | , "realToFrac/NominalDiffTime-Fractional (Data.Thyme.Time)" 57 | , "realToFrac/Real-DiffTime (Data.Thyme.Time)" 58 | , "realToFrac/Real-NominalDiffTime (Data.Thyme.Time)" 59 | ] -------------------------------------------------------------------------------- /src/Data/Thyme/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | -- | This module provides 'Num', 'Real', 'Fractional', and 'RealFrac' 6 | -- instances for 'DiffTime' and 'NominalDiffTime'. 7 | module Data.Thyme.Time 8 | ( module Data.Thyme.Time.Core 9 | {- instance RealFrac {,Nominal}DiffTime -} 10 | ) where 11 | 12 | import Prelude 13 | import Data.Thyme.Internal.Micro 14 | import Data.Ratio 15 | import Data.Thyme 16 | import Data.Thyme.Clock.Internal 17 | import Data.Thyme.Time.Core 18 | 19 | instance Num Micro where 20 | {-# INLINE (+) #-} 21 | {-# INLINE (-) #-} 22 | {-# INLINE (*) #-} 23 | {-# INLINE negate #-} 24 | {-# INLINE abs #-} 25 | {-# INLINE signum #-} 26 | {-# INLINE fromInteger #-} 27 | Micro a + Micro b = Micro (a + b) 28 | Micro a - Micro b = Micro (a - b) 29 | Micro a * Micro b = Micro (quot a 1000 * quot b 1000) 30 | negate (Micro a) = Micro (negate a) 31 | abs (Micro a) = Micro (abs a) 32 | signum (Micro a) = Micro (signum a * 1000000) 33 | fromInteger a = Micro (fromInteger a * 1000000) 34 | 35 | instance Real Micro where 36 | {-# INLINE toRational #-} 37 | toRational (Micro a) = toInteger a % 1000000 38 | 39 | instance Fractional Micro where 40 | {-# INLINE (/) #-} 41 | {-# INLINE recip #-} 42 | {-# INLINE fromRational #-} 43 | Micro a / Micro b = Micro (quot (a * 1000) (b `quot` 1000)) 44 | recip (Micro a) = Micro (quot 1000000 a) 45 | fromRational r = Micro (round $ r * 1000000) 46 | 47 | instance RealFrac Micro where 48 | {-# INLINE properFraction #-} 49 | properFraction a = (fromIntegral q, r) where 50 | (q, r) = microQuotRem a (Micro 1000000) 51 | 52 | deriving instance Num DiffTime 53 | deriving instance Real DiffTime 54 | deriving instance Fractional DiffTime 55 | deriving instance RealFrac DiffTime 56 | 57 | deriving instance Num NominalDiffTime 58 | deriving instance Real NominalDiffTime 59 | deriving instance Fractional NominalDiffTime 60 | deriving instance RealFrac NominalDiffTime 61 | 62 | {-# RULES 63 | 64 | "realToFrac/DiffTime-NominalDiffTime" 65 | realToFrac = \ (DiffTime d) -> NominalDiffTime d 66 | "realToFrac/NominalDiffTime-DiffTime" 67 | realToFrac = \ (NominalDiffTime d) -> DiffTime d 68 | 69 | "realToFrac/DiffTime-Fractional" 70 | realToFrac = toSeconds :: (Fractional n) => DiffTime -> n 71 | "realToFrac/NominalDiffTime-Fractional" 72 | realToFrac = toSeconds :: (Fractional n) => NominalDiffTime -> n 73 | 74 | "realToFrac/Real-DiffTime" 75 | realToFrac = fromSeconds :: (Real n) => n -> DiffTime 76 | "realToFrac/Real-NominalDiffTime" 77 | realToFrac = fromSeconds :: (Real n) => n -> NominalDiffTime #-} 78 | 79 | -------------------------------------------------------------------------------- /tests/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module Common where 4 | 5 | #if HLINT 6 | #include "cabal_macros.h" 7 | #endif 8 | 9 | import Prelude 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Control.Applicative 12 | #endif 13 | import Control.Lens 14 | import Data.AdditiveGroup 15 | import Data.Char 16 | import Data.Thyme 17 | import Data.Thyme.Clock.POSIX 18 | import System.Exit 19 | import Test.QuickCheck 20 | import qualified Test.QuickCheck.Gen as Gen 21 | 22 | exit :: Bool -> IO () 23 | exit b = exitWith $ if b then ExitSuccess else ExitFailure 1 24 | 25 | ------------------------------------------------------------------------ 26 | 27 | -- FIXME: We disagree with time on how many digits to use for year. 28 | newtype RecentTime = RecentTime UTCTime deriving (Show) 29 | 30 | instance Arbitrary RecentTime where 31 | arbitrary = fmap (RecentTime . review utcTime) $ UTCView 32 | <$> choose (minDay, maxDay) 33 | <*> choose (zeroV, pred dayLength) where 34 | minDay = gregorian # YearMonthDay 1000 1 1 35 | maxDay = gregorian # YearMonthDay 9999 12 13 36 | dayLength = posixDayLength ^. microseconds . from microseconds 37 | 38 | ------------------------------------------------------------------------ 39 | 40 | newtype Spec = Spec String deriving (Show) 41 | 42 | instance Arbitrary Spec where 43 | arbitrary = do 44 | -- Pick a non-overlapping day spec generator. 45 | day <- Gen.elements 46 | [ spec {-YearMonthDay-}"DFYyCBbhmde" 47 | , spec {-OrdinalDate-}"YyCj" 48 | -- TODO: time only consider the presence of %V as 49 | -- indication that it should parse as WeekDate 50 | , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa" 51 | , spec {-SundayWeek-}"YyCUuwAa" 52 | , spec {-MondayWeek-}"YyCWuwAa" 53 | ] :: Gen (Gen String) 54 | -- Pick a non-overlapping day & tod spec generator. 55 | time <- Gen.frequency 56 | [ (16, pure $ Gen.frequency 57 | [ (8, day) 58 | , (4, rod) 59 | , (2, h12) 60 | , (1, sec) 61 | , (1, spec {-TimeZone-}"zZ") 62 | ] ) 63 | -- TODO: these are broken due to issues above and below 64 | -- , (2, pure $ spec {-aggregate-}"crXx") 65 | , (1, pure $ spec {-UTCTime-}"s") 66 | ] :: Gen (Gen String) 67 | fmap (Spec . dropWhile isSpace . unwords) . listOf1 $ frequency 68 | [(16, time), (4, string), (1, pure "%%")] 69 | where 70 | spec = Gen.elements . fmap (\ c -> ['%', c]) 71 | string = filter ('%' /=) <$> arbitrary 72 | -- TODO: time discards %q %Q or %p %P after setting %S or hours 73 | -- respectively. Fudge it by always including %q and %p at end. 74 | -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ" 75 | rod = spec {-RestOfDay-}"RHkMqQ" 76 | sec = (++ " %q") <$> spec {-seconds-}"ST" 77 | h12 = (++ " %p") <$> spec {-12-hour-}"Il" 78 | 79 | -------------------------------------------------------------------------------- /src/Data/Thyme/Format/Human.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | #include "thyme.h" 7 | #if HLINT 8 | #include "cabal_macros.h" 9 | #endif 10 | 11 | -- | Vague textual descriptions of time durations. 12 | module Data.Thyme.Format.Human 13 | ( humanTimeDiff 14 | , humanTimeDiffs 15 | , humanRelTime 16 | , humanRelTimes 17 | ) where 18 | 19 | import Prelude 20 | #if !MIN_VERSION_base(4,8,0) 21 | import Control.Applicative 22 | #endif 23 | import Control.Arrow 24 | import Control.Lens 25 | import Control.Monad 26 | import Data.AdditiveGroup 27 | import Data.AffineSpace 28 | import Data.Foldable 29 | import Data.Thyme.Internal.Micro 30 | import Data.Monoid 31 | import Data.Thyme.Clock.Internal 32 | import Data.VectorSpace 33 | 34 | data Unit = Unit 35 | { unit :: Micro 36 | , single :: ShowS 37 | , plural :: ShowS 38 | } 39 | LENS(Unit,plural,ShowS) 40 | 41 | -- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form. 42 | {-# INLINE humanTimeDiff #-} 43 | humanTimeDiff :: (TimeDiff d) => d -> String 44 | humanTimeDiff d = humanTimeDiffs d "" 45 | 46 | -- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form. 47 | {-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-} 48 | humanTimeDiffs :: (TimeDiff d) => d -> ShowS 49 | humanTimeDiffs td = (if signed < 0 then (:) '-' else id) . diff where 50 | signed@(Micro . abs -> us) = td ^. microseconds 51 | diff = maybe id id . getFirst . fold $ 52 | zipWith (approx us . unit) (tail units) units 53 | 54 | -- | Display one 'UTCTime' relative to another, in a human-readable form. 55 | {-# INLINE humanRelTime #-} 56 | humanRelTime :: UTCTime -> UTCTime -> String 57 | humanRelTime ref time = humanRelTimes ref time "" 58 | 59 | -- | Display one 'UTCTime' relative to another, in a human-readable form. 60 | humanRelTimes :: UTCTime -> UTCTime -> ShowS 61 | humanRelTimes ref time = thence $ humanTimeDiffs diff where 62 | (diff, thence) = case compare delta zeroV of 63 | LT -> (negateV delta, ((++) "in " .)) 64 | EQ -> (zeroV, const $ (++) "right now") 65 | GT -> (delta, (. (++) " ago")) 66 | where delta = time .-. ref 67 | 68 | approx :: Micro -> Micro -> Unit -> First ShowS 69 | approx us next Unit {..} = First $ 70 | shows n . inflection <$ guard (us < next) where 71 | n = fst $ microQuotRem (us ^+^ half) unit where 72 | half = Micro . fst $ microQuotRem unit (Micro 2) 73 | inflection = if n == 1 then single else plural 74 | 75 | units :: [Unit] 76 | units = scanl (&) 77 | (Unit (Micro 1) (" microsecond" ++) (" microseconds" ++)) 78 | [ times "millisecond" 1000 79 | , times "second" 1000 80 | , times "minute" 60 81 | , times "hour" 60 82 | , times "day" 24 83 | , times "week" 7 84 | , times "month" (30.4368 / 7) 85 | , times "year" 12 86 | , times "decade" 10 87 | , times "century" 10 >>> set _plural (" centuries" ++) 88 | , times "millennium" 10 >>> set _plural (" millennia" ++) 89 | , const (Unit maxBound id id) -- upper bound needed for humanTimeDiffs.diff 90 | ] where 91 | times :: String -> Rational -> Unit -> Unit 92 | times ((++) . (:) ' ' -> single) r Unit {unit} 93 | = Unit {unit = r *^ unit, plural = single . (:) 's', ..} 94 | 95 | -------------------------------------------------------------------------------- /tests/sanity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | #if HLINT 5 | #include "cabal_macros.h" 6 | #endif 7 | 8 | import Prelude 9 | 10 | import Control.Arrow 11 | import Control.Lens 12 | import qualified Data.Attoparsec.ByteString.Char8 as P 13 | import Data.ByteString (ByteString) 14 | import Data.Thyme 15 | import Data.Thyme.Calendar.OrdinalDate 16 | import Data.Thyme.Time 17 | import qualified Data.Time as T 18 | import qualified Data.Time.Calendar.OrdinalDate as T 19 | import Test.QuickCheck 20 | 21 | import Common 22 | 23 | #if MIN_VERSION_bytestring(0,10,0) 24 | # if MIN_VERSION_bytestring(0,10,2) 25 | import qualified Data.ByteString.Builder as B 26 | # else 27 | import qualified Data.ByteString.Lazy.Builder as B 28 | # endif 29 | import qualified Data.ByteString.Lazy as L 30 | #else 31 | import qualified Data.Text as Text 32 | import qualified Data.Text.Encoding as Text 33 | #endif 34 | 35 | {-# INLINE utf8String #-} 36 | utf8String :: String -> ByteString 37 | #if MIN_VERSION_bytestring(0,10,0) 38 | utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8 39 | #else 40 | utf8String = Text.encodeUtf8 . Text.pack 41 | #endif 42 | 43 | ------------------------------------------------------------------------ 44 | 45 | prop_ShowRead :: (Eq a, Show a, Read a) => a -> Bool 46 | prop_ShowRead a = (a, "") `elem` reads (show a) 47 | 48 | prop_toOrdinalDate :: Day -> Bool 49 | prop_toOrdinalDate day = 50 | fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day) 51 | 52 | prop_formatTime :: Spec -> RecentTime -> Property 53 | prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t')) 54 | #if MIN_VERSION_QuickCheck(2,7,0) 55 | = counterexample desc (s == s') where 56 | #else 57 | = printTestCase desc (s == s') where 58 | #endif 59 | s = formatTime defaultTimeLocale spec t 60 | s' = T.formatTime defaultTimeLocale spec t' 61 | desc = "thyme: " ++ s ++ "\ntime: " ++ s' 62 | 63 | prop_parseTime :: Spec -> RecentTime -> Property 64 | prop_parseTime (Spec spec) (RecentTime orig) 65 | #if MIN_VERSION_QuickCheck(2,7,0) 66 | = counterexample desc (fmap (review thyme) t == t') where 67 | #else 68 | = printTestCase desc (fmap (review thyme) t == t') where 69 | #endif 70 | s = T.formatTime defaultTimeLocale spec (thyme # orig) 71 | t = parseTime defaultTimeLocale spec s :: Maybe UTCTime 72 | #if MIN_VERSION_time(1,5,0) 73 | t' = T.parseTimeM True defaultTimeLocale spec s 74 | #else 75 | t' = T.parseTime defaultTimeLocale spec s 76 | #endif 77 | tp = P.parse (timeParser defaultTimeLocale spec) . utf8String 78 | desc = "input: " ++ show s ++ "\nthyme: " ++ show t 79 | ++ "\ntime: " ++ show t' ++ "\nstate: " ++ show (tp s) 80 | 81 | ------------------------------------------------------------------------ 82 | 83 | {-# ANN main "HLint: ignore Use list literal" #-} 84 | main :: IO () 85 | main = exit . all isSuccess =<< sequence 86 | [ qc 10000 (prop_ShowRead :: Day -> Bool) 87 | , qc 10000 (prop_ShowRead :: DiffTime -> Bool) 88 | , qc 10000 (prop_ShowRead :: NominalDiffTime -> Bool) 89 | , qc 10000 (prop_ShowRead :: UTCTime -> Bool) 90 | , qc 10000 prop_toOrdinalDate 91 | , qc 1000 prop_formatTime 92 | , qc 1000 prop_parseTime 93 | 94 | ] where 95 | isSuccess r = case r of Success {} -> True; _ -> False 96 | qc :: Testable prop => Int -> prop -> IO Result 97 | qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n} 98 | 99 | -------------------------------------------------------------------------------- /src/Data/Thyme/Internal/Micro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | #include "thyme.h" 11 | 12 | -- | FOR INTERNAL USE ONLY. 13 | module Data.Thyme.Internal.Micro where 14 | 15 | import Prelude 16 | import Control.DeepSeq 17 | import Data.AdditiveGroup 18 | import Data.Basis 19 | import Data.Data 20 | import Data.Hashable 21 | import Data.Int 22 | import Data.Ix 23 | import Data.Ratio 24 | #if __GLASGOW_HASKELL__ == 704 25 | import qualified Data.Vector.Generic 26 | import qualified Data.Vector.Generic.Mutable 27 | #endif 28 | import Data.Vector.Unboxed.Deriving 29 | import Data.VectorSpace 30 | import GHC.Generics (Generic) 31 | import System.Random 32 | import Test.QuickCheck 33 | 34 | #if !SHOW_INTERNAL 35 | import Control.Monad 36 | import Data.Char 37 | import Data.Thyme.Format.Internal 38 | import Numeric 39 | import Text.ParserCombinators.ReadPrec 40 | import Text.ParserCombinators.ReadP 41 | import Text.Read 42 | #endif 43 | 44 | newtype Micro = Micro Int64 deriving (INSTANCES_MICRO) 45 | 46 | derivingUnbox "Micro" [t| Micro -> Int64 |] 47 | [| \ (Micro a) -> a |] [| Micro |] 48 | 49 | #if SHOW_INTERNAL 50 | deriving instance Show Micro 51 | deriving instance Read Micro 52 | #else 53 | instance Show Micro where 54 | {-# INLINEABLE showsPrec #-} 55 | showsPrec _ (Micro a) = sign . shows si . frac where 56 | sign = if a < 0 then (:) '-' else id 57 | (si, su) = abs a `divMod` 1000000 58 | frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su 59 | 60 | instance Read Micro where 61 | {-# INLINEABLE readPrec #-} 62 | readPrec = lift $ do 63 | sign <- (char '-' >> return negate) `mplus` return id 64 | s <- readS_to_P readDec 65 | us <- (`mplus` return 0) $ do 66 | _ <- char '.' 67 | [(us10, "")] <- (readDec . take 7 . (++ "000000")) 68 | `fmap` munch1 isDigit 69 | return (div (us10 + 5) 10) 70 | return . Micro . sign $ s * 1000000 + us 71 | #endif 72 | 73 | {-# INLINE microQuotRem #-} 74 | {-# INLINE microDivMod #-} 75 | microQuotRem, microDivMod :: Micro -> Micro -> (Int64, Micro) 76 | microQuotRem (Micro a) (Micro b) = (n, Micro f) where (n, f) = quotRem a b 77 | microDivMod (Micro a) (Micro b) = (n, Micro f) where (n, f) = divMod a b 78 | 79 | instance AdditiveGroup Micro where 80 | {-# INLINE zeroV #-} 81 | zeroV = Micro 0 82 | {-# INLINE (^+^) #-} 83 | (^+^) = \ (Micro a) (Micro b) -> Micro (a + b) 84 | {-# INLINE negateV #-} 85 | negateV = \ (Micro a) -> Micro (negate a) 86 | 87 | instance VectorSpace Micro where 88 | type Scalar Micro = Rational 89 | {-# INLINE (*^) #-} 90 | s *^ Micro a = Micro . fromInteger $ -- 'round'-to-even 91 | case compare (2 * abs r) (denominator s) of 92 | LT -> n 93 | EQ -> if even n then n else m 94 | GT -> m 95 | where 96 | (n, r) = quotRem (toInteger a * numerator s) (denominator s) 97 | m = if r < 0 then n - 1 else n + 1 98 | 99 | instance HasBasis Micro where 100 | type Basis Micro = () 101 | {-# INLINE basisValue #-} 102 | basisValue = \ _ -> Micro 1000000 103 | {-# INLINE decompose #-} 104 | decompose = \ (Micro a) -> [((), fromIntegral a % 1000000)] 105 | {-# INLINE decompose' #-} 106 | decompose' = \ (Micro a) _ -> fromIntegral a % 1000000 107 | 108 | -------------------------------------------------------------------------------- /src/Data/Thyme/Clock/POSIX.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | 3 | #ifndef mingw32_HOST_OS 4 | #include 5 | #endif 6 | 7 | -- | 8 | module Data.Thyme.Clock.POSIX 9 | ( posixDayLength 10 | , POSIXTime 11 | , posixTime 12 | , getPOSIXTime 13 | 14 | -- * Compatibility 15 | , posixSecondsToUTCTime 16 | , utcTimeToPOSIXSeconds 17 | ) where 18 | 19 | import Prelude 20 | import Control.Lens 21 | import Data.AdditiveGroup 22 | import Data.Thyme.Internal.Micro 23 | import Data.Thyme.Clock.Internal 24 | 25 | #ifdef mingw32_HOST_OS 26 | import System.Win32.Time 27 | #else 28 | import Foreign.C.Error (throwErrnoIfMinus1_) 29 | import Foreign.C.Types 30 | import Foreign.Marshal.Alloc (allocaBytes) 31 | import Foreign.Ptr (Ptr, nullPtr) 32 | import Foreign.Storable 33 | #endif 34 | 35 | -- | The nominal (ignoring leap seconds) time difference since midnight 36 | -- 1970-01-01, the Unix epoch. Equvialent to a normalised 37 | -- @@. 38 | type POSIXTime = NominalDiffTime 39 | 40 | -- | "Control.Lens.Iso" between 'UTCTime' and 'POSIXTime'. 41 | -- 42 | -- @ 43 | -- > 'getPOSIXTime' 44 | -- 1459515013.527711s 45 | -- > 'review' 'posixTime' '<$>' 'getPOSIXTime' 46 | -- 2016-01-01 12:50:45.588729 UTC 47 | -- @ 48 | {-# INLINE posixTime #-} 49 | posixTime :: Iso' UTCTime POSIXTime 50 | posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch) 51 | (UTCRep . (^+^) unixEpoch) where 52 | unixEpoch = review microseconds $ 53 | {-ModifiedJulianDay-}40587 * {-posixDayLength-}86400000000 54 | 55 | -- | Return the current system POSIX time via 56 | -- @@, 57 | -- or @getSystemTimeAsFileTime@ on Windows. 58 | -- 59 | -- See also 'Data.Thyme.Clock.getCurrentTime', 'Data.Thyme.LocalTime.getZonedTime'. 60 | {-# INLINE getPOSIXTime #-} 61 | getPOSIXTime :: IO POSIXTime 62 | #ifdef mingw32_HOST_OS 63 | 64 | -- On Windows, the equlvalent of POSIX time is ‘file time’, defined as 65 | -- the number of 100-nanosecond intervals that have elapsed since 66 | -- 12:00 AM January 1, 1601 (UTC). We can convert this into a POSIX 67 | -- time by adjusting the offset to be relative to the POSIX epoch. 68 | getPOSIXTime = do 69 | FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime 70 | return . NominalDiffTime . Micro . fromIntegral $ 71 | quot ft 10 - 11644473600000000{-ftEpoch ^. microseconds-} 72 | -- ftEpoch = utcTime # UTCTime (gregorian # YearMonthDay 1601 1 1) zeroV 73 | 74 | #else 75 | 76 | getPOSIXTime = allocaBytes #{size struct timeval} $ \ ptv -> do 77 | throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptv nullPtr 78 | CTime sec <- #{peek struct timeval, tv_sec} ptv 79 | CSUSeconds usec <- #{peek struct timeval, tv_usec} ptv 80 | return . NominalDiffTime . Micro $ 81 | 1000000 * fromIntegral sec + fromIntegral usec 82 | 83 | foreign import ccall unsafe "time.h gettimeofday" 84 | gettimeofday :: Ptr () -> Ptr () -> IO CInt 85 | 86 | #endif 87 | 88 | ------------------------------------------------------------------------ 89 | 90 | -- | Construct a 'UTCTime' from a 'POSIXTime'. 91 | -- 92 | -- @ 93 | -- 'posixSecondsToUTCTime' = 'review' 'posixTime' 94 | -- 'posixSecondsToUTCTime' t ≡ 'posixTime' 'Control.Lens.#' t 95 | -- @ 96 | {-# INLINE posixSecondsToUTCTime #-} 97 | posixSecondsToUTCTime :: POSIXTime -> UTCTime 98 | posixSecondsToUTCTime = review posixTime 99 | 100 | -- | Convert a 'UTCTime' to a 'POSIXTime'. 101 | -- 102 | -- @ 103 | -- 'utcTimeToPOSIXSeconds' = 'view' 'posixTime' 104 | -- @ 105 | {-# INLINE utcTimeToPOSIXSeconds #-} 106 | utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime 107 | utcTimeToPOSIXSeconds = view posixTime 108 | 109 | -------------------------------------------------------------------------------- /src/Data/Thyme/Format/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | #if HLINT 8 | #include "cabal_macros.h" 9 | #endif 10 | 11 | -- | Instances of 'FromJSON' and 'ToJSON' for 'UTCTime' and 'ZonedTime', 12 | -- along with a newtype wrapper 'DotNetTime'. 13 | module Data.Thyme.Format.Aeson 14 | ( DotNetTime (..) 15 | ) where 16 | 17 | import Prelude 18 | import Control.Applicative 19 | import Data.Aeson hiding (DotNetTime (..)) 20 | import Data.Aeson.Types hiding (DotNetTime (..)) 21 | import Data.Data 22 | #if !MIN_VERSION_base(4,8,0) 23 | import Data.Monoid 24 | #endif 25 | import Data.Text (pack, unpack) 26 | import qualified Data.Text as T 27 | import Data.Thyme 28 | 29 | -- Copyright: (c) 2011, 2012, 2013 Bryan O'Sullivan 30 | -- (c) 2011 MailRank, Inc. 31 | 32 | ------------------------------------------------------------------------ 33 | -- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Internal 34 | 35 | -- | A newtype wrapper for 'UTCTime' that uses the same non-standard 36 | -- serialization format as Microsoft .NET, whose @System.DateTime@ 37 | -- type is by default serialized to JSON as in the following example: 38 | -- 39 | -- > /Date(1302547608878)/ 40 | -- 41 | -- The number represents milliseconds since the Unix epoch. 42 | newtype DotNetTime = DotNetTime { 43 | fromDotNetTime :: UTCTime 44 | } deriving (Eq, Ord, Read, Show, Typeable, FormatTime) 45 | 46 | ------------------------------------------------------------------------ 47 | -- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Instances 48 | 49 | instance ToJSON DotNetTime where 50 | toJSON (DotNetTime t) = 51 | String (pack (secs ++ formatMillis t ++ ")/")) 52 | where secs = formatTime defaultTimeLocale "/Date(%s" t 53 | {-# INLINE toJSON #-} 54 | 55 | instance FromJSON DotNetTime where 56 | parseJSON = withText "DotNetTime" $ \t -> 57 | let (s,m) = T.splitAt (T.length t - 5) t 58 | t' = T.concat [s,".",m] 59 | in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of 60 | Just d -> pure (DotNetTime d) 61 | _ -> fail "could not parse .NET time" 62 | {-# INLINE parseJSON #-} 63 | 64 | instance ToJSON ZonedTime where 65 | toJSON t = String $ pack $ formatTime defaultTimeLocale format t 66 | where 67 | format = "%FT%T." ++ formatMillis t ++ tzFormat 68 | tzFormat 69 | | 0 == timeZoneMinutes (zonedTimeZone t) = "Z" 70 | | otherwise = "%z" 71 | 72 | formatMillis :: (FormatTime t) => t -> String 73 | formatMillis t = take 3 $ formatTime defaultTimeLocale "%q" t 74 | 75 | instance FromJSON ZonedTime where 76 | parseJSON (String t) = 77 | tryFormats alternateFormats 78 | <|> fail "could not parse ECMA-262 ISO-8601 date" 79 | where 80 | tryFormat f = 81 | case parseTime defaultTimeLocale f (unpack t) of 82 | Just d -> pure d 83 | Nothing -> empty 84 | tryFormats = foldr1 (<|>) . map tryFormat 85 | alternateFormats = 86 | dateTimeFmt defaultTimeLocale : 87 | distributeList ["%Y", "%Y-%m", "%F"] 88 | ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"] 89 | 90 | distributeList xs ys = 91 | foldr (\x acc -> acc ++ distribute x ys) [] xs 92 | distribute x = map (mappend x) 93 | 94 | parseJSON v = typeMismatch "ZonedTime" v 95 | 96 | instance ToJSON UTCTime where 97 | toJSON t = String $ pack $ formatTime defaultTimeLocale format t 98 | where 99 | format = "%FT%T." ++ formatMillis t ++ "Z" 100 | {-# INLINE toJSON #-} 101 | 102 | instance FromJSON UTCTime where 103 | parseJSON = withText "UTCTime" $ \t -> 104 | case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of 105 | Just d -> pure d 106 | _ -> fail "could not parse ISO-8601 date" 107 | {-# INLINE parseJSON #-} 108 | 109 | -------------------------------------------------------------------------------- /src/Data/Thyme/Calendar/WeekDate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | #if __GLASGOW_HASKELL__ == 706 6 | {-# OPTIONS_GHC -fsimpl-tick-factor=120 #-} -- 7.6.3 only, it seems; fixes #29 7 | #endif 8 | 9 | #include "thyme.h" 10 | #if HLINT 11 | #include "cabal_macros.h" 12 | #endif 13 | 14 | -- | Various Week Date formats 15 | module Data.Thyme.Calendar.WeekDate 16 | ( Year, WeekOfYear, DayOfWeek 17 | -- * ISO 8601 Week Date 18 | , WeekDate (..), _wdYear, _wdWeek, _wdDay 19 | , weekDate, weekDateValid, showWeekDate 20 | 21 | -- * Weeks starting Sunday 22 | , SundayWeek (..), _swYear, _swWeek, _swDay 23 | , sundayWeek, sundayWeekValid 24 | 25 | -- * Weeks starting Monday 26 | , MondayWeek (..), _mwYear, _mwWeek, _mwDay 27 | , mondayWeek, mondayWeekValid 28 | 29 | , module Data.Thyme.Calendar.WeekDate 30 | ) where 31 | 32 | import Prelude 33 | #if !MIN_VERSION_base(4,8,0) 34 | import Control.Applicative 35 | #endif 36 | import Control.Arrow 37 | import Control.Lens 38 | import Data.Thyme.Calendar.OrdinalDate 39 | import Data.Thyme.Calendar.Internal 40 | import System.Random 41 | import Test.QuickCheck 42 | 43 | instance Bounded WeekDate where 44 | minBound = minBound ^. weekDate 45 | maxBound = maxBound ^. weekDate 46 | 47 | instance Bounded SundayWeek where 48 | minBound = minBound ^. sundayWeek 49 | maxBound = maxBound ^. sundayWeek 50 | 51 | instance Bounded MondayWeek where 52 | minBound = minBound ^. mondayWeek 53 | maxBound = maxBound ^. mondayWeek 54 | 55 | instance Random WeekDate where 56 | randomR = randomIsoR weekDate 57 | random = first (^. weekDate) . random 58 | 59 | instance Random SundayWeek where 60 | randomR = randomIsoR sundayWeek 61 | random = first (^. sundayWeek) . random 62 | 63 | instance Random MondayWeek where 64 | randomR = randomIsoR mondayWeek 65 | random = first (^. mondayWeek) . random 66 | 67 | instance Arbitrary WeekDate where 68 | arbitrary = view weekDate <$> arbitrary 69 | shrink wd = view weekDate <$> shrink (weekDate # wd) 70 | 71 | instance Arbitrary SundayWeek where 72 | arbitrary = view sundayWeek <$> arbitrary 73 | shrink sw = view sundayWeek <$> shrink (sundayWeek # sw) 74 | 75 | instance Arbitrary MondayWeek where 76 | arbitrary = view mondayWeek <$> arbitrary 77 | shrink mw = view mondayWeek <$> shrink (mondayWeek # mw) 78 | 79 | instance CoArbitrary WeekDate where 80 | coarbitrary (WeekDate y w d) 81 | = coarbitrary y . coarbitrary w . coarbitrary d 82 | 83 | instance CoArbitrary SundayWeek where 84 | coarbitrary (SundayWeek y w d) 85 | = coarbitrary y . coarbitrary w . coarbitrary d 86 | 87 | instance CoArbitrary MondayWeek where 88 | coarbitrary (MondayWeek y w d) 89 | = coarbitrary y . coarbitrary w . coarbitrary d 90 | 91 | -- * Compatibility 92 | 93 | -- | Converts a 'Day' to an . 94 | -- 95 | -- @ 96 | -- 'toWeekDate' ('view' 'weekDate' -> 'WeekDate' y w d) = (y, w, d) 97 | -- @ 98 | {-# INLINE toWeekDate #-} 99 | toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek) 100 | toWeekDate (view weekDate -> WeekDate y w d) = (y, w, d) 101 | 102 | -- | Converts an 103 | -- to a 'Day'. 104 | -- Does not validate the input. 105 | -- 106 | -- @ 107 | -- 'fromWeekDate' y w d = 'weekDate' 'Control.Lens.#' 'WeekDate' y w d 108 | -- @ 109 | {-# INLINE fromWeekDate #-} 110 | fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day 111 | fromWeekDate y w d = weekDate # WeekDate y w d 112 | 113 | -- | Converts an 114 | -- to a 'Day'. 115 | -- Returns 'Nothing' for invalid input. 116 | -- 117 | -- @ 118 | -- 'fromWeekDateValid' y w d = 'weekDateValid' ('WeekDate' y w d) 119 | -- @ 120 | {-# INLINE fromWeekDateValid #-} 121 | fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day 122 | fromWeekDateValid y w d = weekDateValid (WeekDate y w d) 123 | 124 | -------------------------------------------------------------------------------- /lens/Control/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | #if HLINT 7 | #include "cabal_macros.h" 8 | #endif 9 | 10 | -- | Small replacement for . 11 | module Control.Lens 12 | ( (&) 13 | , Iso, Iso', iso 14 | , from 15 | , review, ( # ) 16 | , Lens, Lens', lens 17 | , view, (^.) 18 | , set, over, (%~), assign, (.=) 19 | ) where 20 | 21 | import Control.Applicative 22 | import Control.Monad.Identity 23 | import Control.Monad.State.Class as State 24 | import Data.Profunctor 25 | import Data.Profunctor.Unsafe 26 | #if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0) 27 | import Data.Coerce 28 | #else 29 | import Unsafe.Coerce 30 | #endif 31 | 32 | infixl 1 & 33 | (&) :: a -> (a -> b) -> b 34 | a & f = f a 35 | {-# INLINE (&) #-} 36 | 37 | type Overloaded p f s t a b = p a (f b) -> p s (f t) 38 | 39 | ------------------------------------------------------------------------ 40 | 41 | type Iso s t a b = forall p f. (Profunctor p, Functor f) => Overloaded p f s t a b 42 | type Iso' s a = Iso s s a a 43 | 44 | iso :: (s -> a) -> (b -> t) -> Iso s t a b 45 | iso sa bt = dimap sa (fmap bt) 46 | {-# INLINE iso #-} 47 | 48 | ------------------------------------------------------------------------ 49 | 50 | data Exchange a b s t = Exchange (s -> a) (b -> t) 51 | 52 | instance Profunctor (Exchange a b) where 53 | dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) 54 | {-# INLINE dimap #-} 55 | lmap f (Exchange sa bt) = Exchange (sa . f) bt 56 | {-# INLINE lmap #-} 57 | rmap f (Exchange sa bt) = Exchange sa (f . bt) 58 | {-# INLINE rmap #-} 59 | #if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0) 60 | ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t 61 | ( .# ) p _ = coerce p 62 | #else 63 | ( #. ) _ = unsafeCoerce 64 | ( .# ) p _ = unsafeCoerce p 65 | #endif 66 | {-# INLINE ( #. ) #-} 67 | {-# INLINE ( .# ) #-} 68 | 69 | type AnIso s t a b = Overloaded (Exchange a b) Identity s t a b 70 | 71 | from :: AnIso s t a b -> Iso b a t s 72 | from l = case l (Exchange id Identity) of 73 | Exchange sa bt -> iso (runIdentity #. bt) sa 74 | {-# INLINE from #-} 75 | 76 | ------------------------------------------------------------------------ 77 | 78 | newtype Reviewed a b = Reviewed 79 | { runReviewed :: b 80 | } deriving (Functor) 81 | 82 | instance Profunctor Reviewed where 83 | dimap _ f (Reviewed c) = Reviewed (f c) 84 | {-# INLINE dimap #-} 85 | lmap _ (Reviewed c) = Reviewed c 86 | {-# INLINE lmap #-} 87 | rmap = fmap 88 | {-# INLINE rmap #-} 89 | Reviewed b .# _ = Reviewed b 90 | {-# INLINE ( .# ) #-} 91 | #if __GLASGOW_HASKELL__ >= 708 && MIN_VERSION_profunctors(4,4,0) 92 | ( #. ) _ = coerce (id :: t -> t) :: forall t u. Coercible t u => u -> t 93 | #else 94 | ( #. ) _ = unsafeCoerce 95 | #endif 96 | {-# INLINE ( #. ) #-} 97 | 98 | type AReview s t a b = Overloaded Reviewed Identity s t a b 99 | 100 | review :: AReview s t a b -> b -> t 101 | review p = runIdentity #. runReviewed #. p .# Reviewed .# Identity 102 | {-# INLINE review #-} 103 | 104 | infixr 8 # 105 | ( # ) :: AReview s t a b -> b -> t 106 | ( # ) = review 107 | {-# INLINE ( # ) #-} 108 | 109 | ------------------------------------------------------------------------ 110 | 111 | type Lens s t a b = forall f. Functor f => Overloaded (->) f s t a b 112 | type Lens' s a = Lens s s a a 113 | 114 | lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b 115 | lens sa sbt afb s = sbt s <$> afb (sa s) 116 | {-# INLINE lens #-} 117 | 118 | ------------------------------------------------------------------------ 119 | 120 | type Getting r s a = Overloaded (->) (Const r) s s a a 121 | 122 | view :: Getting a s a -> s -> a 123 | view l s = getConst (l Const s) 124 | {-# INLINE view #-} 125 | 126 | infixl 8 ^. 127 | (^.) :: s -> Getting a s a -> a 128 | (^.) = flip view 129 | {-# INLINE (^.) #-} 130 | 131 | ------------------------------------------------------------------------ 132 | 133 | type Setter s t a b = Overloaded (->) Identity s t a b 134 | 135 | set :: Setter s t a b -> b -> s -> t 136 | set l b = runIdentity #. l (\ _ -> Identity b) 137 | {-# INLINE set #-} 138 | 139 | over :: Setter s t a b -> (a -> b) -> s -> t 140 | over l f = runIdentity #. l (Identity #. f) 141 | {-# INLINE over #-} 142 | 143 | infixr 4 %~ 144 | (%~) :: Setter s t a b -> (a -> b) -> s -> t 145 | (%~) = over 146 | {-# INLINE (%~) #-} 147 | 148 | assign :: (MonadState s m) => Setter s s a b -> b -> m () 149 | assign l b = State.modify (set l b) 150 | {-# INLINE assign #-} 151 | 152 | infix 4 .= 153 | (.=) :: (MonadState s m) => Setter s s a b -> b -> m () 154 | (.=) = assign 155 | {-# INLINE (.=) #-} 156 | 157 | -------------------------------------------------------------------------------- /src/Data/Thyme/Format/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | #if HLINT 6 | #include "cabal_macros.h" 7 | #endif 8 | 9 | module Data.Thyme.Format.Internal where 10 | 11 | import Prelude 12 | import Control.Applicative 13 | import Data.Attoparsec.ByteString.Char8 (Parser, Result, IResult (..)) 14 | import qualified Data.Attoparsec.ByteString.Char8 as P 15 | import qualified Data.ByteString.Char8 as S 16 | import Data.Char 17 | import Data.Int 18 | import qualified Data.Text as Text 19 | import qualified Data.Text.Encoding as Text 20 | 21 | #if MIN_VERSION_bytestring(0,10,0) 22 | # if MIN_VERSION_bytestring(0,10,2) 23 | import qualified Data.ByteString.Builder as B 24 | # else 25 | import qualified Data.ByteString.Lazy.Builder as B 26 | # endif 27 | import qualified Data.ByteString.Lazy as L 28 | #endif 29 | 30 | {-# INLINE utf8Char #-} 31 | {-# INLINE utf8String #-} 32 | utf8Char :: Char -> S.ByteString 33 | utf8String :: String -> S.ByteString 34 | #if MIN_VERSION_bytestring(0,10,0) 35 | utf8Char = L.toStrict . B.toLazyByteString . B.charUtf8 36 | utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8 37 | #else 38 | utf8Char = Text.encodeUtf8 . Text.singleton 39 | utf8String = Text.encodeUtf8 . Text.pack 40 | #endif 41 | 42 | ------------------------------------------------------------------------ 43 | 44 | {-# INLINE shows02 #-} 45 | shows02 :: Int -> ShowS 46 | shows02 n = if n < 10 then (:) '0' . shows n else shows n 47 | 48 | {-# ANN shows_2 "HLint: ignore Use camelCase" #-} 49 | {-# INLINE shows_2 #-} 50 | shows_2 :: Int -> ShowS 51 | shows_2 n = if n < 10 then (:) ' ' . shows n else shows n 52 | 53 | {-# INLINE shows03 #-} 54 | shows03 :: Int -> ShowS 55 | shows03 n 56 | | n < 10 = (++) "00" . shows n 57 | | n < 100 = (++) "0" . shows n 58 | | otherwise = shows n 59 | 60 | {-# INLINE showsYear #-} 61 | showsYear :: Int -> ShowS 62 | showsYear n@(abs -> u) 63 | | u < 10 = neg . (++) "000" . shows u 64 | | u < 100 = neg . (++) "00" . shows u 65 | | u < 1000 = neg . (++) "0" . shows u 66 | | otherwise = neg . shows u 67 | where neg = if n < 0 then (:) '-' else id 68 | 69 | {-# INLINE fills06 #-} 70 | fills06 :: Int64 -> ShowS 71 | fills06 n 72 | | n < 10 = (++) "00000" 73 | | n < 100 = (++) "0000" 74 | | n < 1000 = (++) "000" 75 | | n < 10000 = (++) "00" 76 | | n < 100000 = (++) "0" 77 | | otherwise = id 78 | 79 | {-# INLINE drops0 #-} 80 | drops0 :: Int64 -> ShowS 81 | drops0 n = case divMod n 10 of 82 | (q, 0) -> drops0 q 83 | _ -> shows n 84 | 85 | ------------------------------------------------------------------------ 86 | 87 | {-# INLINEABLE parserToReadS #-} 88 | parserToReadS :: Parser a -> ReadS a 89 | parserToReadS = go . P.parse where 90 | {-# INLINEABLE go #-} 91 | go :: (S.ByteString -> Result a) -> ReadS a 92 | go k (splitAt 32 -> (h, t)) = case k (utf8String h) of 93 | -- `date -R | wc -c` is 32 characters 94 | Fail rest cxts msg -> fail $ concat [ "parserToReadS: ", msg 95 | , "; remaining: ", show (utf8Decode rest), "; stack: ", show cxts ] 96 | Partial k' -> go k' t 97 | Done rest a -> return (a, utf8Decode rest ++ t) 98 | 99 | {-# INLINE utf8Decode #-} 100 | utf8Decode :: S.ByteString -> String 101 | utf8Decode = Text.unpack . Text.decodeUtf8 102 | 103 | {-# INLINE indexOf #-} 104 | indexOf :: [String] -> Parser Int 105 | indexOf = P.choice . zipWith (\ i s -> i <$ P.string (S.pack s)) [0..] 106 | 107 | {-# INLINE indexOfCI #-} 108 | indexOfCI :: [String] -> Parser Int 109 | indexOfCI = P.choice . zipWith (\ i s -> i <$ stringCI s) [0..] 110 | 111 | -- | Case-insensitive UTF-8 ByteString parser 112 | -- 113 | -- Matches one character at a time. Slow. 114 | {-# INLINE stringCI #-} 115 | stringCI :: String -> Parser () 116 | stringCI = foldl (\ p c -> p *> charCI c) (pure ()) 117 | 118 | -- | Case-insensitive UTF-8 ByteString parser 119 | -- 120 | -- We can't easily perform upper/lower case conversion on the input, so 121 | -- instead we accept either one of @toUpper c@ and @toLower c@. 122 | {-# INLINE charCI #-} 123 | charCI :: Char -> Parser () 124 | charCI c = if u == l then charU8 c else charU8 l <|> charU8 u where 125 | l = toLower c 126 | u = toUpper c 127 | 128 | {-# INLINE charU8 #-} 129 | charU8 :: Char -> Parser () 130 | charU8 c = () <$ P.string (utf8Char c) 131 | 132 | -- | Number may be prefixed with '-' 133 | {-# INLINE negative #-} 134 | negative :: (Integral n) => Parser n -> Parser n 135 | negative p = ($) <$> (negate <$ P.char '-' <|> pure id) <*> p 136 | 137 | -- | Fixed-length 0-padded decimal 138 | {-# INLINE dec0 #-} 139 | dec0 :: Int -> Parser Int 140 | dec0 n = either fail return . P.parseOnly P.decimal =<< P.take n 141 | 142 | -- | Fixed-length space-padded decimal 143 | {-# INLINE dec_ #-} 144 | dec_ :: Int -> Parser Int 145 | dec_ n = either fail return . P.parseOnly P.decimal 146 | =<< S.dropWhile isSpace <$> P.take n 147 | 148 | -------------------------------------------------------------------------------- /src/Data/Thyme/Calendar/WeekdayOfMonth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE ViewPatterns #-} 9 | 10 | #include "thyme.h" 11 | #if HLINT 12 | #include "cabal_macros.h" 13 | #endif 14 | 15 | -- | Calendar date reckoned by year, month-of-year, and n-th day-of-week. 16 | module Data.Thyme.Calendar.WeekdayOfMonth 17 | ( Year, Month, DayOfWeek 18 | , module Data.Thyme.Calendar.WeekdayOfMonth 19 | ) where 20 | 21 | import Prelude 22 | #if !MIN_VERSION_base(4,8,0) 23 | import Control.Applicative 24 | #endif 25 | import Control.Arrow 26 | import Control.DeepSeq 27 | import Control.Lens 28 | import Control.Monad 29 | import Data.AffineSpace 30 | import Data.Bits 31 | import Data.Data 32 | import Data.Hashable 33 | import Data.Thyme.Calendar 34 | import Data.Thyme.Calendar.Internal 35 | #if __GLASGOW_HASKELL__ == 704 36 | import qualified Data.Vector.Generic 37 | import qualified Data.Vector.Generic.Mutable 38 | #endif 39 | import Data.Vector.Unboxed.Deriving 40 | import GHC.Generics (Generic) 41 | import System.Random 42 | import Test.QuickCheck hiding ((.&.)) 43 | 44 | -- | Calendar date with year, month-of-year, and n-th day-of-week. 45 | data WeekdayOfMonth = WeekdayOfMonth 46 | { womYear :: {-# UNPACK #-}!Year 47 | -- ^ Calendar year. 48 | , womMonth :: {-# UNPACK #-}!Month 49 | -- ^ Month of year. 50 | , womNth :: {-# UNPACK #-}!Int 51 | -- ^ /N/-th 'DayOfWeek'. Range /±1–5/; negative means the /N/-th 52 | -- last 'DayOfWeek' of the month. 53 | , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek 54 | -- ^ Day of week. /1 = Monday, 7 = Sunday/, like ISO 8601 'WeekDate'. 55 | } deriving (INSTANCES_USUAL, Show) 56 | 57 | LENS(WeekdayOfMonth,womYear,Year) 58 | LENS(WeekdayOfMonth,womMonth,Month) 59 | LENS(WeekdayOfMonth,womNth,Int) 60 | LENS(WeekdayOfMonth,womDayOfWeek,DayOfWeek) 61 | 62 | derivingUnbox "WeekdayOfMonth" 63 | [t| WeekdayOfMonth -> Int |] 64 | [| \ WeekdayOfMonth {..} -> shiftL womYear 11 .|. shiftL womMonth 7 65 | .|. shiftL (womNth + 5) 3 .|. womDayOfWeek |] 66 | [| \ n -> WeekdayOfMonth (shiftR n 11) (shiftR n 7 .&. 0xf) 67 | (shiftR n 3 - 5) (n .&. 0x7) |] 68 | 69 | instance Hashable WeekdayOfMonth 70 | instance NFData WeekdayOfMonth 71 | 72 | instance Bounded WeekdayOfMonth where 73 | minBound = minBound ^. weekdayOfMonth 74 | maxBound = maxBound ^. weekdayOfMonth 75 | 76 | instance Random WeekdayOfMonth where 77 | randomR = randomIsoR weekdayOfMonth 78 | random = first (^. weekdayOfMonth) . random 79 | 80 | instance Arbitrary WeekdayOfMonth where 81 | arbitrary = view weekdayOfMonth <$> arbitrary 82 | shrink wom = view weekdayOfMonth <$> shrink (weekdayOfMonth # wom) 83 | 84 | instance CoArbitrary WeekdayOfMonth where 85 | coarbitrary (WeekdayOfMonth y m n d) 86 | = coarbitrary y . coarbitrary m 87 | . coarbitrary n . coarbitrary d 88 | 89 | -- | Conversion between a 'Day' and and 'WeekdayOfMonth'. 90 | -- 91 | -- This is a proper 'Iso' if and only if all of the 'WeekdayOfMonth' fields 92 | -- are valid and positive. 93 | -- 94 | -- For example, the last /Monday/ in /January 2016/ is also the fourth 95 | -- /Monday/: 96 | -- 97 | -- @ 98 | -- > 'weekdayOfMonth' 'Control.Lens.#' 'WeekdayOfMonth' 2016 1 (-1) 1 99 | -- 2016-01-25 100 | -- > 'YearMonthDay' 2016 01 25 '^.' 'from' 'gregorian' '.' 'weekdayOfMonth' 101 | -- 'WeekdayOfMonth' {'womYear' = 2016, 'womMonth' = 1, 'womNth' = 4, 'womDayOfWeek' = 1} 102 | -- @ 103 | {-# INLINE weekdayOfMonth #-} 104 | weekdayOfMonth :: Iso' Day WeekdayOfMonth 105 | weekdayOfMonth = iso toWeekday fromWeekday where 106 | 107 | {-# INLINEABLE toWeekday #-} 108 | toWeekday :: Day -> WeekdayOfMonth 109 | toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where 110 | YearMonthDay y m d = ord ^. yearMonthDay 111 | WeekDate _ _ wd = toWeekOrdinal ord day 112 | n = 1 + div (d - 1) 7 113 | 114 | {-# INLINEABLE fromWeekday #-} 115 | fromWeekday :: WeekdayOfMonth -> Day 116 | fromWeekday (WeekdayOfMonth y m n wd) = refDay .+^ s * offset where 117 | refOrd = yearMonthDay # YearMonthDay y m 118 | (if n < 0 then monthLength (isLeapYear y) m else 1) 119 | refDay = ordinalDate # refOrd 120 | WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay 121 | s = signum n 122 | wo = s * (wd - wd1) 123 | offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo 124 | 125 | -- | Convert a 'WeekdayOfMonth' to a 'Day'. 126 | -- Returns 'Nothing' for invalid input. 127 | -- 128 | -- For example, the third /Sunday/ of /January 2016/ is /2016-01-27/, but 129 | -- there is no fifth /Monday/ in /January 2016/. 130 | -- 131 | -- @ 132 | -- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 3 7) 133 | -- 'Just' 2016-01-17 134 | -- > 'weekdayOfMonthValid' ('WeekdayOfMonth' 2016 1 5 1) 135 | -- 'Nothing' 136 | -- @ 137 | {-# INLINEABLE weekdayOfMonthValid #-} 138 | weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day 139 | weekdayOfMonthValid (WeekdayOfMonth y m n wd) = (refDay .+^ s * offset) 140 | <$ guard (n /= 0 && 1 <= wd && wd <= 7 && offset < len) where 141 | len = monthLength (isLeapYear y) m 142 | refOrd = yearMonthDay # YearMonthDay y m (if n < 0 then len else 1) 143 | refDay = ordinalDate # refOrd 144 | WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay 145 | s = signum n 146 | wo = s * (wd - wd1) 147 | offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo 148 | 149 | -------------------------------------------------------------------------------- /src/Data/Thyme/Time/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | #if HLINT 9 | #include "cabal_macros.h" 10 | #endif 11 | 12 | -- | This module provides the 'Thyme' typeclass, and instances for 13 | -- converting between "Data.Time" and "Data.Thyme" types. It also provides 14 | -- compatibility wrappers for existing code using "Data.Time". 15 | -- 16 | -- Note that we do not provide 'Num' hierarchy instances for 'DiffTime' nor 17 | -- 'NominalDiffTime' here. If you want to use them anyway despite parts of 18 | -- them being ill-defined (e.g. @('*')@ on 'DiffTime'), import 19 | -- "Data.Thyme.Time" instead. 20 | 21 | module Data.Thyme.Time.Core 22 | ( module Data.Thyme 23 | , module Data.Thyme.Time.Core 24 | ) where 25 | 26 | import Prelude 27 | import Control.Lens 28 | import Data.AffineSpace 29 | import Data.Fixed 30 | import Data.Ratio 31 | import Data.Thyme 32 | import Data.Thyme.Clock.TAI 33 | import qualified Data.Time.Calendar as T 34 | import qualified Data.Time.Clock as T 35 | import qualified Data.Time.Clock.TAI as T 36 | import qualified Data.Time.LocalTime as T 37 | import Data.Thyme.TrueName 38 | 39 | ------------------------------------------------------------------------ 40 | -- * Type conversion 41 | 42 | -- | Typeclass for converting between "Data.Time" and "Data.Thyme" types. 43 | class Thyme time thyme | thyme -> time where 44 | -- | Convert between "Data.Time" and "Data.Thyme" types. 45 | -- 46 | -- @ 47 | -- > :set -t 48 | -- > import qualified "Data.Time" 49 | -- 50 | -- > 'thyme' 'Control.Lens.#' ('fromSeconds'' 10 :: 'DiffTime') 51 | -- 10s 52 | -- it :: 'Data.Time.DiffTime' 53 | -- 54 | -- > 'Data.Time.secondsToDiffTime' 10 '^.' 'thyme' :: 'DiffTime' 55 | -- 10s 56 | -- it :: 'DiffTime' 57 | -- @ 58 | thyme :: Iso' time thyme 59 | 60 | instance Thyme T.Day Day where 61 | {-# INLINE thyme #-} 62 | thyme = iso 63 | (ModifiedJulianDay . fromInteger . T.toModifiedJulianDay) 64 | (T.ModifiedJulianDay . toInteger . toModifiedJulianDay) 65 | 66 | instance Thyme T.UniversalTime UniversalTime where 67 | {-# INLINE thyme #-} 68 | thyme = iso T.getModJulianDate T.ModJulianDate . from modJulianDate 69 | 70 | instance Thyme T.DiffTime DiffTime where 71 | {-# INLINE thyme #-} 72 | thyme = dt . fixed . from picoseconds where 73 | dt = iso (\ [truename| ''T.DiffTime MkDiffTime | ps |] -> ps ) 74 | [truename| ''T.DiffTime MkDiffTime |] 75 | #if MIN_VERSION_base(4,7,0) 76 | fixed = iso (\ (MkFixed n) -> n ) MkFixed 77 | #else 78 | fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n ) 79 | [truename| ''Fixed MkFixed |] 80 | #endif 81 | 82 | instance Thyme T.NominalDiffTime NominalDiffTime where 83 | {-# INLINE thyme #-} 84 | thyme = ndt . fixed . from picoseconds where 85 | ndt = iso (\ [truename| ''T.NominalDiffTime MkNominalDiffTime | ps |] -> ps ) 86 | [truename| ''T.NominalDiffTime MkNominalDiffTime |] 87 | #if MIN_VERSION_base(4,7,0) 88 | fixed = iso (\ (MkFixed n) -> n ) MkFixed 89 | #else 90 | fixed = iso (\ [truename| ''Fixed MkFixed | n |] -> n ) 91 | [truename| ''Fixed MkFixed |] 92 | #endif 93 | 94 | instance Thyme T.UTCTime UTCView where 95 | {-# INLINE thyme #-} 96 | thyme = iso 97 | (\ (T.UTCTime d t) -> UTCView (d ^. thyme) (t ^. thyme)) 98 | (\ (UTCView d t) -> T.UTCTime (thyme # d) (thyme # t)) 99 | 100 | instance Thyme T.UTCTime UTCTime where 101 | {-# INLINE thyme #-} 102 | thyme = thyme . from utcTime 103 | 104 | instance Thyme T.AbsoluteTime AbsoluteTime where 105 | {-# INLINE thyme #-} 106 | thyme = iso (`T.diffAbsoluteTime` T.taiEpoch) 107 | (`T.addAbsoluteTime` T.taiEpoch) 108 | . thyme . iso (taiEpoch .+^) (.-. taiEpoch) 109 | 110 | instance Thyme T.TimeZone TimeZone where 111 | {-# INLINE thyme #-} 112 | thyme = iso (\ T.TimeZone {..} -> TimeZone {..}) 113 | (\ TimeZone {..} -> T.TimeZone {..}) 114 | 115 | instance Thyme T.TimeOfDay TimeOfDay where 116 | {-# INLINE thyme #-} 117 | thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m $ 118 | microseconds # round (s * 1000000) ) 119 | ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational $ 120 | toInteger (s ^. microseconds) % 1000000 ) 121 | 122 | instance Thyme T.LocalTime LocalTime where 123 | {-# INLINE thyme #-} 124 | thyme = iso 125 | (\ (T.LocalTime d t) -> LocalTime (d ^. thyme) (t ^. thyme)) 126 | (\ (LocalTime d t) -> T.LocalTime (thyme # d) (thyme # t)) 127 | 128 | instance Thyme T.ZonedTime ZonedTime where 129 | {-# INLINE thyme #-} 130 | thyme = iso 131 | (\ (T.ZonedTime t z) -> ZonedTime (t ^. thyme) (z ^. thyme)) 132 | (\ (ZonedTime t z) -> T.ZonedTime (thyme # t) (thyme # z)) 133 | 134 | -- | Convert a "Data.Time" type to a "Data.Thyme" type, if you would rather 135 | -- not use "Control.Lens" directly. 136 | -- 137 | -- @ 138 | -- 'toThyme' = 'view' 'thyme' 139 | -- 'toThyme' t ≡ t '^.' 'thyme' 140 | -- @ 141 | {-# INLINE toThyme #-} 142 | toThyme :: (Thyme time thyme) => time -> thyme 143 | toThyme = view thyme 144 | 145 | -- | Convert a "Data.Thyme" type to a "Data.Time" type, if you would rather 146 | -- not use "Control.Lens" directly. 147 | -- 148 | -- @ 149 | -- 'fromThyme' = 'review' 'thyme' 150 | -- 'fromThyme' t ≡ 'thyme' 'Control.Lens.#' t 151 | -- @ 152 | {-# INLINE fromThyme #-} 153 | fromThyme :: (Thyme time thyme) => thyme -> time 154 | fromThyme = review thyme 155 | 156 | -------------------------------------------------------------------------------- /thyme.cabal: -------------------------------------------------------------------------------- 1 | name: thyme 2 | version: 0.4.1 3 | synopsis: A faster time library 4 | description: 5 | @thyme@ is a performance-optimized rewrite of the excellent 6 | @@ library. 7 | . 8 | See @@ 9 | for a full description. 10 | homepage: https://github.com/fumieval/thyme 11 | license: BSD3 12 | license-file: LICENSE 13 | author: Liyang HU, Ashley Yakeley 14 | maintainer: Fumiaki Kinoshita 15 | copyright: © 2013−2014 Liyang HU 16 | category: Data, System 17 | build-type: Simple 18 | cabal-version: >= 1.10 19 | stability: experimental 20 | extra-source-files: 21 | CHANGELOG.md 22 | README.md 23 | include/thyme.h 24 | tested-with: 25 | GHC >= 8.4 && < 9.12 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/fumieval/thyme 30 | 31 | flag bug-for-bug 32 | description: bug-for-bug compatibility with time 33 | default: True 34 | manual: True 35 | 36 | flag docs 37 | description: include extra packages for Data.Thyme.Docs; implies -flens 38 | default: False 39 | manual: True 40 | 41 | flag HLint 42 | description: include HLint as a Cabal test-suite 43 | default: False 44 | manual: True 45 | 46 | flag lens 47 | description: use the full lens package 48 | default: False 49 | manual: True 50 | 51 | flag show-internal 52 | description: instance Show of internal representation 53 | default: False 54 | manual: True 55 | 56 | library 57 | default-language: Haskell2010 58 | include-dirs: include 59 | hs-source-dirs: src 60 | if !(flag(lens) || flag(docs)) 61 | hs-source-dirs: lens 62 | exposed-modules: 63 | Data.Thyme 64 | Data.Thyme.Docs 65 | Data.Thyme.Calendar 66 | Data.Thyme.Calendar.MonthDay 67 | Data.Thyme.Calendar.OrdinalDate 68 | Data.Thyme.Calendar.WeekDate 69 | Data.Thyme.Calendar.WeekdayOfMonth 70 | Data.Thyme.Clock 71 | Data.Thyme.Clock.POSIX 72 | Data.Thyme.Clock.TAI 73 | Data.Thyme.Format 74 | Data.Thyme.Format.Human 75 | Data.Thyme.Format.Aeson 76 | Data.Thyme.Internal.Micro 77 | Data.Thyme.LocalTime 78 | Data.Thyme.Time 79 | Data.Thyme.Time.Core 80 | other-modules: 81 | Data.Thyme.Calendar.Internal 82 | Data.Thyme.Clock.Internal 83 | Data.Thyme.Format.Internal 84 | Data.Thyme.TrueName 85 | if !(flag(lens) || flag(docs)) 86 | other-modules: Control.Lens 87 | build-depends: 88 | QuickCheck >= 2.4, 89 | attoparsec >= 0.10, 90 | aeson >= 0.6, 91 | base >= 4.5 && < 5, 92 | bytestring >= 0.9, 93 | containers >= 0.5, 94 | deepseq >= 1.2, 95 | hashable >= 1.2, 96 | mtl >= 1.1, 97 | old-locale >= 1.0, 98 | random, 99 | text >= 0.11, 100 | template-haskell >=2.7 && <2.24, 101 | time >= 1.4, 102 | vector >= 0.9, 103 | vector-th-unbox >= 0.2.1.0, 104 | vector-space >= 0.8 105 | 106 | if os(windows) 107 | build-depends: Win32 108 | if os(darwin) || os(freebsd) 109 | build-tools: cpphs 110 | ghc-options: "-pgmP cpphs --cpp" 111 | if flag(lens) || flag(docs) 112 | build-depends: lens >= 3.9 113 | else 114 | build-depends: profunctors >= 3.1.2 115 | if flag(docs) 116 | build-depends: integer-gmp, ghc-prim 117 | ghc-options: -Wall 118 | if flag(bug-for-bug) 119 | cpp-options: -DBUG_FOR_BUG=1 120 | if flag(show-internal) 121 | cpp-options: -DSHOW_INTERNAL=1 122 | 123 | test-suite sanity 124 | default-language: Haskell2010 125 | type: exitcode-stdio-1.0 126 | hs-source-dirs: tests 127 | if !flag(lens) 128 | hs-source-dirs: lens 129 | main-is: sanity.hs 130 | other-modules: Common 131 | if !flag(lens) 132 | other-modules: Control.Lens 133 | build-depends: 134 | QuickCheck, 135 | attoparsec, 136 | base < 5, 137 | bytestring, 138 | old-locale, 139 | text, 140 | thyme, 141 | time, 142 | vector-space 143 | if flag(lens) 144 | build-depends: lens 145 | else 146 | build-depends: profunctors, mtl 147 | ghc-options: -Wall 148 | 149 | test-suite rewrite 150 | default-language: Haskell2010 151 | type: exitcode-stdio-1.0 152 | hs-source-dirs: tests 153 | main-is: rewrite.hs 154 | build-depends: 155 | base < 5, 156 | containers, 157 | random, 158 | thyme 159 | ghc-options: -Wall 160 | 161 | test-suite hlint 162 | default-language: Haskell2010 163 | type: exitcode-stdio-1.0 164 | hs-source-dirs: tests 165 | main-is: hlint.hs 166 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 167 | if flag(HLint) 168 | build-depends: base < 5, hlint >= 1.9 169 | else 170 | buildable: False 171 | 172 | benchmark bench 173 | default-language: Haskell2010 174 | type: exitcode-stdio-1.0 175 | hs-source-dirs: tests 176 | if !flag(lens) 177 | hs-source-dirs: lens 178 | main-is: bench.hs 179 | other-modules: Common 180 | if !flag(lens) 181 | other-modules: Control.Lens 182 | build-depends: 183 | QuickCheck, 184 | base < 5, 185 | criterion, 186 | mtl, 187 | old-locale, 188 | random, 189 | thyme, 190 | time, 191 | vector, 192 | vector-space 193 | if flag(lens) 194 | build-depends: lens 195 | else 196 | build-depends: profunctors 197 | ghc-options: -Wall 198 | 199 | -- vim: et sw=4 ts=4 sts=4: 200 | 201 | -------------------------------------------------------------------------------- /src/Data/Thyme/Calendar/OrdinalDate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | #include "thyme.h" 7 | #if HLINT 8 | #include "cabal_macros.h" 9 | #endif 10 | 11 | -- | ISO 8601 Ordinal Date format 12 | module Data.Thyme.Calendar.OrdinalDate 13 | ( Year, isLeapYear 14 | , DayOfYear 15 | , OrdinalDate (..), _odYear, _odDay 16 | , ordinalDate 17 | , module Data.Thyme.Calendar.OrdinalDate 18 | ) where 19 | 20 | import Prelude 21 | #if !MIN_VERSION_base(4,8,0) 22 | import Control.Applicative 23 | #endif 24 | import Control.Arrow 25 | import Control.Lens 26 | import Control.Monad 27 | import Data.Thyme.Calendar 28 | import Data.Thyme.Calendar.Internal 29 | import System.Random 30 | import Test.QuickCheck 31 | 32 | instance Bounded OrdinalDate where 33 | minBound = minBound ^. ordinalDate 34 | maxBound = maxBound ^. ordinalDate 35 | 36 | instance Random OrdinalDate where 37 | randomR = randomIsoR ordinalDate 38 | random = first (^. ordinalDate) . random 39 | 40 | instance Arbitrary OrdinalDate where 41 | arbitrary = view ordinalDate <$> arbitrary 42 | shrink od = view ordinalDate <$> shrink (ordinalDate # od) 43 | 44 | instance CoArbitrary OrdinalDate where 45 | coarbitrary (OrdinalDate y d) = coarbitrary y . coarbitrary d 46 | 47 | -- | Convert an 'OrdinalDate' to a 'Day', or 'Nothing' for invalid input. 48 | -- 49 | -- @ 50 | -- > 'ordinalDateValid' ('OrdinalDate' 2015 365) 51 | -- 'Just' 2015-12-31 52 | -- 53 | -- > 'ordinalDateValid' ('OrdinalDate' 2015 366) 54 | -- 'Nothing' 55 | -- 56 | -- > 'ordinalDateValid' ('OrdinalDate' 2016 366) 57 | -- 'Just' 2016-12-31 58 | -- @ 59 | {-# INLINE ordinalDateValid #-} 60 | ordinalDateValid :: OrdinalDate -> Maybe Day 61 | ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od 62 | <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365) 63 | 64 | -- * Compatibility 65 | 66 | {-# INLINE toOrdinalDate #-} 67 | -- | Convert a 'Day' to its Gregorian 'Year' and 'DayOfYear'. 68 | -- 69 | -- @ 70 | -- 'toOrdinalDate' ('view' 'ordinalDate' -> 'OrdinalDate' y d) = (y, d) 71 | -- @ 72 | toOrdinalDate :: Day -> (Year, DayOfYear) 73 | toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d) 74 | 75 | -- | Convert a Gregorian 'Year' and 'DayOfYear' to a 'Day'. 76 | -- Does not validate the input. 77 | -- 78 | -- @ 79 | -- 'fromOrdinalDate' y d = 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' y d 80 | -- @ 81 | {-# INLINE fromOrdinalDate #-} 82 | fromOrdinalDate :: Year -> DayOfYear -> Day 83 | fromOrdinalDate y d = ordinalDate # OrdinalDate y d 84 | 85 | -- | Converts a Gregorian 'Year' and 'DayOfYear' to a 'Day'. 86 | -- Returns 'Nothing' on invalid input. 87 | -- 88 | -- @ 89 | -- 'fromOrdinalDateValid' y d = 'ordinalDateValid' ('OrdinalDate' y d) 90 | -- @ 91 | {-# INLINE fromOrdinalDateValid #-} 92 | fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day 93 | fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d) 94 | 95 | -- | Converts a 'Day' to its /Sunday/-starting week date. 96 | -- 97 | -- The first /Sunday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier 98 | -- days in the same year are week @0@. This corresponds to @\"%U\"@ for 99 | -- 'formatTime'. 100 | -- 101 | -- /Sunday/ is @0 ∷ 'DayOfWeek'@, /Saturday/ is @6@. This corresponds to 102 | -- @\"%w\"@ for 'formatTime'. 103 | -- 104 | -- @ 105 | -- 'sundayStartWeek' ('view' 'sundayWeek' -> 'SundayWeek' y w d) = (y, w, d) 106 | -- @ 107 | {-# INLINE sundayStartWeek #-} 108 | sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek) 109 | sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d) 110 | 111 | -- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the 112 | -- inverse of 'sundayStartWeek'. 113 | -- Does not validate the input. 114 | -- 115 | -- @ 116 | -- 'fromSundayStartWeek' y w d = 'sundayWeek' 'Control.Lens.#' 'SundayWeek' y w d 117 | -- @ 118 | {-# INLINE fromSundayStartWeek #-} 119 | fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day 120 | fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d 121 | 122 | -- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the 123 | -- inverse of 'sundayStartWeek'. 124 | -- Returns 'Nothing' for invalid input. 125 | -- 126 | -- @ 127 | -- 'fromSundayStartWeekValid' y w d = 'sundayWeekValid' ('SundayWeek' y w d) 128 | -- @ 129 | {-# INLINE fromSundayStartWeekValid #-} 130 | fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day 131 | fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d) 132 | 133 | -- | Converts a 'Day' to its /Monday/-starting week date. 134 | -- 135 | -- The first /Monday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier 136 | -- days in the same year are week @0@. This corresponds to @\"%W\"@ for 137 | -- 'formatTime'. 138 | -- 139 | -- /Monday/ is @1 ∷ 'DayOfWeek'@, /Sunday/ is @7@. This corresponds to 140 | -- @\"%u\"@ for 'formatTime'. 141 | -- 142 | -- @ 143 | -- 'mondayStartWeek' ('view' 'mondayWeek' -> 'MondayWeek' y w d) = (y, w, d) 144 | -- @ 145 | {-# INLINE mondayStartWeek #-} 146 | mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek) 147 | mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d) 148 | 149 | -- | Converts a /Monday/-starting week date to the corresponding 'Day'; the 150 | -- inverse of 'mondayStartWeek'. 151 | -- Does not validate the input. 152 | -- 153 | -- @ 154 | -- 'fromMondayStartWeek' y w d = 'mondayWeek' 'Control.Lens.#' 'MondayWeek' y w d 155 | -- @ 156 | {-# INLINE fromMondayStartWeek #-} 157 | fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day 158 | fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d 159 | 160 | -- | Converts a /Monday/-starting week date to the corresponding 'Day'; the 161 | -- inverse of 'mondayStartWeek'. 162 | -- Returns 'Nothing' for invalid input. 163 | -- 164 | -- @ 165 | -- 'fromMondayStartWeekValid' y w d = 'mondayWeekValid' ('MondayWeek' y w d) 166 | -- @ 167 | {-# INLINE fromMondayStartWeekValid #-} 168 | fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day 169 | fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d) 170 | 171 | -------------------------------------------------------------------------------- /src/Data/Thyme/Clock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 708 3 | {-# LANGUAGE PatternSynonyms #-} 4 | #endif 5 | 6 | {-| Types and functions for 7 | and 8 | . 9 | 10 | If you don't care about leap seconds, keep to 'UTCTime' and 11 | 'NominalDiffTime' for your clock calculations, and you'll be fine. 12 | 13 | "Data.Thyme.Time" provides 'Num', 'Real', 'Fractional' and 'RealFrac' 14 | instances for 'DiffTime' and 'NominalDiffTime', but their use is 15 | discouraged. See "Data.Thyme.Docs#spaces" for details. 16 | 17 | Use 'fromSeconds' and 'toSeconds' to convert between 'DiffTime' 18 | / 'NominalDiffTime' and other numeric types; use 'fromSeconds'' for 19 | literals to avoid type defaulting warnings. 20 | 21 | -} 22 | 23 | module Data.Thyme.Clock ( 24 | -- * UTC 25 | UTCTime 26 | , utctDay, utctDayTime 27 | , _utctDay, _utctDayTime 28 | #if __GLASGOW_HASKELL__ >= 708 29 | , pattern UTCTime 30 | #endif 31 | , mkUTCTime 32 | , utcTime 33 | 34 | , UTCView (..), _utcvDay, _utcvDayTime 35 | , NominalDiffTime 36 | 37 | , getCurrentTime 38 | 39 | -- * Absolute intervals 40 | , DiffTime 41 | 42 | -- * Time interval conversion 43 | , TimeDiff (..) 44 | , toSeconds, fromSeconds 45 | , toSeconds', fromSeconds' 46 | , picoseconds 47 | 48 | -- * Universal Time 49 | , UniversalTime 50 | #if __GLASGOW_HASKELL__ >= 708 51 | , pattern UniversalTime 52 | #endif 53 | , modJulianDate 54 | 55 | -- * Compatibility 56 | , getModJulianDate 57 | , mkModJulianDate 58 | , secondsToDiffTime 59 | , picosecondsToDiffTime 60 | , unUTCTime 61 | , addUTCTime 62 | , diffUTCTime 63 | , toMicroseconds 64 | , fromMicroseconds 65 | ) where 66 | 67 | import Prelude 68 | import Control.Lens 69 | import Data.AffineSpace 70 | import Data.Int 71 | import Data.Ratio ((%)) 72 | import Data.Thyme.Clock.Internal 73 | import Data.Thyme.Clock.POSIX 74 | 75 | -- | Get the current UTC date and time from the local system clock. 76 | -- 77 | -- @ 78 | -- > 'Data.Thyme.Clock.getCurrentTime' 79 | -- 2016-01-15 13:42:02.287688 UTC 80 | -- @ 81 | -- 82 | -- See also: 'Data.Thyme.LocalTime.getZonedTime', 'getPOSIXTime'. 83 | getCurrentTime :: IO UTCTime 84 | getCurrentTime = fmap (review posixTime) getPOSIXTime 85 | 86 | -- | Conversion between 'TimeDiff' and picoseconds. In the reverse 87 | -- direction, picoseconds are 'round'ed to the nearest microsecond. 88 | {-# INLINE picoseconds #-} 89 | picoseconds :: (TimeDiff t) => Iso' t Integer 90 | picoseconds = microseconds . iso 91 | ((*) 1000000 . toInteger) (\ ps -> round (ps % 1000000)) 92 | 93 | ------------------------------------------------------------------------ 94 | 95 | -- | Convert a 'UniversalTime' to the fractional number of days since the 96 | -- . 97 | -- 98 | -- @ 99 | -- 'getModJulianDate' = 'view' 'modJulianDate' 100 | -- @ 101 | {-# INLINE getModJulianDate #-} 102 | getModJulianDate :: UniversalTime -> Rational 103 | getModJulianDate = view modJulianDate 104 | 105 | -- | Construct a 'UniversalTime' from the fractional number of days since the 106 | -- . 107 | -- 108 | -- @ 109 | -- 'mkModJulianDate' = 'review' 'modJulianDate' 110 | -- @ 111 | {-# INLINE mkModJulianDate #-} 112 | mkModJulianDate :: Rational -> UniversalTime 113 | mkModJulianDate = review modJulianDate 114 | 115 | -- | Construct a 'DiffTime' from some number of seconds. 116 | -- 117 | -- This is just 'fromSeconds' with a more constrained type. 118 | -- 119 | -- @ 120 | -- 'secondsToDiffTime' = 'fromSeconds' 121 | -- @ 122 | {-# INLINE secondsToDiffTime #-} 123 | secondsToDiffTime :: Int64 -> DiffTime 124 | secondsToDiffTime = fromSeconds 125 | 126 | -- | Construct a 'DiffTime' from some number of picoseconds. 127 | -- The input will be rounded to the nearest microsecond. 128 | -- 129 | -- @ 130 | -- 'picosecondsToDiffTime' a = 'microseconds' 'Control.Lens.#' 'quot' (a '+' 'signum' a '*' 500000) 1000000 131 | -- @ 132 | {-# INLINE picosecondsToDiffTime #-} 133 | picosecondsToDiffTime :: Integer -> DiffTime 134 | picosecondsToDiffTime = review picoseconds 135 | 136 | -- | Decompose a 'UTCTime' into a 'UTCView'. 137 | -- 138 | -- @ 139 | -- 'unUTCTime' = 'view' 'utcTime' 140 | -- @ 141 | -- 142 | -- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g. 143 | -- 144 | -- @ 145 | -- f :: 'UTCTime' -> ('Day', 'DiffTime') 146 | -- f ('unUTCTime' -> 'UTCView' day dt) = (day, dt) 147 | -- @ 148 | -- 149 | -- For GHC 7.8 or later, there is also the pattern synonym 150 | -- @@. 151 | {-# INLINE unUTCTime #-} 152 | unUTCTime :: UTCTime -> UTCView 153 | unUTCTime = view utcTime 154 | 155 | -- | Add a duration to a point in time. 156 | -- 157 | -- @ 158 | -- 'addUTCTime' = 'flip' ('.+^') 159 | -- 'addUTCTime' d t ≡ t '.+^' d 160 | -- @ 161 | -- 162 | -- See also the 'AffineSpace' instance for 'UTCTime'. 163 | {-# INLINE addUTCTime #-} 164 | addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime 165 | addUTCTime = flip (.+^) 166 | 167 | -- | The duration difference between two time points. 168 | -- 169 | -- @ 170 | -- 'diffUTCTime' = ('.-.') 171 | -- 'diffUTCTime' a b = a '.-.' b 172 | -- @ 173 | -- 174 | -- See also the 'AffineSpace' instance for 'UTCTime'. 175 | {-# INLINE diffUTCTime #-} 176 | diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime 177 | diffUTCTime = (.-.) 178 | 179 | -- | The number of microseconds in a 'DiffTime' or 'NominalDiffTime'. 180 | -- 181 | -- @ 182 | -- 'toMicroseconds' :: 'DiffTime' -> 'Int64' 183 | -- 'toMicroseconds' :: 'NominalDiffTime' -> 'Int64' 184 | -- 'toMicroseconds' = 'view' 'microseconds' 185 | -- 'toMicroseconds' d ≡ d '^.' 'microseconds' 186 | -- @ 187 | {-# INLINE toMicroseconds #-} 188 | toMicroseconds :: (TimeDiff t) => t -> Int64 189 | toMicroseconds = view microseconds 190 | 191 | -- | Construct a 'DiffTime' or 'NominalDiffTime' from a number of 192 | -- microseconds. 193 | -- 194 | -- @ 195 | -- 'fromMicroseconds' :: 'Int64' -> 'DiffTime' 196 | -- 'fromMicroseconds' :: 'Int64' -> 'NominalDiffTime' 197 | -- 'fromMicroseconds' = 'review' 'microseconds' 198 | -- 'fromMicroseconds' n ≡ 'microseconds' 'Control.Lens.#' n 199 | -- @ 200 | {-# INLINE fromMicroseconds #-} 201 | fromMicroseconds :: (TimeDiff t) => Int64 -> t 202 | fromMicroseconds = review microseconds 203 | 204 | -------------------------------------------------------------------------------- /src/Data/Thyme/Calendar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | #include "thyme.h" 7 | #if HLINT 8 | #include "cabal_macros.h" 9 | #endif 10 | 11 | -- | Calendar calculations. 12 | -- 13 | -- Note that 'UTCTime' is not Y294K-compliant, and 'Bounded' instances for 14 | -- the various calendar types reflect this fact. That said, the calendar 15 | -- calculations by themselves work perfectly fine for a wider range of 16 | -- dates, subject to the size of 'Int' for your platform. 17 | module Data.Thyme.Calendar 18 | ( 19 | -- * Day 20 | Day (..), modifiedJulianDay 21 | 22 | -- * Calendar 23 | , Year, Month, DayOfMonth 24 | , YearMonthDay (..), _ymdYear, _ymdMonth, _ymdDay 25 | , Years, Months, Days 26 | 27 | -- * Gregorian calendar 28 | -- $proleptic 29 | , isLeapYear 30 | , yearMonthDay, gregorian, gregorianValid, showGregorian 31 | , module Data.Thyme.Calendar 32 | ) where 33 | 34 | import Prelude hiding ((.)) 35 | #if !MIN_VERSION_base(4,8,0) 36 | import Control.Applicative 37 | #endif 38 | import Control.Arrow 39 | import Control.Category 40 | import Control.Lens 41 | import Control.Monad 42 | import Data.AdditiveGroup 43 | import Data.AffineSpace 44 | import Data.Thyme.Calendar.Internal 45 | import Data.Thyme.Clock.Internal 46 | import System.Random 47 | import Test.QuickCheck 48 | 49 | -- "Data.Thyme.Calendar.Internal" cannot import "Data.Thyme.Clock.Internal", 50 | -- therefore these orphan 'Bounded' instances must live here. 51 | instance Bounded Day where 52 | minBound = minBound ^. _utctDay 53 | maxBound = maxBound ^. _utctDay 54 | 55 | instance Bounded YearMonthDay where 56 | minBound = minBound ^. gregorian 57 | maxBound = maxBound ^. gregorian 58 | 59 | instance Random Day where 60 | randomR r = first (^. _utctDay) . randomR (range r) where 61 | -- upper bound is one Micro second before the next day 62 | range = toMidnight *** pred . toMidnight . succ 63 | toMidnight day = utcTime # UTCView day zeroV 64 | random = randomR (minBound, maxBound) 65 | 66 | instance Random YearMonthDay where 67 | randomR = randomIsoR gregorian 68 | random = first (^. gregorian) . random 69 | 70 | instance Arbitrary Day where 71 | arbitrary = ModifiedJulianDay 72 | <$> choose (join (***) toModifiedJulianDay (minBound, maxBound)) 73 | shrink (ModifiedJulianDay mjd) = ModifiedJulianDay <$> shrink mjd 74 | 75 | instance Arbitrary YearMonthDay where 76 | arbitrary = view gregorian <$> arbitrary 77 | shrink ymd = view gregorian <$> shrink (gregorian # ymd) 78 | 79 | instance CoArbitrary YearMonthDay where 80 | coarbitrary (YearMonthDay y m d) 81 | = coarbitrary y . coarbitrary m . coarbitrary d 82 | 83 | ------------------------------------------------------------------------ 84 | 85 | -- $proleptic 86 | -- 87 | -- Note that using the 88 | -- calendar for 89 | -- dates before its adoption (from 1582 onwards, but varies from one country 90 | -- to the next) produces 91 | -- , 92 | -- which may cause some confusion. 93 | 94 | -- | The number of days in a given month in the 95 | -- calendar. 96 | -- 97 | -- @ 98 | -- > 'gregorianMonthLength' 2005 2 99 | -- 28 100 | -- @ 101 | {-# INLINE gregorianMonthLength #-} 102 | gregorianMonthLength :: Year -> Month -> Days 103 | gregorianMonthLength = monthLength . isLeapYear 104 | 105 | -- | Add months, with days past the last day of the month clipped to the 106 | -- last day. 107 | -- 108 | -- See also 'addGregorianMonthsClip'. 109 | -- 110 | -- @ 111 | -- > 'gregorianMonthsClip' 1 '$' 'YearMonthDay' 2005 1 30 112 | -- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 2, 'ymdDay' = 28} 113 | -- @ 114 | {-# INLINEABLE gregorianMonthsClip #-} 115 | gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay 116 | gregorianMonthsClip n (YearMonthDay y m d) = YearMonthDay y' m' 117 | $ min (gregorianMonthLength y' m') d where 118 | ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12 119 | 120 | -- | Add months, with days past the last day of the month rolling over to 121 | -- the next month. 122 | -- 123 | -- See also 'addGregorianMonthsRollover'. 124 | -- 125 | -- @ 126 | -- > 'gregorianMonthsRollover' 1 $ 'YearMonthDay' 2005 1 30 127 | -- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 3, 'ymdDay' = 2} 128 | -- @ 129 | {-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-} 130 | {-# INLINEABLE gregorianMonthsRollover #-} 131 | gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay 132 | gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of 133 | True -> YearMonthDay y' m' d 134 | False -> case m' < 12 of 135 | True -> YearMonthDay y' (m' + 1) (d - len) 136 | False -> YearMonthDay (y' + 1) 1 (d - len) 137 | where 138 | ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12 139 | len = gregorianMonthLength y' m' 140 | 141 | -- | Add years, matching month and day, with /February 29th/ clipped to the 142 | -- /28th/ if necessary. 143 | -- 144 | -- See also 'addGregorianYearsClip'. 145 | -- 146 | -- @ 147 | -- > 'gregorianYearsClip' 2 $ 'YearMonthDay' 2004 2 29 148 | -- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 2, 'ymdDay' = 28} 149 | -- @ 150 | {-# INLINEABLE gregorianYearsClip #-} 151 | gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay 152 | gregorianYearsClip n (YearMonthDay ((+) n -> y') 2 29) 153 | | not (isLeapYear y') = YearMonthDay y' 2 28 154 | gregorianYearsClip n (YearMonthDay y m d) = YearMonthDay (y + n) m d 155 | 156 | -- | Add years, matching month and day, with /February 29th/ rolled over to 157 | -- /March 1st/ if necessary. 158 | -- 159 | -- See also 'addGregorianYearsRollover'. 160 | -- 161 | -- @ 162 | -- > 'gregorianYearsRollover' 2 $ 'YearMonthDay' 2004 2 29 163 | -- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 3, 'ymdDay' = 1} 164 | -- @ 165 | {-# INLINEABLE gregorianYearsRollover #-} 166 | gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay 167 | gregorianYearsRollover n (YearMonthDay ((+) n -> y') 2 29) 168 | | not (isLeapYear y') = YearMonthDay y' 3 1 169 | gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d 170 | 171 | -- * Compatibility 172 | 173 | -- | Add some 'Days' to a calendar 'Day' to get a new 'Day'. 174 | -- 175 | -- @ 176 | -- 'addDays' = 'flip' ('.+^') 177 | -- 'addDays' n d ≡ d '.+^' n 178 | -- @ 179 | -- 180 | -- See also the 'AffineSpace' instance for 'Day'. 181 | {-# INLINE addDays #-} 182 | addDays :: Days -> Day -> Day 183 | addDays = flip (.+^) 184 | 185 | -- | Subtract two calendar 'Day's for the difference in 'Days'. 186 | -- 187 | -- @ 188 | -- 'diffDays' = ('.-.') 189 | -- 'diffDays' a b = a '.-.' b 190 | -- @ 191 | -- 192 | -- See also the 'AffineSpace' instance for 'Day'. 193 | {-# INLINE diffDays #-} 194 | diffDays :: Day -> Day -> Days 195 | diffDays = (.-.) 196 | 197 | -- | Convert a 'Day' to its Gregorian 'Year', 'Month', and 'DayOfMonth'. 198 | -- 199 | -- @ 200 | -- 'toGregorian' ('view' 'gregorian' -> 'YearMonthDay' y m d) = (y, m, d) 201 | -- @ 202 | {-# INLINE toGregorian #-} 203 | toGregorian :: Day -> (Year, Month, DayOfMonth) 204 | toGregorian (view gregorian -> YearMonthDay y m d) = (y, m, d) 205 | 206 | -- | Construct a 'Day' from a Gregorian calendar date. 207 | -- Does not validate the input. 208 | -- 209 | -- @ 210 | -- 'fromGregorian' y m d = 'gregorian' 'Control.Lens.#' 'YearMonthDay' y m d 211 | -- @ 212 | {-# INLINE fromGregorian #-} 213 | fromGregorian :: Year -> Month -> DayOfMonth -> Day 214 | fromGregorian y m d = gregorian # YearMonthDay y m d 215 | 216 | -- | Construct a 'Day' from a Gregorian calendar date. 217 | -- Returns 'Nothing' for invalid input. 218 | -- 219 | -- @ 220 | -- 'fromGregorianValid' y m d = 'gregorianValid' ('YearMonthDay' y m d) 221 | -- @ 222 | {-# INLINE fromGregorianValid #-} 223 | fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day 224 | fromGregorianValid y m d = gregorianValid (YearMonthDay y m d) 225 | 226 | -- | Add some number of 'Months' to the given 'Day'; if the original 227 | -- 'DayOfMonth' exceeds that of the new 'Month', it will be clipped to the 228 | -- last day of the new 'Month'. 229 | -- 230 | -- @ 231 | -- 'addGregorianMonthsClip' n = 'gregorian' '%~' 'gregorianMonthsClip' n 232 | -- @ 233 | {-# INLINE addGregorianMonthsClip #-} 234 | addGregorianMonthsClip :: Months -> Day -> Day 235 | addGregorianMonthsClip n = gregorian %~ gregorianMonthsClip n 236 | 237 | -- | Add some number of 'Months' to the given 'Day'; if the original 238 | -- 'DayOfMonth' exceeds that of the new 'Month', it will be rolled over into 239 | -- the following 'Month'. 240 | -- 241 | -- @ 242 | -- 'addGregorianMonthsRollover' n = 'gregorian' '%~' 'gregorianMonthsRollover' n 243 | -- @ 244 | {-# INLINE addGregorianMonthsRollover #-} 245 | addGregorianMonthsRollover :: Months -> Day -> Day 246 | addGregorianMonthsRollover n = gregorian %~ gregorianMonthsRollover n 247 | 248 | -- | Add some number of 'Years' to the given 'Day', with /February 29th/ 249 | -- clipped to /February 28th/ if necessary. 250 | -- 251 | -- @ 252 | -- 'addGregorianYearsClip' n = 'gregorian' '%~' 'gregorianYearsClip' n 253 | -- @ 254 | {-# INLINE addGregorianYearsClip #-} 255 | addGregorianYearsClip :: Years -> Day -> Day 256 | addGregorianYearsClip n = gregorian %~ gregorianYearsClip n 257 | 258 | -- | Add some number of 'Years' to the given 'Day', with /February 29th/ 259 | -- rolled over to /March 1st/ if necessary. 260 | -- 261 | -- @ 262 | -- 'addGregorianYearsRollover' n = 'gregorian' '%~' 'gregorianYearsRollover' n 263 | -- @ 264 | {-# INLINE addGregorianYearsRollover #-} 265 | addGregorianYearsRollover :: Years -> Day -> Day 266 | addGregorianYearsRollover n = gregorian %~ gregorianYearsRollover n 267 | 268 | -------------------------------------------------------------------------------- /src/Data/Thyme/Docs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 3 | 4 | module Data.Thyme.Docs 5 | ( 6 | -- * #api#API 7 | -- $api 8 | 9 | -- ** #compat#Compatibility with @time@ 10 | -- $compat 11 | 12 | -- ** #spaces#VectorSpace and AffineSpace 13 | -- $spaces 14 | 15 | -- ** #lenses#Isomorphisms and Lenses 16 | -- $lenses 17 | 18 | -- * #tutorial#Tutorial 19 | -- $tutorial 20 | 21 | -- * #impl#Implementation 22 | -- $impl 23 | 24 | -- ** #range#Range 25 | -- $range 26 | 27 | -- ** #prec#Precision 28 | -- $prec 29 | 30 | -- ** #perf#Performance 31 | -- $perf 32 | ) where 33 | 34 | import Control.Lens 35 | import Data.AffineSpace 36 | import Data.Int 37 | import Data.IntMap (Key, IntMap) 38 | import Data.Map.Strict (Map) 39 | import Data.Thyme 40 | import Data.Thyme.Calendar.WeekDate 41 | import Data.Thyme.Clock.TAI 42 | import Data.Thyme.Format.Human 43 | import Data.Thyme.Time.Core 44 | import qualified Data.Time as T 45 | import Data.VectorSpace 46 | 47 | -- Note: {{{ and }}} below are fold markers for Vim. Please ignore. 48 | 49 | {- {{{ api -} 50 | {- $api 51 | 52 | In general stick to 'UTCTime' and 'NominalDiffTime' for time calculations, 53 | converting from/to 'LocalTime', or 'ZonedTime' et cetera only for 54 | input/output. 55 | 56 | Synonyms for 'Int'—such as 'Year', 'Month', and 'DayOfMonth'—are provided 57 | for more descriptive type signatures. There are records (with strict and 58 | unpacked fields) for some common tuples, e.g. 'YearMonthDay', instead of 59 | @('Integer', 'Int', 'Int')@. 60 | 61 | On platforms where the native 'Int' is 64-bits wide, types with an 'Enum' 62 | instance such as 'Day' can be used as 'Key's for 'IntMap', preferably via an 63 | @@ wrapper. In any 64 | case the 'Ord' instances are much faster, if you must use 'Map'. 65 | 66 | -}{- }}} -} 67 | 68 | {- {{{ compat -} 69 | {- $compat 70 | 71 | @thyme@ tries to maintain API compatibility with @time@ and each module 72 | exports the same functions as corresponding one in @time@. There are however 73 | some differences to keep in mind: 74 | 75 | * 'UTCTime' is an opaque type and there is no @UTCTime@ constructor. Since 76 | GHC 7.8 you can use the @@ 77 | pattern synonym. In any case, 'utcTime' can convert it to a 'UTCView'. 78 | 79 | * 'UniversalTime' similarly has the 80 | @@ pattern synonym, 81 | along with 'modJulianDate'. 82 | 83 | * 'Year's are 'Int's, not 'Integer's: you may need 'fromIntegral'. 84 | 85 | * If you'd rather not use @lens@ or @vector-space@ directly, most modules 86 | list functions under a ‘Compatibility’ section that mimics the @time@ API. 87 | 88 | * Where a third party library uses @time@, you can use 'toThyme' and 89 | 'fromThyme' from "Data.Thyme.Time.Core" to convert between the 90 | corresponding types. 91 | 92 | * "Data.Thyme.Time" provides 'Num', 'Real', 'Fractional', and 'RealFrac' 93 | instances for 'DiffTime' and 'NominalDiffTime'. Avoid using this in new 94 | code, <#spaces because of reasons>. 95 | 96 | Any other differences not covered here may be unintentional. Please check 97 | on GitHub and 98 | file a new one if necessary. 99 | 100 | -}{- }}} -} 101 | 102 | {- {{{ spaces -} 103 | {- $spaces 104 | 105 | One of the issues arising from 'Num', 'Real', 'Fractional', and 'RealFrac' 106 | instances for e.g. 'NominalDiffTime' is that we must also supply nonsensical 107 | operations such as @('*')@: multiplying two quantities of 108 | 109 | gives something of dimension /T²/, yet according to the type of @('*')@ the 110 | result is another 'NominalDiffTime' of dimension /T/. 111 | 112 | A more principled approach is to invoke our geometric intuition and think of 113 | instants in time as points in a one-dimensional affine space—that is, a line 114 | without an origin per se; a time-line, if you will. Taking the distance 115 | (displacement) between two points in this space amounts to finding the 116 | (signed) duration between two instants in time. These durations are akin to 117 | vectors in the geometric sense, and as such we can add, subtract, or scaled 118 | them by some factor to obtain another duration. Conversely a point plus (or 119 | minus) a vector results in another point, and likewise an instant in time 120 | plus (or minus) a duration takes us to another instant in time. 121 | 122 | The 'AffineSpace' and 'VectorSpace' classes from 123 | allows us to 124 | express exactly this idea: 'UTCTime' correspond to points on the time-line, 125 | and is therefore an instance of 'AffineSpace' with the associated 126 | 127 | @ 128 | type 'Diff' 'UTCTime' = 'NominalDiffTime' 129 | @ 130 | 131 | as the type of durations between instants. It may help to think of the 132 | provided operations as having these restricted types: 133 | 134 | @ 135 | ('.-.') :: 'UTCTime' -> 'UTCTime' -> 'NominalDiffTime' 136 | ('.+^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime' 137 | ('.-^') :: 'UTCTime' -> 'NominalDiffTime' -> 'UTCTime' 138 | @ 139 | 140 | In turn 'NominalDiffTime' is an instance of 'VectorSpace' (and also 141 | 'AdditiveGroup') which comes with the following operations: 142 | 143 | @ 144 | ('^+^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime' 145 | ('^-^') :: 'NominalDiffTime' -> 'NominalDiffTime' -> 'NominalDiffTime' 146 | @ 147 | 148 | Said instance also defines @type 'Scalar' 'NominalDiffTime' = 'Rational'@, 149 | so we can scale 'NominalDiffTime's thusly: 150 | 151 | @ 152 | ('*^') :: 'Rational' -> 'NominalDiffTime' -> 'NominalDiffTime' 153 | ('^*') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime' 154 | ('^/') :: 'NominalDiffTime' -> 'Rational' -> 'NominalDiffTime' 155 | @ 156 | 157 | On operator naming: remember that @.@ are points, and @^@ are vectors. 158 | Thus @('.+^')@ corresponds to the operation /point plus vector/, and 159 | @('^-^')@ means /vector minus vector/, and so on. 160 | 161 | Similarly, 'AbsoluteTime' is an 'AffineSpace', and 'DiffTime' is 162 | a 'VectorSpace', with 163 | 164 | @ 165 | type 'Diff' 'AbsoluteTime' = 'DiffTime' 166 | type 'Scalar' 'DiffTime' = 'Rational' 167 | @ 168 | 169 | If you must have 'Num', 'Real', 'Fractional', and 'RealFrac' for 'DiffTime' 170 | and 'NominalDiffTime', they are provided as orhpan instances in the 171 | "Data.Thyme.Time" module. 172 | 173 | -}{- }}} -} 174 | 175 | {- {{{ lenses -} 176 | {- $lenses 177 | 178 | Since a large part of @thyme@'s functionality is involved in converting back 179 | and forth between various representations of time, it's convenient to expose 180 | these as "Control.Lens.Iso"s from the 181 | @@ package, and field 182 | accessors as "Control.Lens.Lens"es. 183 | 184 | A full @lens@ 185 | is however beyond the scope of this documentation. As far as /using/ @thyme@ 186 | is concerned, it's sufficient to restrict ourselves to a subset of the 187 | @lens@ API: 188 | 189 | @ 190 | 'view' :: 'Lens'' s a -> s -> a 191 | 'review' :: 'Iso'' s a -> a -> s 192 | 'over' :: 'Lens'' s a -> (a -> a) -> s -> s 193 | @ 194 | 195 | There are infix versions of the above: 196 | 197 | @ 198 | ('^.') = 'flip' 'view' 199 | ('Control.Lens.#') = 'review' 200 | ('%~') = 'over' 201 | @ 202 | 203 | An 'Iso'' can be used wherever a 'Lens'' is required, so it is helpful to 204 | think of 'view' and 'over' as also having the following types: 205 | 206 | @ 207 | 'view' :: 'Iso'' s a -> s -> a 208 | 'over' :: 'Iso'' s a -> (a -> a) -> s -> s 209 | @ 210 | 211 | You can use a @'Lens'' s a@ to extract an @a@ out of an @s@ with 'view'. An 212 | 'Iso' s a' means you can also construct an @s@ from an @a@ with 'review'. 213 | Furthermore 'Lens''s and 'Iso''s can be chained with the standard @('.')@ 214 | function composition. 215 | 216 | @ 217 | ('.') :: 'Lens'' s u -> 'Lens'' u a -> 'Lens'' s a 218 | ('.') :: 'Iso'' s u -> 'Iso'' u a -> 'Iso'' s a 219 | @ 220 | 221 | Composing an 'Iso'' with a 'Lens'' however ‘downgrades’ the result to 222 | a 'Lens''. 223 | 224 | The <#tutorial tutorial below> has some examples. 225 | 226 | -}{- }}} -} 227 | 228 | {- {{{ tutorial -} 229 | {- $tutorial 230 | 231 | Start @ghci@ with the @lens@ and @vector-space@ packages, along with some 232 | preliminary imports: 233 | 234 | @ 235 | $ ghci -package thyme -package lens -package vector-space 236 | > import "Control.Lens" 237 | > import "Data.AffineSpace" 238 | > import "Data.Thyme" 239 | > import "Data.VectorSpace" 240 | @ 241 | 242 | Let's begin by getting the current UTC date and time from the local system 243 | clock: 244 | 245 | @ 246 | > now <- 'getCurrentTime' 247 | > now 248 | 2016-04-06 03:50:11.159991 UTC 249 | @ 250 | 251 | What date and time is it in my local time zone, formatted using the default 252 | locale? 253 | 254 | @ 255 | > zone <- 'getCurrentTimeZone' 256 | > 'formatTime' 'defaultTimeLocale' \"%c\" $ (zone, now) '^.' 'zonedTime' 257 | "Wed Apr 6 12:50:11 JST 2016" 258 | @ 259 | 260 | See also: 'getZonedTime'. 261 | 262 | What will be the local time-of-day be /1000/ seconds from now? 263 | 264 | @ 265 | > (now '.+^' 'fromSeconds'' 1000) '^.' 'utcLocalTime' zone '.' '_localTimeOfDay' 266 | 12:50:11.159991 267 | @ 268 | 269 | Approximately how long has it been since the Unix epoch at midnight 270 | /1970-01-01/? 271 | 272 | @ 273 | > import "Data.Thyme.Format.Human" 274 | > let posixEpoch = 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 1970 1 1) 'zeroV' 275 | > 'humanTimeDiff' (now '.-.' posixEpoch) 276 | "5 decades" 277 | @ 278 | 279 | Two months from today, what day of the week will it be? 280 | 281 | @ 282 | > import "Data.Thyme.Calendar.WeekDate" 283 | > let later = now '&' '_utctDay' '.' 'gregorian' '%~' 'gregorianMonthsClip' 2 284 | > later 285 | 2016-06-06 03:50:11.159991 UTC 286 | > later '^.' '_utctDay' '.' 'weekDate' 287 | 'WeekDate' {'wdYear' = 2016, 'wdWeek' = 23, 'wdDay' = 1} 288 | > 'formatTime' 'defaultTimeLocale' \"%A\" later 289 | "Monday" 290 | @ 291 | 292 | -}{- }}} -} 293 | 294 | {- {{{ impl -} 295 | {- $impl 296 | 297 | The performance improvement of "Data.Thyme" comes chiefly from representing 298 | times internally as a single @newtype@d 'Int64's instead of multiple 299 | 'GHC.Integer.GMP.Internals.Integer's, as is the case with 300 | "Data.Time.Clock"@.@'T.UTCTime'. The trade-offs are summarised below. 301 | 302 | -}{- }}} -} 303 | 304 | {- {{{ range -} 305 | {- $range 306 | 307 | 'T.UTCTime' from "Data.Time.Clock" has unbounded range, whereas 'UTCTime' 308 | from "Data.Thyme.Clock" has a usable range just under 600,000 years, between 309 | the following times inclusive: 310 | 311 | @ 312 | -290419-11-07 19:59:05.224192 UTC 313 | 294135-11-26 04:00:54.775807 UTC 314 | @ 315 | 316 | @thyme@ is therefore not Y294K-compliant. 317 | 318 | -}{- }}} -} 319 | 320 | {- {{{ prec -} 321 | {- $prec 322 | 323 | 'UTCTime', 'NominalDiffTime', 'DiffTime', and so on from "Data.Thyme.Clock" 324 | have resolutions of /1 μs/ = /10^-6 s/, while those from "Data.Time.Clock" 325 | have resolutions of /1 ps/ = /10^-12 s/. 326 | 327 | However keep in mind that a call to @gettimeofday(3)@ or @clock_gettime(3)@ 328 | takes on the order of ~0.4μs on a relatively recent (circa 2016) desktop, so 329 | the coarser resolution is not really an issue in almost all applications. 330 | 331 | -}{- }}} -} 332 | 333 | {- {{{ perf -} 334 | {- $perf 335 | 336 | "Data.Thyme.Clock"@.@'UTCTime' is implemented as @newtype@ wrappers around 337 | a single 'Int64', so that 'addUTCTime' and 'diffUTCTime' both compile down 338 | to a single arithmetic operation. Likewise "Data.Thyme.Clock"@.@'DiffTime' 339 | (and 'NominalDiffTime') are also @newtype@s over 'Int64's. 340 | 341 | "Data.Time.Clock"@.@'T.UTCTime' on the other hand comprises of two 342 | 'Integer's internally: one for the 'T.Day' and another for the 'T.DiffTime' 343 | time-of-day. Here 'T.diffUTCTime' has to account for the difference in 344 | 'T.Day's, while 'T.addUTCTime' must normalise its result to ensure 345 | 'T.utctDayTime' stays within 'T.posixDayLength'. 346 | 347 | Furthermore, any "Data.Time.Clock"@.@'T.DiffTime' (and 'T.NominalDiffTime') 348 | longer than /~2.15 ms/ exceeds /2^31 ps/, and would overflow a native 349 | 'GHC.Prim.Int#' on 32-bit architectures, incurring the cost of using 350 | 'GHC.Integer.GMP.Internals.BigNat's inside 351 | 'GHC.Integer.GMP.Internals.Integer'. Even for 64-bit 'Int#'s, /2^63 ps/ 352 | corresponds to only /~106 days/, and it's not inconceivable to deal with 353 | durations longer than this. In both cases, there is the additional overhead 354 | of working with lifted 'GHC.Integer.GMP.Internals.Integer's. 355 | 356 | -}{- }}} -} 357 | 358 | -------------------------------------------------------------------------------- /src/Data/Thyme/Clock/TAI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | 12 | #include "thyme.h" 13 | #if HLINT 14 | #include "cabal_macros.h" 15 | #endif 16 | 17 | #define TAIUTCDAT @@ 18 | 19 | -- | 20 | -- (TAI) and conversion to/from UTC, accounting for leap seconds. 21 | module Data.Thyme.Clock.TAI 22 | ( AbsoluteTime 23 | , taiEpoch 24 | , TAIUTCMap (..) 25 | , TAIUTCRow (..) 26 | , absoluteTime 27 | , absoluteTime' 28 | , utcDayLength 29 | , parseTAIUTCRow 30 | , makeTAIUTCMap 31 | , parseTAIUTCDAT 32 | 33 | -- * Compatibility 34 | , addAbsoluteTime 35 | , diffAbsoluteTime 36 | , utcToTAITime 37 | , taiToUTCTime 38 | ) where 39 | 40 | import Prelude 41 | #if !MIN_VERSION_base(4,8,0) 42 | import Control.Applicative 43 | #endif 44 | import Control.DeepSeq 45 | import Control.Lens 46 | import Control.Monad 47 | import Data.AffineSpace 48 | import Data.Attoparsec.ByteString.Char8 (()) 49 | import qualified Data.Attoparsec.ByteString.Char8 as P 50 | import qualified Data.ByteString as S 51 | import Data.Data 52 | import Data.Hashable 53 | import Data.Ix 54 | import Data.Map.Strict (Map) 55 | import qualified Data.Map.Strict as Map 56 | import Data.Thyme.Calendar 57 | import Data.Thyme.Clock.Internal 58 | import Data.Thyme.Format.Internal (indexOf) 59 | import Data.Thyme.Internal.Micro 60 | import Data.Thyme.LocalTime 61 | #if __GLASGOW_HASKELL__ == 704 62 | import qualified Data.Vector.Generic 63 | import qualified Data.Vector.Generic.Mutable 64 | #endif 65 | import Data.Vector.Unboxed.Deriving 66 | import Data.VectorSpace 67 | import GHC.Generics (Generic) 68 | import System.Random (Random) 69 | import Test.QuickCheck 70 | 71 | -- | 72 | -- (TAI). Note that for most applications 'UTCTime' is perfectly sufficient, 73 | -- and much more convenient to use. 74 | -- 75 | -- Internally this is the number of seconds since 'taiEpoch'. TAI days are 76 | -- exactly 86400 SI seconds long. 77 | newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO) 78 | 79 | derivingUnbox "AbsoluteTime" [t| AbsoluteTime -> DiffTime |] 80 | [| \ (AbsoluteTime a) -> a |] [| AbsoluteTime |] 81 | 82 | instance Show AbsoluteTime where 83 | {-# INLINEABLE showsPrec #-} 84 | showsPrec p tai = showsPrec p lt . (++) " TAI" where 85 | lt = tai ^. from (absoluteTime $ TAIUTCMap mempty mempty) . utcLocalTime utc 86 | 87 | -- | The 88 | -- epoch, which is /1858-11-17 00:00:00 TAI/. 89 | {-# INLINE taiEpoch #-} 90 | taiEpoch :: AbsoluteTime 91 | taiEpoch = AbsoluteTime zeroV 92 | 93 | instance AffineSpace AbsoluteTime where 94 | type Diff AbsoluteTime = DiffTime 95 | {-# INLINE (.-.) #-} 96 | (.-.) = \ (AbsoluteTime a) (AbsoluteTime b) -> a ^-^ b 97 | {-# INLINE (.+^) #-} 98 | (.+^) = \ (AbsoluteTime a) d -> AbsoluteTime (a ^+^ d) 99 | 100 | -- | A table of 'TAIUTCRow's for converting between TAI and UTC. 101 | -- 102 | -- The two 'Map's are keyed on the corresponding instants in UTC and TAI 103 | -- from which the 'TAIUTCRow' becomes applicable. The 'UTCTime' key of the 104 | -- first 'Map' is always at midnight. 105 | -- 106 | -- No table is provided here because leap seconds are unpredictable, and any 107 | -- program shipped with such a table could become out-of-date in as little 108 | -- as 6 months. See 'parseTAIUTCDAT' for details. 109 | data TAIUTCMap = TAIUTCMap (Map UTCTime TAIUTCRow) (Map AbsoluteTime TAIUTCRow) 110 | deriving (INSTANCES_USUAL, Show) 111 | 112 | -- | Each line of TAIUTCDAT (see 'parseTAIUTCDAT') specifies the difference 113 | -- between TAI and UTC for a particular period. For example: 114 | -- 115 | -- @ 116 | -- 1968 FEB 1 =JD 2439887.5 TAI-UTC= 4.2131700 S + (MJD - 39126.) X 0.002592 S 117 | -- @ 118 | -- 119 | -- says that from 1968-02-01 00:00:00 (Julian Date 2439887.5; or Modified 120 | -- Julian Date 39887.0), the difference between TAI and UTC is @4.2131700s@ 121 | -- (the /additive/ part) plus a scaled component that increases for each day 122 | -- beyond MJD 39126 (the /base/) by 0.002592s (the /coefficient/). In 123 | -- general, the latter half of each line is of the form: 124 | -- 125 | -- @ 126 | -- TAI-UTC= /additive/ S + (MJD - /base/) X /coefficient/ S 127 | -- @ 128 | -- 129 | -- @'TAIUTCRow' a b c@ is a normalised version of the above, with the /base/ 130 | -- multiplied by 86400s, and the /coefficient/ divided by the same. This 131 | -- allows us to use the internal representation of 'UTCTime'—seconds since 132 | -- the MJD epoch—as the @MJD@ term without further rescaling. 133 | -- 134 | -- Note that between 1961-01-01 and 1972-01-01, each UTC second was actually 135 | -- slightly longer than one TAI (or SI) second. For the first year this was 136 | -- at the rate of exactly 1.000000015 TAI (or SI) seconds per UTC second, 137 | -- but was subject to irregular updates. Since leap seconds came into effect 138 | -- on 1972-01-01, the /additive/ part has always been an intergral number of 139 | -- seconds, and the /coefficient/ has always been zero. 140 | -- 141 | -- To convert between TAI and UTC, we refer to the definition: 142 | -- 143 | -- @ 144 | -- TAI - UTC = a + (MJD - b) * c 145 | -- @ 146 | -- 147 | -- Using UTC for MJD (with 'b' and 'c' scaled as described above): 148 | -- 149 | -- @ 150 | -- TAI = UTC + a + (UTC - b) * c 151 | -- TAI - a + b * c = UTC + UTC * c 152 | -- (TAI - a + b * c) / (1 + c) = UTC 153 | -- @ 154 | -- 155 | -- This is implemented by 'absoluteTime' and 'absoluteTime''. 156 | -- 157 | -- Further reading: 158 | -- 159 | -- * https://en.wikipedia.org/wiki/Coordinated_Universal_Time 160 | -- * https://en.wikipedia.org/wiki/International_Atomic_Time 161 | data TAIUTCRow = TAIUTCRow !DiffTime !UTCTime !Rational 162 | -- ^ Each row comprises of an /additive/ component, the /base/ of the 163 | -- scaled component, and the /coefficient/ of the scaled component. 164 | deriving (INSTANCES_USUAL, Show) 165 | 166 | {-# INLINE lookupLE #-} 167 | lookupLE :: (Ord k) => k -> Map k TAIUTCRow -> TAIUTCRow 168 | lookupLE k = maybe (TAIUTCRow zeroV (UTCRep zeroV) 0) snd . Map.lookupLE k 169 | 170 | {-# INLINE unwrap #-} 171 | unwrap :: TAIUTCRow -> (Micro, Micro, Rational) 172 | unwrap (TAIUTCRow (DiffTime a) (UTCRep (NominalDiffTime b)) c) = (a, b, c) 173 | 174 | -- | Convert between 'UTCTime' and 'AbsoluteTime' using a 'TAIUTCMap'. 175 | -- 176 | -- Since 'UTCTime' cannot represent a time-of-day of 86400s or more, any 177 | -- conversion from 'AbsoluteTime' that happens to be during a leap second 178 | -- will overflow into the next day. 179 | -- 180 | -- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below. 181 | -- 182 | -- @ 183 | -- > let jul1 = 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV' 184 | -- > jul1 '&' 'absoluteTime' tum '%~' ('.-^' 'fromSeconds' 1.1) 185 | -- 2015-06-30 23:59:59.9 UTC 186 | -- @ 187 | {-# INLINE absoluteTime #-} 188 | absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime 189 | absoluteTime (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where 190 | {-# INLINEABLE toTAI #-} 191 | toTAI :: UTCTime -> AbsoluteTime 192 | toTAI utime@(UTCRep (NominalDiffTime uts)) = AbsoluteTime . DiffTime $ 193 | uts ^+^ a ^+^ (uts ^-^ b) ^* c where 194 | (a, b, c) = unwrap $ lookupLE utime utcMap 195 | 196 | {-# INLINEABLE toUTC #-} 197 | toUTC :: AbsoluteTime -> UTCTime 198 | toUTC atime@(AbsoluteTime (DiffTime ats)) = UTCRep . NominalDiffTime $ 199 | (ats ^-^ a ^+^ b ^* c) ^/ (1 + c) where 200 | (a, b, c) = unwrap $ lookupLE atime taiMap 201 | 202 | -- | Convert between 'UTCView' and TAI 'AbsoluteTime' using a 'TAIUTCMap'. 203 | -- 204 | -- Unlike 'absoluteTime', 'UTCView' /can/ represent a time-of-day greater 205 | -- than 86400s, and this gives the correct results during a leap second. 206 | -- 207 | -- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below. 208 | -- 209 | -- @ 210 | -- > let jul1 = 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV' 211 | -- > jul1 '&' 'absoluteTime'' tum '%~' ('.-^' 'fromSeconds' 0.1) 212 | -- 'UTCView' {'utcvDay' = 2015-06-30, 'utcvDayTime' = 86400.9s} 213 | -- @ 214 | -- 215 | -- However keep in mind that currently there is no standard way to get the 216 | -- TAI on most platforms. Simply converting the result of 217 | -- 'Data.Thyme.Clock.getCurrentTime' (which calls @gettimeofday(2)@) to 218 | -- 'AbsoluteTime' during a leap second will still give non-monotonic times. 219 | {-# INLINE absoluteTime' #-} 220 | absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime 221 | absoluteTime' (TAIUTCMap utcMap taiMap) = iso toTAI toUTC where 222 | {-# INLINEABLE toTAI #-} 223 | toTAI :: UTCView -> AbsoluteTime 224 | toTAI uview@(UTCView day _) = AbsoluteTime . DiffTime $ 225 | uts ^+^ a ^+^ (uts ^-^ b) ^* c where 226 | (a, b, c) = unwrap $ lookupLE (utcTime # UTCView day zeroV) utcMap 227 | UTCRep (NominalDiffTime uts) = utcTime # uview 228 | 229 | {-# INLINEABLE toUTC #-} 230 | toUTC :: AbsoluteTime -> UTCView 231 | toUTC atime@(AbsoluteTime (DiffTime ats)) = fixup (utime ^. utcTime) where 232 | row@(unwrap -> (a, b, c)) = lookupLE atime taiMap 233 | utime = UTCRep . NominalDiffTime $ (ats ^-^ a ^+^ b ^* c) ^/ (1 + c) 234 | -- 'lookupLE' of the same instant in 'utcMap' and 'taiMap' should 235 | -- give the same 'TAIUTCRow'. If it doesn't, then @utime@ must have 236 | -- overflown into the next 'Day'. 237 | fixup uview@(UTCView day dt) = if lookupLE utime utcMap == row 238 | then uview else UTCView (day .-^ 1) (fromSeconds' 86400 ^+^ dt) 239 | 240 | -- TODO: Linux >= 3.10 has @CLOCK_TAI@ for @clock_gettime(2)@. 241 | 242 | -- | Using a 'TAIUTCMap', lookup the 'DiffTime' length of the UTC 'Day'. 243 | -- 244 | -- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below. 245 | -- 246 | -- @ 247 | -- > 'utcDayLength' tum '.' 'view' '_utctDay' '<$>' 'getCurrentTime' 248 | -- 86400s 249 | -- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30 250 | -- 86401s 251 | -- @ 252 | utcDayLength :: TAIUTCMap -> Day -> DiffTime 253 | utcDayLength tum day = diff (day .+^ 1) .-. diff day where 254 | diff d = UTCView d zeroV ^. from utcTime . absoluteTime tum 255 | 256 | -- | @attoparsec@ 'P.Parser' for a single line of TAIUTCDAT. 257 | -- 258 | -- Returns the starting 'UTCTime' and the normalised 'TAIUTCRow'. 259 | parseTAIUTCRow :: P.Parser (UTCTime, TAIUTCRow) 260 | parseTAIUTCRow = do 261 | y <- P.skipSpace *> P.decimal "Year" 262 | let months = [ "JAN", "FEB", "MAR", "APR", "MAY", "JUN" 263 | , "JUL", "AUG", "SEP", "OCT", "NOV", "DEC" ] 264 | m <- (+) 1 <$ P.skipSpace <*> indexOf months "Month" 265 | d <- P.skipSpace *> P.decimal "DayOfMonth" 266 | 267 | tokens ["=", "JD"] 268 | -- TAI-UTC changes always happen at midnight UTC, so just ignore ".5". 269 | since <- subtract 2400000{-.5-} <$> P.decimal 270 | <* P.string ".5" "Julian Date .5" 271 | let ymd = YearMonthDay y m d 272 | unless (gregorian # ymd == ModifiedJulianDay since) $ do 273 | fail $ show ymd ++ " ≠ MJD " ++ show since 274 | ++ " ≡ " ++ show (ModifiedJulianDay since) 275 | 276 | tokens ["TAI", "-", "UTC", "="] 277 | a <- P.rational "Additive" 278 | tokens ["S", "+", "(", "MJD", "-"] 279 | b <- P.decimal <* P.char '.' "Base" -- also always midnight UTC 280 | tokens [")", "X"] 281 | c <- (/ toSeconds' posixDayLength) <$> P.rational 282 | <* P.skipSpace <* P.string "S" "Coefficient" 283 | 284 | return (mjdToUTC since, TAIUTCRow (fromSeconds' a) (mjdToUTC b) c) 285 | where 286 | tokens ts = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) 287 | P.skipSpace ts ("tokens " ++ show ts) 288 | mjdToUTC mjd = utcTime # UTCView (ModifiedJulianDay mjd) zeroV 289 | 290 | -- | Build a 'TAIUTCMap' from the result of 'parseTAIUTCRow'. 291 | makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap 292 | makeTAIUTCMap rows = TAIUTCMap (Map.fromList rows) 293 | (Map.fromList $ invert <$> rows) where 294 | invert (since, entry) = (since ^. absoluteTime single, entry) where 295 | single = TAIUTCMap (Map.singleton since entry) mempty 296 | 297 | -- | Parse the contents of TAIUTCDAT into a 'TAIUTCMap' for conversion 298 | -- between TAI and UTC. 299 | -- 300 | -- @ 301 | -- $ curl -O \"http:\/\/maia.usno.navy.mil\/ser7\/tai-utc.dat\" 302 | -- $ ghci --package thyme 303 | -- > import "Data.Thyme" 304 | -- > import "Data.Thyme.Clock.TAI" 305 | -- > import "Data.ByteString" ('S.readFile') 306 | -- > Right tum \<- 'parseTAIUTCDAT' '<$>' 'S.readFile' \"tai-utc.dat\" 307 | -- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30 308 | -- 86401s 309 | -- @ 310 | parseTAIUTCDAT :: S.ByteString -> Either String TAIUTCMap 311 | parseTAIUTCDAT = P.parseOnly $ makeTAIUTCMap <$> P.manyTill 312 | (parseTAIUTCRow <* P.endOfLine) P.endOfInput 313 | 314 | ------------------------------------------------------------------------ 315 | 316 | -- | Add a duration to an 'AbsoluteTime'. 317 | -- 318 | -- @ 319 | -- 'addAbsoluteTime' = 'flip' ('.+^') 320 | -- 'addAbsoluteTime' d t ≡ t '.+^' d 321 | -- @ 322 | -- 323 | -- See also the 'AffineSpace' instance for 'AbsoluteTime'. 324 | {-# INLINE addAbsoluteTime #-} 325 | addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime 326 | addAbsoluteTime = flip (.+^) 327 | 328 | -- | The duration difference between two 'AbsoluteTime's. 329 | -- 330 | -- @ 331 | -- 'diffAbsoluteTime' = ('.-.') 332 | -- 'diffAbsoluteTime' a b ≡ a '.-.' b 333 | -- @ 334 | -- 335 | -- See also the 'AffineSpace' instance for 'AbsoluteTime'. 336 | {-# INLINE diffAbsoluteTime #-} 337 | diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime 338 | diffAbsoluteTime = (.-.) 339 | 340 | -- | Using a 'TAIUTCMap', convert a 'UTCTime' to 'AbsoluteTime'. 341 | -- 342 | -- @ 343 | -- 'utcToTAITime' = 'view' '.' 'absoluteTime' 344 | -- @ 345 | {-# INLINE utcToTAITime #-} 346 | utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime 347 | utcToTAITime m = view (absoluteTime m) 348 | 349 | -- | Using a 'TAIUTCMap', convert a 'AbsoluteTime' to 'UTCTime'. 350 | -- 351 | -- @ 352 | -- 'taiToUTCTime' = 'review' '.' 'absoluteTime' 353 | -- @ 354 | {-# INLINE taiToUTCTime #-} 355 | taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime 356 | taiToUTCTime m = review (absoluteTime m) 357 | 358 | -------------------------------------------------------------------------------- /src/Data/Thyme/TrueName.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Refer to . 4 | 5 | module Data.Thyme.TrueName (summon, truename) where 6 | 7 | import Prelude 8 | #if !MIN_VERSION_base(4,8,0) 9 | import Control.Applicative 10 | #endif 11 | import Control.Monad 12 | import Data.List (nub) 13 | import Language.Haskell.TH.Ppr 14 | import Language.Haskell.TH.PprLib 15 | import Language.Haskell.TH.Quote 16 | import Language.Haskell.TH.Syntax 17 | 18 | conNames :: Con -> [Name]{- {{{ -} 19 | conNames con = case con of 20 | NormalC name _ -> [name] 21 | RecC name vbts -> name : [ fname | (fname, _, _) <- vbts ] 22 | InfixC _ name _ -> [name] 23 | ForallC _ _ con' -> conNames con' 24 | 25 | #if MIN_VERSION_template_haskell(2,11,0) 26 | GadtC names _ typ -> names ++ typNames typ 27 | RecGadtC names vbts typ -> names ++ typNames typ 28 | ++ [ fname | (fname, _, _) <- vbts] 29 | #endif 30 | {- }}} -} 31 | 32 | decNames :: Dec -> [Name]{- {{{ -} 33 | decNames dec = case dec of 34 | FunD _ _ -> [] 35 | ValD _ _ _ -> [] 36 | TySynD _ _ typ -> typNames typ 37 | ClassD _ _ _ _ decs -> decNames =<< decs 38 | #if MIN_VERSION_template_haskell(2,11,0) 39 | InstanceD _ cxt typ decs -> 40 | #else 41 | InstanceD cxt typ decs -> 42 | #endif 43 | (predNames =<< cxt) ++ typNames typ ++ (decNames =<< decs) 44 | SigD name typ -> name : typNames typ 45 | 46 | #if MIN_VERSION_template_haskell(2,16,0) 47 | KiSigD name kind -> name : typNames kind 48 | #endif 49 | 50 | ForeignD frgn -> case frgn of 51 | ImportF _ _ _ name t -> name : typNames t 52 | ExportF _ _ name t -> name : typNames t 53 | PragmaD _ -> [] 54 | 55 | #if MIN_VERSION_template_haskell(2,11,0) 56 | DataD _ _ _ _ cons _ -> conNames =<< cons 57 | NewtypeD _ _ _ _ con _ -> conNames con 58 | #else 59 | DataD _ _ _ cons _ -> conNames =<< cons 60 | NewtypeD _ _ _ con _ -> conNames con 61 | #endif 62 | 63 | #if MIN_VERSION_template_haskell(2,12,0) 64 | PatSynD _name _args _dir _pat -> [] 65 | PatSynSigD _name typ -> typNames typ 66 | #endif 67 | 68 | #if MIN_VERSION_template_haskell(2,22,0) 69 | InfixD _ _ _ -> [] 70 | #elif MIN_VERSION_template_haskell(2,8,0) 71 | InfixD _ _ -> [] 72 | #endif 73 | 74 | #if MIN_VERSION_template_haskell(2,12,0) 75 | DataInstD cxt _name _typs _kind cons derivs -> 76 | datatypeNames cxt cons ++ derivNames derivs 77 | NewtypeInstD cxt _name _typs _kind con derivs -> 78 | datatypeNames cxt [con] ++ derivNames derivs 79 | #elif MIN_VERSION_template_haskell(2,11,0) 80 | DataInstD cxt _ _ _ cons derivs -> 81 | datatypeNames cxt cons ++ (predNames =<< derivs) 82 | NewtypeInstD cxt _ _ _ con derivs -> 83 | datatypeNames cxt [con] ++ (predNames =<< derivs) 84 | #else 85 | DataInstD cxt _ _ cons derivs -> datatypeNames cxt cons ++ derivs 86 | NewtypeInstD cxt _ _ con derivs -> datatypeNames cxt [con] ++ derivs 87 | #endif 88 | 89 | #if MIN_VERSION_template_haskell(2,11,0) 90 | DataFamilyD _ _ _ -> [] 91 | OpenTypeFamilyD _ -> [] 92 | #else 93 | FamilyD _ _ _ _ -> [] 94 | #endif 95 | 96 | #if MIN_VERSION_template_haskell(2,11,0) 97 | ClosedTypeFamilyD _ tses -> tseNames =<< tses 98 | #elif MIN_VERSION_template_haskell(2,9,0) 99 | ClosedTypeFamilyD _ _ _ tses -> tseNames =<< tses 100 | #endif 101 | 102 | #if MIN_VERSION_template_haskell(2,15,0) 103 | TySynInstD tse -> tseNames tse 104 | #elif MIN_VERSION_template_haskell(2,9,0) 105 | TySynInstD _ tse -> tseNames tse 106 | #else 107 | TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t 108 | #endif 109 | 110 | #if MIN_VERSION_template_haskell(2,9,0) 111 | RoleAnnotD _ _ -> [] 112 | #endif 113 | 114 | #if MIN_VERSION_template_haskell(2,12,0) 115 | StandaloneDerivD _strat cxt typ -> (predNames =<< cxt) ++ typNames typ 116 | #elif MIN_VERSION_template_haskell(2,10,0) 117 | StandaloneDerivD cxt typ -> (predNames =<< cxt) ++ typNames typ 118 | #endif 119 | 120 | #if MIN_VERSION_template_haskell(2,10,0) 121 | DefaultSigD _ _ -> [] 122 | #endif 123 | 124 | #if MIN_VERSION_template_haskell(2,15,0) 125 | ImplicitParamBindD _ _ -> [] 126 | #endif 127 | 128 | #if MIN_VERSION_template_haskell(2,22,0) 129 | TypeDataD _ _ _ _ -> [] 130 | DefaultD _ -> [] 131 | #endif 132 | 133 | {- }}} -} 134 | 135 | datatypeNames :: Cxt -> [Con] -> [Name] 136 | datatypeNames cxt cons = (conNames =<< cons) ++ (predNames =<< cxt) 137 | 138 | #if MIN_VERSION_template_haskell(2,12,0) 139 | derivNames :: [DerivClause] -> [Name] 140 | derivNames derivs = predNames =<< 141 | [ p | DerivClause _strat cxt <- derivs, p <- cxt ] 142 | #endif 143 | 144 | tseNames :: TySynEqn -> [Name] 145 | #if MIN_VERSION_template_haskell(2,15,0) 146 | tseNames (TySynEqn _ l r) = typNames l ++ typNames r 147 | #elif MIN_VERSION_template_haskell(2,9,0) 148 | tseNames (TySynEqn ts t) = (typNames =<< ts) ++ typNames t 149 | #endif 150 | 151 | predNames :: Pred -> [Name]{- {{{ -} 152 | #if MIN_VERSION_template_haskell(2,10,0) 153 | predNames = typNames 154 | #else 155 | predNames p = case p of 156 | ClassP n ts -> n : (typNames =<< ts) 157 | EqualP s t -> typNames s ++ typNames t 158 | #endif 159 | {- }}} -} 160 | 161 | typNames :: Type -> [Name]{- {{{ -} 162 | typNames typ = case typ of 163 | ForallT _ c t -> (predNames =<< c) ++ typNames t 164 | AppT s t -> typNames s ++ typNames t 165 | SigT t _ -> typNames t 166 | VarT _ -> [] 167 | ConT name -> [name] 168 | TupleT _ -> [] 169 | UnboxedTupleT _ -> [] 170 | ArrowT -> [] 171 | ListT -> [] 172 | 173 | #if MIN_VERSION_template_haskell(2,8,0) 174 | PromotedT _ -> [] 175 | PromotedTupleT _ -> [] 176 | PromotedNilT -> [] 177 | PromotedConsT -> [] 178 | StarT -> [] 179 | ConstraintT -> [] 180 | LitT _ -> [] 181 | #endif 182 | 183 | #if MIN_VERSION_template_haskell(2,10,0) 184 | EqualityT -> [] 185 | #endif 186 | 187 | #if MIN_VERSION_template_haskell(2,11,0) 188 | InfixT s n t -> n : typNames s ++ typNames t 189 | UInfixT s n t -> n : typNames s ++ typNames t 190 | ParensT t -> typNames t 191 | WildCardT -> [] 192 | #endif 193 | 194 | #if MIN_VERSION_template_haskell(2,12,0) 195 | UnboxedSumT _arity -> [] 196 | #endif 197 | 198 | #if MIN_VERSION_template_haskell(2,15,0) 199 | AppKindT k t -> typNames k ++ typNames t 200 | ImplicitParamT _ t -> typNames t 201 | #endif 202 | 203 | #if MIN_VERSION_template_haskell(2,16,0) 204 | ForallVisT _ t -> typNames t 205 | #endif 206 | 207 | #if MIN_VERSION_template_haskell(2,17,0) 208 | MulArrowT -> [] 209 | #endif 210 | 211 | #if MIN_VERSION_template_haskell(2,19,0) 212 | PromotedInfixT s n t -> n : typNames s ++ typNames t 213 | PromotedUInfixT s n t -> n : typNames s ++ typNames t 214 | #endif 215 | {- }}} -} 216 | 217 | infoNames :: Info -> [Name]{- {{{ -} 218 | infoNames info = case info of 219 | ClassI dec _ -> decNames dec 220 | TyConI dec -> decNames dec 221 | FamilyI _ decs -> decNames =<< decs 222 | PrimTyConI _ _ _ -> [] 223 | TyVarI _ typ -> typNames typ 224 | 225 | #if MIN_VERSION_template_haskell(2,11,0) 226 | ClassOpI _ typ _ -> typNames typ 227 | DataConI _ typ parent -> parent : typNames typ 228 | VarI _ typ _ -> typNames typ 229 | #else 230 | ClassOpI _ typ _ _ -> typNames typ 231 | DataConI _ typ parent _ -> parent : typNames typ 232 | VarI _ typ _ _ -> typNames typ 233 | #endif 234 | 235 | #if MIN_VERSION_template_haskell(2,12,0) 236 | PatSynI _name typ -> typNames typ 237 | #endif 238 | {- }}} -} 239 | 240 | {- {{{ -} 241 | -- | Summons a 'Name' using @template-haskell@'s 'reify' function. 242 | -- 243 | -- The first argument is a 'String' matching the 'Name' we want: either its 244 | -- 'nameBase', or qualified with its module. The second argument gives the 245 | -- 'Name' to 'reify'. 246 | -- 247 | -- If no match is found or there is some ambiguity, 'summon' will fail with 248 | -- a list of 'Name's found, along with the output of 'reify' for reference. 249 | -- 250 | -- Suppose we are given a module @M@ that exports a function @s@, but not 251 | -- the type @T@, the constrcutor @C@, nor the field @f@: 252 | -- 253 | -- > module M (s) where 254 | -- > newtype T = C { f :: Int } 255 | -- > s :: T -> T 256 | -- > s = C . succ . f 257 | -- 258 | -- In our own module we have no legitimate way of passing @s@ an argument of 259 | -- type @T@. We can get around this in a type-safe way with 'summon': 260 | -- 261 | -- >{-# LANGUAGE TemplateHaskell #-} 262 | -- >module Main where 263 | -- >import Language.Haskell.TH.Syntax 264 | -- >import Unsafe.TrueName 265 | -- >import M 266 | -- > 267 | -- >type T = $(fmap ConT $ summon "T" 's) 268 | -- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int 269 | -- >mkC = $(fmap ConE $ summon "C" =<< summon "T" 's) 270 | -- >unC $(fmap (`ConP` [VarP $ mkName "n"]) $ summon "C" =<< summon "T" 's) = n 271 | -- >f = $(fmap VarE $ summon "f" =<< summon "T" 's) 272 | -- > 273 | -- >main :: IO () 274 | -- >main = print (unC t, n) where 275 | -- > t = s (mkC 42 :: T) 276 | -- > n = f (s t) 277 | -- 278 | -- Note that 'summon' cannot obtain the 'Name' for an unexported function, 279 | -- since GHC . 280 | -- The only workaround is to copypasta the definition. D: 281 | {- }}} -} 282 | summon :: String -> Name -> Q Name{- {{{ -} 283 | summon name thing = do 284 | info <- reify thing 285 | let ns = nub (infoNames info) 286 | case filter (\ n -> name == nameBase n || name == show n) ns of 287 | [n] -> return n 288 | _ -> fail $ "summon: you wanted " ++ show name ++ ", but I have:\n" 289 | ++ unlines ((++) " " . namespace <$> ns) 290 | ++ " reify " ++ show thing ++ " returned:\n" 291 | ++ show (nest 8 $ ppr info) 292 | where 293 | namespace n@(Name _ flavour) = show n ++ case flavour of 294 | NameG VarName _ _ -> " (var)" 295 | NameG DataName _ _ -> " (cons)" 296 | NameG TcClsName _ _ -> " (type)" 297 | _ -> " (?)" 298 | {- }}} -} 299 | 300 | {- {{{ -} 301 | -- | A more convenient 'QuasiQuoter' interface to 'summon'. 302 | -- 303 | -- The first space-delimited token gives the initial 'Name' passed to 304 | -- 'summon': it must be ‘quoted’ with a @'@ or @''@ prefix to indicate 305 | -- whether it should be interpreted in an expression or a type context, 306 | -- as per . 307 | -- Subsequent tokens correspond to the 'String' argument of 'summon', and 308 | -- are iterated over. Thus 309 | -- 310 | -- > [truename| ''A B C D |] 311 | -- 312 | -- is roughly equivalent to: 313 | -- 314 | -- > summon "D" =<< summon "C" =<< summon "B" ''A 315 | -- 316 | -- but with the resulting 'Name' wrapped up in 'ConE', 'VarE', 'ConP', or 317 | -- 'ConT', depending on the context. (There is no 'quoteDec'.) 318 | -- 319 | -- Variable bindings are given after a @|@ token in a 'Pat' context: 320 | -- 321 | -- > [truename| ''Chan Chan | chanR chanW |] <- newChan 322 | -- 323 | -- These may be prefixed with @!@ or @~@ to give the usual semantics. 324 | -- A single @..@ token invokes @RecordWildCards@ in 'Pat' contexts, and for 325 | -- record construction in 'Exp' contexts. 326 | -- Nested or more exotic patterns are not supported. 327 | -- 328 | -- With this, the example from 'summon' may be more succinctly written: 329 | -- 330 | -- >{-# LANGUAGE QuasiQuotes #-} 331 | -- >module Main where 332 | -- >import Unsafe.TrueName 333 | -- >import M 334 | -- > 335 | -- >type T = [truename| 's T |] 336 | -- >mkC :: Int -> T; unC :: T -> Int; f :: T -> Int 337 | -- >mkC = [truename| 's T C |] 338 | -- >unC [truename| 's T C | n |] = n 339 | -- >f = [truename| 's T f |] 340 | -- > 341 | -- >main :: IO () 342 | -- >main = print (unC t, n) where 343 | -- > t = s (mkC 42 :: T) 344 | -- > n = f (s t) 345 | {- }}} -} 346 | truename :: QuasiQuoter{- {{{ -} 347 | truename = QuasiQuoter 348 | { quoteExp = makeE <=< nameVars 349 | , quotePat = makeP <=< nameVars 350 | , quoteType = makeT <=< nameVars 351 | , quoteDec = \ _ -> err "I'm not sure how this would work" 352 | } where 353 | err = fail . (++) "truename: " 354 | noPat = err . (++) "unexpected pattern variables: " . unwords 355 | 356 | makeT (name, vars) = ConT name <$ unless (null vars) (noPat vars) 357 | makeE (name@(Name occ flavour), vars) = case flavour of 358 | NameG VarName _ _ -> VarE name <$ unless (null vars) (noPat vars) 359 | NameG DataName _ _ -> case vars of 360 | [] -> return (ConE name) 361 | [".."] -> RecConE name . capture VarE <$> recFields name 362 | _ -> noPat vars 363 | _ -> err $ occString occ ++ " has a strange flavour" 364 | makeP (name, vars) = if vars == [".."] 365 | then RecP name . capture VarP <$> recFields name 366 | else 367 | #if MIN_VERSION_template_haskell(2,18,0) 368 | return $ ConP name [] (map pat vars) where 369 | #else 370 | return $ ConP name (map pat vars) where 371 | #endif 372 | pat n = case n of 373 | "_" -> WildP 374 | '!' : ns -> BangP (pat ns) 375 | '~' : ns -> TildeP (pat ns) 376 | _ -> VarP (mkName n) 377 | capture v = map $ \ f -> (f, v (mkName $ nameBase f)) 378 | 379 | recFields :: Name -> Q [Name] 380 | recFields name = do 381 | parent <- reify name >>= \ info -> case info of 382 | #if MIN_VERSION_template_haskell(2,11,0) 383 | DataConI _ _ p -> return p 384 | #else 385 | DataConI _ _ p _ -> return p 386 | #endif 387 | _ -> err $ show name ++ " is not a data constructor" 388 | dec <- reify parent >>= \ info -> case info of 389 | TyConI d -> return d 390 | _ -> err $ "parent " ++ show parent ++ " is not a plain type" 391 | case dec of 392 | #if MIN_VERSION_template_haskell(2,11,0) 393 | DataD _ _ _ _ cs _ -> return (fields =<< cs) 394 | NewtypeD _ _ _ _ c _ -> return (fields c) 395 | #else 396 | DataD _ _ _ cs _ -> return (fields =<< cs) 397 | NewtypeD _ _ _ c _ -> return (fields c) 398 | #endif 399 | _ -> err $ "parent " ++ show parent ++ " neither data nor newtype" 400 | where 401 | fields :: Con -> [Name] 402 | fields con = case con of 403 | NormalC _ _ -> [] 404 | RecC n vbts -> if n /= name then [] else [ v | (v, _, _) <- vbts ] 405 | InfixC _ _ _ -> [] 406 | ForallC _ _ c -> fields c 407 | #if MIN_VERSION_template_haskell(2,11,0) 408 | GadtC _ _ _ -> [] 409 | RecGadtC ns vbts _ -> if name `notElem` ns then [] 410 | else [ v | (v, _, _) <- vbts ] 411 | #endif 412 | 413 | lookupThing :: String -> Q Name 414 | lookupThing s0 = case s0 of 415 | '\'' : s1 -> case s1 of 416 | '\'' : s2 -> hmm s2 "lookupTypeName" =<< lookupTypeName s2 417 | _ -> hmm s1 "lookupValueName" =<< lookupValueName s1 418 | _ -> err $ "please specify either '" ++ s0 ++ " or ''" ++ s0 419 | where 420 | hmm s l = maybe (err $ unwords [l, show s, "failed"]) return 421 | 422 | nameVars :: String -> Q (Name, [String]) 423 | nameVars spec = case words spec of 424 | [] -> err "expecting at least one token" 425 | start : rest -> do 426 | thing <- lookupThing start 427 | let (names, vars) = break ("|" ==) rest 428 | name <- foldM (flip summon) thing names 429 | return (name, dropWhile ("|" ==) vars) 430 | {- }}} -} 431 | -------------------------------------------------------------------------------- /src/Data/Thyme/Clock/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} -- workaround 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | #if __GLASGOW_HASKELL__ >= 708 8 | {-# LANGUAGE PatternSynonyms #-} 9 | #endif 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE ViewPatterns #-} 15 | {-# OPTIONS_HADDOCK hide #-} 16 | 17 | #include "thyme.h" 18 | 19 | module Data.Thyme.Clock.Internal where 20 | 21 | import Prelude 22 | import Control.DeepSeq 23 | import Control.Lens 24 | import Data.AdditiveGroup 25 | import Data.AffineSpace 26 | import Data.Basis 27 | import Data.Data 28 | import Data.Hashable 29 | import Data.Int 30 | import Data.Ix 31 | import Data.Thyme.Internal.Micro 32 | import Data.Thyme.Calendar.Internal 33 | #if __GLASGOW_HASKELL__ == 704 34 | import qualified Data.Vector.Generic 35 | import qualified Data.Vector.Generic.Mutable 36 | #endif 37 | import Data.Vector.Unboxed.Deriving 38 | import Data.VectorSpace 39 | import GHC.Generics (Generic) 40 | import System.Random 41 | import Test.QuickCheck 42 | 43 | #if !SHOW_INTERNAL 44 | import Control.Monad 45 | import Text.ParserCombinators.ReadPrec (lift) 46 | import Text.ParserCombinators.ReadP (char) 47 | import Text.Read (readPrec) 48 | #endif 49 | 50 | -- | Hour time-of-day. 51 | type Hour = Int 52 | -- | Minute time-of-day. 53 | type Minute = Int 54 | 55 | -- | Time intervals, encompassing both 'DiffTime' and 'NominalDiffTime'. 56 | -- 57 | -- ==== Notes 58 | -- 59 | -- Still affected by ? 60 | class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where 61 | -- | Conversion between 'TimeDiff' and 'Int64' microseconds. 62 | -- 63 | -- @ 64 | -- > ('fromSeconds'' 3 :: 'DiffTime') '^.' 'microseconds' 65 | -- 3000000 66 | -- 67 | -- > 'microseconds' 'Control.Lens.#' 4000000 :: 'DiffTime' 68 | -- 4s 69 | -- @ 70 | microseconds :: Iso' t Int64 71 | 72 | -- | Convert a time interval to some 'Fractional' type. 73 | {-# INLINE toSeconds #-} 74 | toSeconds :: (TimeDiff t, Fractional n) => t -> n 75 | toSeconds = (* recip 1000000) . fromIntegral . view microseconds 76 | 77 | -- | Make a time interval from some 'Real' type. 78 | -- 79 | -- Try to make sure @n@ is one of 'Float', 'Double', 'Int', 'Int64' or 80 | -- 'Integer', for which rewrite @RULES@ have been provided. 81 | {-# INLINE[0] fromSeconds #-} 82 | fromSeconds :: (Real n, TimeDiff t) => n -> t 83 | fromSeconds = fromSeconds' . toRational 84 | 85 | -- | Type-restricted 'toSeconds' to avoid constraint-defaulting warnings. 86 | {-# INLINE toSeconds' #-} 87 | toSeconds' :: (TimeDiff t) => t -> Rational 88 | toSeconds' = (`decompose'` ()) 89 | 90 | -- | Type-restricted 'fromSeconds' to avoid constraint-defaulting warnings. 91 | {-# INLINE fromSeconds' #-} 92 | fromSeconds' :: (TimeDiff t) => Rational -> t 93 | fromSeconds' = (*^ basisValue ()) 94 | 95 | ------------------------------------------------------------------------ 96 | -- not for public consumption 97 | 98 | {-# INLINE fromSecondsRealFrac #-} 99 | fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t 100 | fromSecondsRealFrac _ = review microseconds . round . (*) 1000000 101 | 102 | {-# INLINE fromSecondsIntegral #-} 103 | fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t 104 | fromSecondsIntegral _ = review microseconds . (*) 1000000 . fromIntegral 105 | 106 | {-# RULES 107 | 108 | "fromSeconds/Float" [~0] fromSeconds = fromSecondsRealFrac (0 :: Float) 109 | "fromSeconds/Double" [~0] fromSeconds = fromSecondsRealFrac (0 :: Double) 110 | "fromSeconds/Int" [~0] fromSeconds = fromSecondsIntegral (0 :: Int) 111 | "fromSeconds/Int64" [~0] fromSeconds = fromSecondsIntegral (0 :: Int64) 112 | "fromSeconds/Integer" [~0] fromSeconds = fromSecondsIntegral (0 :: Integer) 113 | 114 | #-} 115 | 116 | ------------------------------------------------------------------------ 117 | 118 | -- | An interval or duration of time, as would be measured by a stopwatch. 119 | -- 120 | -- 'DiffTime' is an instance of 'AdditiveGroup' as well as 'VectorSpace', 121 | -- with 'Rational' as its 'Scalar'. 122 | -- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances 123 | -- here. See "Data.Thyme.Docs#spaces" for details. 124 | -- 125 | -- @ 126 | -- > 'fromSeconds'' 100 :: 'DiffTime' 127 | -- 100s 128 | -- > 'fromSeconds'' 100 '^+^' 'fromSeconds'' 100 '^*' 4 129 | -- 500s 130 | -- > 'fromSeconds'' 100 '^-^' 'fromSeconds'' 100 '^/' 4 131 | -- 75s 132 | -- @ 133 | newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) 134 | 135 | derivingUnbox "DiffTime" [t| DiffTime -> Micro |] 136 | [| \ (DiffTime a) -> a |] [| DiffTime |] 137 | 138 | #if SHOW_INTERNAL 139 | deriving instance Show DiffTime 140 | deriving instance Read DiffTime 141 | #else 142 | instance Show DiffTime where 143 | {-# INLINEABLE showsPrec #-} 144 | showsPrec p (DiffTime a) = showsPrec p a . (:) 's' 145 | instance Read DiffTime where 146 | {-# INLINEABLE readPrec #-} 147 | readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's') 148 | #endif 149 | 150 | instance VectorSpace DiffTime where 151 | type Scalar DiffTime = Rational 152 | {-# INLINE (*^) #-} 153 | (*^) = \ s (DiffTime t) -> DiffTime (s *^ t) 154 | 155 | instance HasBasis DiffTime where 156 | type Basis DiffTime = () 157 | {-# INLINE basisValue #-} 158 | basisValue = \ _ -> DiffTime (basisValue ()) 159 | {-# INLINE decompose #-} 160 | decompose = \ (DiffTime a) -> decompose a 161 | {-# INLINE decompose' #-} 162 | decompose' = \ (DiffTime a) -> decompose' a 163 | 164 | instance TimeDiff DiffTime where 165 | {-# INLINE microseconds #-} 166 | microseconds = iso (\ (DiffTime (Micro u)) -> u) (DiffTime . Micro) 167 | 168 | ------------------------------------------------------------------------ 169 | 170 | -- | The nominal interval between two 'UTCTime's, which does not take leap 171 | -- seconds into account. 172 | -- 173 | -- For example, the difference between /23:59:59/ and /00:00:01/ on the 174 | -- following day is always 2 seconds of 'NominalDiffTime', regardless of 175 | -- whether a leap-second took place. 176 | -- 177 | -- 'NominalDiffTime' is an instance of 'AdditiveGroup' as well as 178 | -- 'VectorSpace', with 'Rational' as its 'Scalar'. 179 | -- We do not provide 'Num', 'Real', 'Fractional' nor 'RealFrac' instances 180 | -- here. See "Data.Thyme.Docs#spaces" for details. 181 | -- 182 | -- @ 183 | -- > let d = 'fromSeconds'' 2 :: 'NominalDiffTime' 184 | -- > d 185 | -- 2s 186 | -- > d '^/' 3 187 | -- 0.666667s 188 | -- @ 189 | -- 190 | -- See also: 'UTCTime'. 191 | newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) 192 | 193 | derivingUnbox "NominalDiffTime" [t| NominalDiffTime -> Micro |] 194 | [| \ (NominalDiffTime a) -> a |] [| NominalDiffTime |] 195 | 196 | #if SHOW_INTERNAL 197 | deriving instance Show NominalDiffTime 198 | deriving instance Read NominalDiffTime 199 | #else 200 | instance Show NominalDiffTime where 201 | {-# INLINEABLE showsPrec #-} 202 | showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest) 203 | instance Read NominalDiffTime where 204 | {-# INLINEABLE readPrec #-} 205 | readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's') 206 | #endif 207 | 208 | instance VectorSpace NominalDiffTime where 209 | type Scalar NominalDiffTime = Rational 210 | {-# INLINE (*^) #-} 211 | (*^) = \ s (NominalDiffTime t) -> NominalDiffTime (s *^ t) 212 | 213 | instance HasBasis NominalDiffTime where 214 | type Basis NominalDiffTime = () 215 | {-# INLINE basisValue #-} 216 | basisValue = \ _ -> NominalDiffTime (basisValue ()) 217 | {-# INLINE decompose #-} 218 | decompose = \ (NominalDiffTime a) -> decompose a 219 | {-# INLINE decompose' #-} 220 | decompose' = \ (NominalDiffTime a) -> decompose' a 221 | 222 | instance TimeDiff NominalDiffTime where 223 | {-# INLINE microseconds #-} 224 | microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro) 225 | 226 | -- | The nominal length of a POSIX day: /86400 SI seconds/. 227 | {-# INLINE posixDayLength #-} 228 | posixDayLength :: NominalDiffTime 229 | posixDayLength = microseconds # 86400000000 230 | 231 | ------------------------------------------------------------------------ 232 | 233 | -- | The principal form of universal time, namely 234 | -- . 235 | -- 236 | -- UT1 is defined by the rotation of the Earth around its axis relative to 237 | -- the Sun. The length of each UT1 day varies and is never exactly 86400 SI 238 | -- seconds, unlike UTC or TAI. 239 | -- 240 | -- The difference between UT1 and UTC is 241 | -- . 242 | newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO) 243 | 244 | derivingUnbox "UniversalTime" [t| UniversalTime -> NominalDiffTime |] 245 | [| \ (UniversalRep a) -> a |] [| UniversalRep |] 246 | 247 | -- | Convert between 'UniversalTime' and the fractional number of days since the 248 | -- . 249 | {-# INLINE modJulianDate #-} 250 | modJulianDate :: Iso' UniversalTime Rational 251 | modJulianDate = iso 252 | (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength) 253 | (UniversalRep . (*^ posixDayLength)) 254 | 255 | #if __GLASGOW_HASKELL__ >= 710 256 | pattern UniversalTime :: Rational -> UniversalTime 257 | pattern UniversalTime mjd <- (view modJulianDate -> mjd) where 258 | UniversalTime mjd = modJulianDate # mjd 259 | #elif __GLASGOW_HASKELL__ >= 708 260 | pattern UniversalTime mjd <- (view modJulianDate -> mjd) 261 | #endif 262 | 263 | ------------------------------------------------------------------------ 264 | 265 | -- | 266 | -- ('UTCTime') is the most commonly used standard for civil timekeeping. It 267 | -- is synchronised with 268 | -- 269 | -- ('Data.Thyme.Clock.AbsoluteTime') and both tick in increments of SI 270 | -- seconds, but UTC includes occasional leap-seconds to keep it close to 271 | -- 272 | -- ('UniversalTime'). 273 | -- 274 | -- @ 275 | -- > '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) 276 | -- 2016-01-15 12:34:56.78 UTC 277 | -- 278 | -- > 'UTCTime' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 1 15) ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' 12 34 56.78) 279 | -- 2016-01-15 12:34:56.78 UTC 280 | -- 281 | -- > 'mkUTCTime' 2016 1 15 12 34 56.78 282 | -- 2016-01-15 12:34:56.78 UTC 283 | -- @ 284 | -- 285 | -- 'UTCTime' is an 'AffineSpace' with 'NominalDiffTime' as its 'Diff'. See 286 | -- "Data.Thyme.Docs#spaces" for details. 287 | -- 288 | -- @ 289 | -- > let t0 = 'mkUTCTime' 2016 1 15 23 59 0 290 | -- > let t1 = 'mkUTCTime' 2016 1 16 00 1 1 291 | -- > let dt = t1 '.-.' t0 292 | -- > dt 293 | -- 121s :: 'NominalDiffTime' 294 | -- 295 | -- > t1 '.+^' dt 296 | -- 2016-01-16 00:03:02 UTC 297 | -- 298 | -- > t1 '.+^' 3 '*^' dt 299 | -- 2016-01-16 00:07:04 UTC 300 | -- @ 301 | -- 302 | -- To decompose a 'UTCTime' into a separate 'Day' and time-of-day, use 303 | -- 'utcTime'. To convert to a local time zone, see 304 | -- 'Data.Thyme.LocalTime.zonedTime' or 'Data.Thyme.LocalTime.utcLocalTime'. 305 | -- 306 | -- ==== Notes 307 | -- 308 | -- Internally 'UTCTime' is just a 64-bit count of 'microseconds' since the 309 | -- Modified Julian Day epoch, so @('.+^')@, @('.-.')@ et cetera ought to be 310 | -- fast. 311 | -- 312 | -- 'UTCTime' . 313 | -- If leap seconds matter, use 'Data.Thyme.Clock.TAI.AbsoluteTime' from 314 | -- "Data.Thyme.Clock.TAI" instead, along with 315 | -- 'Data.Thyme.Clock.TAI.absoluteTime'' and 'UTCView' for presentation. 316 | newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO) 317 | 318 | derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |] 319 | [| \ (UTCRep a) -> a |] [| UTCRep |] 320 | 321 | -- | Unpacked 'UTCTime', partly for compatibility with @time@. 322 | -- 323 | -- As of GHC 7.10, you can also use the 'UTCTime' pattern synonym. 324 | data UTCView = UTCView 325 | { utcvDay :: {-# UNPACK #-}!Day 326 | -- ^ Calendar date. 327 | , utcvDayTime :: {-# UNPACK #-}!DiffTime 328 | -- ^ Time elapsed since midnight; /0/ ≤ 'utcvDayTime' < /86401s/. 329 | } deriving (INSTANCES_USUAL, Show) 330 | 331 | -- | 'Lens'' for the calendar 'Day' component of a 'UTCView'. 332 | LENS(UTCView,utcvDay,Day) 333 | 334 | -- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCView'. 335 | LENS(UTCView,utcvDayTime,DiffTime) 336 | 337 | derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |] 338 | [| \ UTCView {..} -> (utcvDay, utcvDayTime) |] 339 | [| \ (utcvDay, utcvDayTime) -> UTCView {..} |] 340 | 341 | instance Hashable UTCView 342 | instance NFData UTCView 343 | 344 | -- | 'Lens'' for the calendar 'Day' component of a 'UTCTime'. 345 | _utctDay :: Lens' UTCTime Day 346 | _utctDay = utcTime . lens utcvDay 347 | (\ UTCView {..} d -> UTCView d utcvDayTime) 348 | 349 | -- | 'Lens'' for the time-of-day 'DiffTime' component of a 'UTCTime'. 350 | _utctDayTime :: Lens' UTCTime DiffTime 351 | _utctDayTime = utcTime . lens utcvDayTime 352 | (\ UTCView {..} t -> UTCView utcvDay t) 353 | 354 | -- | Accessor for the calendar 'Day' component of an 'UTCTime'. 355 | -- 356 | -- @ 357 | -- 'utctDay' = 'view' '_utctDay' 358 | -- @ 359 | utctDay :: UTCTime -> Day 360 | utctDay = view _utctDay 361 | 362 | -- | Accessor for the time-of-day 'DiffTime' component of an 'UTCTime'. 363 | -- 364 | -- @ 365 | -- 'utctDayTime' = 'view' '_utctDayTime' 366 | -- @ 367 | utctDayTime :: UTCTime -> DiffTime 368 | utctDayTime = view _utctDayTime 369 | 370 | instance AffineSpace UTCTime where 371 | type Diff UTCTime = NominalDiffTime 372 | {-# INLINE (.-.) #-} 373 | (.-.) = \ (UTCRep a) (UTCRep b) -> a ^-^ b 374 | {-# INLINE (.+^) #-} 375 | (.+^) = \ (UTCRep a) d -> UTCRep (a ^+^ d) 376 | 377 | -- | View 'UTCTime' as an 'UTCView', comprising a 'Day' along with 378 | -- a 'DiffTime' offset since midnight. 379 | -- 380 | -- This is an improper lens: 'utcvDayTime' outside the range of 381 | -- @['zeroV', 'posixDayLength')@ will carry over into 'utcvDay', with the 382 | -- expected behaviour. 383 | -- 384 | -- @ 385 | -- > 'view' 'utcTime' '<$>' 'Data.Thyme.Clock.getCurrentTime' 386 | -- 'UTCView' {'utcvDay' = 2016-01-15, 'utcvDayTime' = 49322.287688s} 387 | -- 388 | -- > '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) 389 | -- 2016-01-15 12:34:56.78 UTC 390 | -- @ 391 | -- 392 | -- With @{-# LANGUAGE ViewPatterns #-}@, you can write: e.g. 393 | -- 394 | -- @ 395 | -- f :: 'UTCTime' -> ('Day', 'DiffTime') 396 | -- f ('view' 'utcTime' -> 'UTCView' day dt) = (day, dt) 397 | -- @ 398 | {-# INLINE utcTime #-} 399 | utcTime :: Iso' UTCTime UTCView 400 | utcTime = iso toView fromView where 401 | NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength 402 | 403 | {-# INLINE toView #-} 404 | toView :: UTCTime -> UTCView 405 | toView (UTCRep (NominalDiffTime a)) = UTCView 406 | (ModifiedJulianDay mjd) (DiffTime dt) where 407 | (fromIntegral -> mjd, dt) = microDivMod a posixDay 408 | 409 | {-# INLINE fromView #-} 410 | fromView :: UTCView -> UTCTime 411 | fromView (UTCView (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where 412 | a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt) 413 | 414 | #if __GLASGOW_HASKELL__ >= 710 415 | pattern UTCTime :: Day -> DiffTime -> UTCTime 416 | pattern UTCTime d t <- (view utcTime -> UTCView d t) where 417 | UTCTime d t = utcTime # UTCView d t 418 | #elif __GLASGOW_HASKELL__ >= 708 419 | pattern UTCTime d t <- (view utcTime -> UTCView d t) 420 | #endif 421 | 422 | -- | Construct a 'UTCTime' from a 'gregorian' date and time-of-day. 423 | -- 424 | -- @ 425 | -- 'mkUTCTime' yy mm dd h m s ≡ 'utcTime' 'Control.Lens.#' 'UTCView' 426 | -- ('gregorian' 'Control.Lens.#' 'YearMonthDay' yy mm dd) 427 | -- ('Data.Thyme.LocalTime.timeOfDay' 'Control.Lens.#' 'Data.Thyme.LocalTime.TimeOfDay' h m ('fromSeconds' s)) 428 | -- @ 429 | {-# INLINE mkUTCTime #-} 430 | mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime 431 | mkUTCTime yy mm dd h m s = utcTime # UTCView 432 | (gregorian # YearMonthDay yy mm dd) 433 | (fromSeconds (3600 * h + 60 * m) ^+^ fromSeconds s) 434 | 435 | -------------------------------------------------------------------------------- /src/Data/Thyme/LocalTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | #include "thyme.h" 14 | #if HLINT 15 | #include "cabal_macros.h" 16 | #endif 17 | 18 | -- | Local time and time zones. 19 | module Data.Thyme.LocalTime 20 | ( Hour, Minute 21 | , module Data.Thyme.LocalTime 22 | ) where 23 | 24 | import Prelude hiding ((.)) 25 | #if !MIN_VERSION_base(4,8,0) 26 | import Control.Applicative 27 | #endif 28 | import Control.Arrow 29 | import Control.Category hiding (id) 30 | import Control.DeepSeq 31 | import Control.Lens 32 | import Control.Monad 33 | import Data.AffineSpace 34 | import Data.Bits 35 | import Data.Data 36 | import Data.Hashable 37 | import Data.Int 38 | import Data.Thyme.Internal.Micro 39 | import Data.Thyme.Calendar 40 | import Data.Thyme.Calendar.Internal 41 | import Data.Thyme.Clock 42 | import Data.Thyme.Clock.Internal 43 | import Data.Thyme.Format.Internal 44 | import qualified Data.Time as T 45 | #if __GLASGOW_HASKELL__ == 704 46 | import qualified Data.Vector.Generic 47 | import qualified Data.Vector.Generic.Mutable 48 | #endif 49 | import Data.Vector.Unboxed.Deriving 50 | import Data.VectorSpace 51 | import GHC.Generics (Generic) 52 | import System.Random 53 | import Test.QuickCheck hiding ((.&.)) 54 | 55 | -- | Hours duration. 56 | type Hours = Int 57 | -- | Minutes duration. 58 | type Minutes = Int 59 | 60 | ------------------------------------------------------------------------ 61 | -- * Time Zones 62 | 63 | -- | Description of one time zone. 64 | -- 65 | -- A 'TimeZone' is a whole number of minutes offset from UTC, together with 66 | -- a name and a ‘summer time’ flag. 67 | data TimeZone = TimeZone 68 | { timeZoneMinutes :: {-# UNPACK #-}!Minutes 69 | -- ^ The number of minutes offset from UTC. 70 | , timeZoneSummerOnly :: !Bool 71 | -- ^ Is this a summer-only (i.e. daylight savings) time zone? 72 | , timeZoneName :: String 73 | -- ^ The name of the zone, typically a three- or four-letter acronym. 74 | } deriving (INSTANCES_USUAL) 75 | 76 | LENS(TimeZone,timeZoneMinutes,Minutes) 77 | LENS(TimeZone,timeZoneSummerOnly,Bool) 78 | LENS(TimeZone,timeZoneName,String) 79 | 80 | instance Hashable TimeZone 81 | instance NFData TimeZone 82 | 83 | #if SHOW_INTERNAL 84 | deriving instance Show TimeZone 85 | #else 86 | instance Show TimeZone where 87 | show tz@TimeZone {..} = if null timeZoneName 88 | then timeZoneOffsetString tz else timeZoneName 89 | #endif 90 | 91 | instance Bounded TimeZone where 92 | minBound = TimeZone (-12 * 60) minBound "AAAA" 93 | maxBound = TimeZone (13 * 60) maxBound "ZZZZ" 94 | 95 | instance Random TimeZone where 96 | randomR (l, u) g0 = (TimeZone minutes summer name, g3) where 97 | (minutes, g1) = randomR (timeZoneMinutes l, timeZoneMinutes u) g0 98 | (summer, g2) = randomR (timeZoneSummerOnly l, timeZoneSummerOnly u) g1 99 | -- slightly dubious interpretation of ‘range’ 100 | (name, g3) = foldr randChar ([], g2) . take 4 $ zip 101 | (timeZoneName l ++ "AAAA") (timeZoneName u ++ "ZZZZ") 102 | randChar nR (ns, g) = (: ns) `first` randomR nR g 103 | random = randomR (minBound, maxBound) 104 | 105 | instance Arbitrary TimeZone where 106 | arbitrary = choose (minBound, maxBound) 107 | shrink tz@TimeZone {..} 108 | = [ tz {timeZoneSummerOnly = s} | s <- shrink timeZoneSummerOnly ] 109 | ++ [ tz {timeZoneMinutes = m} | m <- shrink timeZoneMinutes ] 110 | ++ [ tz {timeZoneName = n} | n <- shrink timeZoneName ] 111 | 112 | instance CoArbitrary TimeZone where 113 | coarbitrary (TimeZone m s n) 114 | = coarbitrary m . coarbitrary s . coarbitrary n 115 | 116 | -- | Text representing the offset of this timezone, e.g. \"-0800\" or 117 | -- \"+0400\" (like @%z@ in 'Data.Thyme.Format.formatTime') 118 | {-# INLINEABLE timeZoneOffsetString #-} 119 | timeZoneOffsetString :: TimeZone -> String 120 | timeZoneOffsetString TimeZone {..} = sign : (shows02 h . shows02 m) "" where 121 | (h, m) = divMod offset 60 122 | (sign, offset) = if timeZoneMinutes < 0 123 | then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes) 124 | 125 | -- | Text representing the offset of this timezone in ISO 8601 style, 126 | -- e.g. \"-08:00\" or 127 | -- \"+04:00\" (like @%N@ in 'Data.Thyme.Format.formatTime') 128 | {-# INLINEABLE timeZoneOffsetStringColon #-} 129 | timeZoneOffsetStringColon :: TimeZone -> String 130 | timeZoneOffsetStringColon TimeZone {..} = 131 | sign : (shows02 h . (:) ':' . shows02 m) "" where 132 | (h, m) = divMod offset 60 133 | (sign, offset) = if timeZoneMinutes < 0 134 | then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes) 135 | 136 | -- | Create a nameless non-summer timezone for this number of minutes 137 | minutesToTimeZone :: Minutes -> TimeZone 138 | minutesToTimeZone m = TimeZone m False "" 139 | 140 | -- | Create a nameless non-summer timezone for this number of hours 141 | hoursToTimeZone :: Hours -> TimeZone 142 | hoursToTimeZone i = minutesToTimeZone (60 * i) 143 | 144 | -- | The UTC (Zulu) time zone. 145 | -- 146 | -- @ 147 | -- 'utc' = 'TimeZone' 0 'False' \"UTC\" 148 | -- @ 149 | utc :: TimeZone 150 | utc = TimeZone 0 False "UTC" 151 | 152 | -- | Get the local time zone at the given time, varying as per summer time 153 | -- adjustments. 154 | -- 155 | -- Performed by 156 | -- 157 | -- or a similar call. 158 | {-# INLINEABLE getTimeZone #-} 159 | getTimeZone :: UTCTime -> IO TimeZone 160 | getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where 161 | day = T.ModifiedJulianDay (toInteger mjd) 162 | UTCView (ModifiedJulianDay mjd) dt = t ^. utcTime 163 | thyme T.TimeZone {..} = TimeZone {..} 164 | 165 | -- | Get the current local time zone. 166 | -- 167 | -- @ 168 | -- 'getCurrentTimeZone' = 'getCurrentTime' >>= 'getTimeZone' 169 | -- @ 170 | -- 171 | -- @ 172 | -- > 'getCurrentTimeZone' 173 | -- JST 174 | -- @ 175 | {-# INLINE getCurrentTimeZone #-} 176 | getCurrentTimeZone :: IO TimeZone 177 | getCurrentTimeZone = getCurrentTime >>= getTimeZone 178 | 179 | ------------------------------------------------------------------------ 180 | -- * Time of Day 181 | 182 | -- | Time of day in hour, minute, second. 183 | data TimeOfDay = TimeOfDay 184 | { todHour :: {-# UNPACK #-}!Hour 185 | , todMin :: {-# UNPACK #-}!Minute 186 | , todSec :: {-# UNPACK #-}!DiffTime -- ^ Second. 187 | } deriving (INSTANCES_USUAL) 188 | 189 | LENS(TimeOfDay,todHour,Hour) 190 | LENS(TimeOfDay,todMin,Minute) 191 | LENS(TimeOfDay,todSec,DiffTime) 192 | 193 | derivingUnbox "TimeOfDay" [t| TimeOfDay -> Int64 |] 194 | [| \ TimeOfDay {..} -> fromIntegral (todHour .|. shiftL todMin 8) 195 | .|. shiftL (todSec ^. microseconds) 16 |] 196 | [| \ n -> TimeOfDay (fromIntegral $ n .&. 0xff) 197 | (fromIntegral $ shiftR n 8 .&. 0xff) (microseconds # shiftR n 16) |] 198 | 199 | instance Hashable TimeOfDay 200 | instance NFData TimeOfDay 201 | 202 | #if SHOW_INTERNAL 203 | deriving instance Show TimeOfDay 204 | #else 205 | instance Show TimeOfDay where 206 | showsPrec _ (TimeOfDay h m (DiffTime s)) 207 | = shows02 h . (:) ':' . shows02 m . (:) ':' 208 | . shows02 (fromIntegral si) . frac where 209 | (si, Micro su) = microQuotRem s (Micro 1000000) 210 | frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su 211 | #endif 212 | 213 | instance Bounded TimeOfDay where 214 | minBound = TimeOfDay 0 0 zeroV 215 | maxBound = TimeOfDay 23 59 (microseconds # 60999999) 216 | 217 | instance Random TimeOfDay where 218 | randomR = randomIsoR timeOfDay 219 | random = first (^. timeOfDay) . random 220 | 221 | instance Arbitrary TimeOfDay where 222 | arbitrary = do 223 | h <- choose (0, 23) 224 | m <- choose (0, 59) 225 | let DiffTime ml = minuteLength h m 226 | TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml) 227 | shrink tod = view timeOfDay . (^+^) noon 228 | <$> shrink (timeOfDay # tod ^-^ noon) where 229 | noon = timeOfDay # midday -- shrink towards midday 230 | 231 | instance CoArbitrary TimeOfDay where 232 | coarbitrary (TimeOfDay h m s) 233 | = coarbitrary h . coarbitrary m . coarbitrary s 234 | 235 | -- | The maximum possible length of a minute. Always /60s/, except at 236 | -- /23:59/ due to leap seconds. 237 | -- 238 | -- @ 239 | -- 'minuteLength' 23 59 = 'fromSeconds'' 61 240 | -- 'minuteLength' _ _ = 'fromSeconds'' 60 241 | -- @ 242 | {-# INLINE minuteLength #-} 243 | minuteLength :: Hour -> Minute -> DiffTime 244 | minuteLength 23 59 = fromSeconds' 61 245 | minuteLength _ _ = fromSeconds' 60 246 | 247 | -- | Hour zero, midnight. 248 | -- 249 | -- @ 250 | -- 'midnight' = 'TimeOfDay' 0 0 'zeroV' 251 | -- @ 252 | midnight :: TimeOfDay 253 | midnight = TimeOfDay 0 0 zeroV 254 | 255 | -- | Hour twelve, noon. 256 | -- 257 | -- @ 258 | -- 'midday' = 'TimeOfDay' 12 0 'zeroV' 259 | -- @ 260 | midday :: TimeOfDay 261 | midday = TimeOfDay 12 0 zeroV 262 | 263 | -- | Construct a 'TimeOfDay' from the hour, minute, and second. 264 | -- 265 | -- Returns 'Nothing' if these constraints are not satisfied: 266 | -- 267 | -- * /0 ≤ @hour@ ≤ 23/ 268 | -- * /0 ≤ @minute@ ≤ 59/ 269 | -- * /0 ≤ @second@ < 'minuteLength' @hour@ @minute@/ 270 | {-# INLINE makeTimeOfDayValid #-} 271 | makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay 272 | makeTimeOfDayValid h m s = TimeOfDay h m s 273 | <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59) 274 | <* guard (zeroV <= s && s < minuteLength h m) 275 | 276 | -- | Conversion between 'DiffTime' and 'TimeOfDay'. 277 | -- 278 | -- @ 279 | -- > 'fromSeconds'' 100 '^.' 'timeOfDay' 280 | -- 00:01:40 281 | -- 282 | -- > 'timeOfDay' 'Control.Lens.#' 'TimeOfDay' 0 1 40 283 | -- 100s 284 | -- @ 285 | {-# INLINE timeOfDay #-} 286 | timeOfDay :: Iso' DiffTime TimeOfDay 287 | timeOfDay = iso fromDiff toDiff where 288 | 289 | {-# INLINEABLE fromDiff #-} 290 | fromDiff :: DiffTime -> TimeOfDay 291 | fromDiff (DiffTime t) = TimeOfDay 292 | (fromIntegral h) (fromIntegral m) (DiffTime s) where 293 | (h, ms) = microQuotRem t (Micro 3600000000) 294 | (m, s) = microQuotRem ms (Micro 60000000) 295 | 296 | {-# INLINEABLE toDiff #-} 297 | toDiff :: TimeOfDay -> DiffTime 298 | toDiff (TimeOfDay h m s) = s 299 | ^+^ fromIntegral m *^ DiffTime (Micro 60000000) 300 | ^+^ fromIntegral h *^ DiffTime (Micro 3600000000) 301 | 302 | -- | Add some minutes to a 'TimeOfDay'; the result includes a day adjustment. 303 | -- 304 | -- @ 305 | -- > 'addMinutes' 10 ('TimeOfDay' 23 55 0) 306 | -- (1,00:05:00) 307 | -- @ 308 | {-# INLINE addMinutes #-} 309 | addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay) 310 | addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where 311 | (dd, h') = divMod (h + dh) 24 312 | (dh, m') = divMod (m + dm) 60 313 | 314 | -- | Conversion between 'TimeOfDay' and the fraction of a day. 315 | -- 316 | -- @ 317 | -- > 'TimeOfDay' 6 0 0 '^.' 'dayFraction' 318 | -- 1 % 4 319 | -- > 'TimeOfDay' 8 0 0 '^.' 'dayFraction' 320 | -- 1 % 3 321 | -- 322 | -- > 'dayFraction' 'Control.Lens.#' (1 / 4) 323 | -- 06:00:00 324 | -- > 'dayFraction' 'Control.Lens.#' (1 / 3) 325 | -- 08:00:00 326 | -- @ 327 | {-# INLINE dayFraction #-} 328 | dayFraction :: Iso' TimeOfDay Rational 329 | dayFraction = from timeOfDay . iso toRatio fromRatio where 330 | 331 | {-# INLINEABLE toRatio #-} 332 | toRatio :: DiffTime -> Rational 333 | toRatio t = toSeconds t / toSeconds posixDayLength 334 | 335 | {-# INLINEABLE fromRatio #-} 336 | fromRatio :: Rational -> DiffTime 337 | fromRatio ((*^ posixDayLength) -> NominalDiffTime r) = DiffTime r 338 | 339 | ------------------------------------------------------------------------ 340 | -- * Local Time 341 | 342 | -- | Local calendar date and time-of-day. 343 | -- 344 | -- This type is appropriate for inputting from and outputting to the 345 | -- outside world. 346 | -- 347 | -- To actually perform logic and arithmetic on local date-times, a 'LocalTime' 348 | -- should first be converted to a 'UTCTime' by the 'utcLocalTime' Iso. 349 | -- 350 | -- See also: 'ZonedTime'. 351 | data LocalTime = LocalTime 352 | { localDay :: {-# UNPACK #-}!Day 353 | -- ^ Local calendar date. 354 | , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay 355 | -- ^ Local time-of-day. 356 | } deriving (INSTANCES_USUAL) 357 | 358 | LENS(LocalTime,localDay,Day) 359 | LENS(LocalTime,localTimeOfDay,TimeOfDay) 360 | 361 | derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |] 362 | [| \ LocalTime {..} -> (localDay, localTimeOfDay) |] 363 | [| \ (localDay, localTimeOfDay) -> LocalTime {..} |] 364 | 365 | instance Hashable LocalTime 366 | instance NFData LocalTime 367 | 368 | #if SHOW_INTERNAL 369 | deriving instance Show LocalTime 370 | #else 371 | instance Show LocalTime where 372 | showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t 373 | #endif 374 | 375 | instance Bounded LocalTime where 376 | minBound = minBound ^. utcLocalTime maxBound 377 | maxBound = maxBound ^. utcLocalTime minBound 378 | 379 | instance Random LocalTime where 380 | randomR = randomIsoR (utcLocalTime utc) 381 | random = randomR (minBound, maxBound) 382 | 383 | instance Arbitrary LocalTime where 384 | arbitrary = choose (minBound, maxBound) 385 | shrink lt@LocalTime {..} 386 | = [ lt {localDay = d} | d <- shrink localDay ] 387 | ++ [ lt {localTimeOfDay = d} | d <- shrink localTimeOfDay ] 388 | 389 | instance CoArbitrary LocalTime where 390 | coarbitrary (LocalTime d t) = coarbitrary d . coarbitrary t 391 | 392 | -- | Conversion between 'UTCTime' and 'LocalTime'. 393 | -- 394 | -- @ 395 | -- > tz <- 'getCurrentTimeZone' 396 | -- 397 | -- > 'timeZoneName' tz 398 | -- \"JST\" 399 | -- 400 | -- > 'timeZoneOffsetString' tz 401 | -- \"+0900\" 402 | -- 403 | -- > now <- 'getCurrentTime' 404 | -- > now 405 | -- 2016-04-23 02:00:00.000000 UTC 406 | -- 407 | -- > let local = now '^.' 'utcLocalTime' tz 408 | -- > local 409 | -- 2016-04-23 11:00:00.000000 410 | -- 411 | -- > 'utcLocalTime' tz 'Control.Lens.#' local 412 | -- 2016-04-23 02:00:00.000000 UTC 413 | -- @ 414 | -- 415 | -- See also: 'zonedTime'. 416 | {-# INLINE utcLocalTime #-} 417 | utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime 418 | utcLocalTime TimeZone {..} = utcTime . iso localise globalise where 419 | 420 | {-# INLINEABLE localise #-} 421 | localise :: UTCView -> LocalTime 422 | localise (UTCView day dt) = LocalTime (day .+^ dd) tod where 423 | (dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay) 424 | 425 | {-# INLINEABLE globalise #-} 426 | globalise :: LocalTime -> UTCView 427 | globalise (LocalTime day tod) = UTCView (day .+^ dd) 428 | (timeOfDay # utcToD) where 429 | (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod 430 | 431 | -- | Conversion between 'UniversalTime' and 'LocalTime'. 432 | {-# INLINE ut1LocalTime #-} 433 | ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime 434 | ut1LocalTime long = iso localise globalise where 435 | NominalDiffTime posixDay@(Micro usDay) = posixDayLength 436 | 437 | {-# INLINEABLE localise #-} 438 | localise :: UniversalTime -> LocalTime 439 | localise (UniversalRep (NominalDiffTime t)) = LocalTime 440 | (ModifiedJulianDay $ fromIntegral day) 441 | (DiffTime dt ^. timeOfDay) where 442 | (day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay 443 | 444 | {-# INLINEABLE globalise #-} 445 | globalise :: LocalTime -> UniversalTime 446 | globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $ 447 | Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where 448 | ModifiedJulianDay (fromIntegral -> mjd) = day 449 | DiffTime dt = timeOfDay # tod 450 | 451 | ------------------------------------------------------------------------ 452 | -- * Zoned Time 453 | 454 | -- | A 'LocalTime' and its 'TimeZone'. 455 | -- 456 | -- This type is appropriate for inputting from and outputting to the 457 | -- outside world. 458 | -- 459 | -- To actually perform logic and arithmetic on local date-times, a 'ZonedTime' 460 | -- should first be converted to a 'UTCTime' by the 'zonedTime' Iso. 461 | data ZonedTime = ZonedTime 462 | { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime 463 | , zonedTimeZone :: !TimeZone 464 | } deriving (INSTANCES_USUAL) 465 | 466 | LENS(ZonedTime,zonedTimeToLocalTime,LocalTime) 467 | LENS(ZonedTime,zonedTimeZone,TimeZone) 468 | 469 | instance Hashable ZonedTime 470 | instance NFData ZonedTime where 471 | rnf ZonedTime {..} = rnf zonedTimeZone 472 | 473 | instance Bounded ZonedTime where 474 | minBound = ZonedTime minBound maxBound 475 | maxBound = ZonedTime maxBound minBound 476 | 477 | instance Random ZonedTime where 478 | randomR (l, u) g0 = (view zonedTime . (,) tz) 479 | `first` randomR (l', u') g1 where 480 | (tz, g1) = random g0 -- ignore TimeZone from l and u 481 | l' = snd $ zonedTime # l 482 | u' = snd $ zonedTime # u 483 | random = randomR (minBound, maxBound) 484 | 485 | instance Arbitrary ZonedTime where 486 | arbitrary = choose (minBound, maxBound) 487 | shrink zt@ZonedTime {..} 488 | = [ zt {zonedTimeToLocalTime = lt} | lt <- shrink zonedTimeToLocalTime ] 489 | ++ [ zt {zonedTimeZone = tz} | tz <- shrink zonedTimeZone ] 490 | 491 | instance CoArbitrary ZonedTime where 492 | coarbitrary (ZonedTime lt tz) = coarbitrary lt . coarbitrary tz 493 | 494 | -- | Conversion between ('TimeZone', 'UTCTime') and 'ZonedTime'. 495 | -- 496 | -- @ 497 | -- > now <- 'getZonedTime' 498 | -- > now 499 | -- 2016-04-04 16:00:00.000000 JST 500 | -- 501 | -- > 'zonedTime' 'Control.Lens.#' now 502 | -- (JST,2016-04-04 07:00:00.000000 UTC) 503 | -- 504 | -- > ('zonedTime' 'Control.Lens.#' now) '^.' 'zonedTime' 505 | -- 2016-04-04 16:00:00.000000 JST 506 | -- @ 507 | -- 508 | -- See also: 'utcLocalTime'. 509 | {-# INLINE zonedTime #-} 510 | zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime 511 | zonedTime = iso toZoned fromZoned where 512 | 513 | {-# INLINE toZoned #-} 514 | toZoned :: (TimeZone, UTCTime) -> ZonedTime 515 | toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz 516 | 517 | {-# INLINE fromZoned #-} 518 | fromZoned :: ZonedTime -> (TimeZone, UTCTime) 519 | fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt) 520 | 521 | #if SHOW_INTERNAL 522 | deriving instance Show ZonedTime 523 | instance Show UTCTime where 524 | showsPrec p = showsPrec p . view utcTime 525 | #else 526 | instance Show ZonedTime where 527 | showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz 528 | instance Show UTCTime where 529 | showsPrec p = showsPrec p . view zonedTime . (,) utc 530 | #endif 531 | 532 | -- | Get the current local date, time, and time zone. 533 | -- 534 | -- @ 535 | -- > 'getZonedTime' 536 | -- 2016-04-23 11:57:22.516064 JST 537 | -- @ 538 | -- 539 | -- See also: 'getCurrentTime', 'Data.Thyme.Clock.POSIX.getPOSIXTime'. 540 | {-# INLINE getZonedTime #-} 541 | getZonedTime :: IO ZonedTime 542 | getZonedTime = utcToLocalZonedTime =<< getCurrentTime 543 | 544 | -- | Convert a 'UTCTime' to a 'ZonedTime' according to the local time zone 545 | -- returned by 'getTimeZone'. 546 | -- 547 | -- See also: 'zonedTime'. 548 | {-# INLINEABLE utcToLocalZonedTime #-} 549 | utcToLocalZonedTime :: UTCTime -> IO ZonedTime 550 | utcToLocalZonedTime time = do 551 | tz <- getTimeZone time 552 | return $ (tz, time) ^. zonedTime 553 | 554 | -- * Compatibility 555 | 556 | -- | Convert a UTC 'TimeOfDay' to a 'TimeOfDay' in some timezone, together 557 | -- with a day adjustment. 558 | -- 559 | -- @ 560 | -- 'utcToLocalTimeOfDay' = 'addMinutes' '.' 'timeZoneMinutes' 561 | -- @ 562 | {-# INLINE utcToLocalTimeOfDay #-} 563 | utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) 564 | utcToLocalTimeOfDay = addMinutes . timeZoneMinutes 565 | 566 | -- | Convert a 'TimeOfDay' in some timezone to a UTC 'TimeOfDay', together 567 | -- with a day adjustment. 568 | -- 569 | -- @ 570 | -- 'localToUTCTimeOfDay' = 'addMinutes' '.' 'negate' '.' 'timeZoneMinutes' 571 | -- @ 572 | {-# INLINE localToUTCTimeOfDay #-} 573 | localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) 574 | localToUTCTimeOfDay = addMinutes . negate . timeZoneMinutes 575 | 576 | -- | Convert a 'DiffTime' of the duration since midnight to a 'TimeOfDay'. 577 | -- Durations exceeding 24 hours will be treated as leap-seconds. 578 | -- 579 | -- @ 580 | -- 'timeToTimeOfDay' = 'view' 'timeOfDay' 581 | -- 'timeToTimeOfDay' d ≡ d '^.' 'timeOfDay' 582 | -- @ 583 | {-# INLINE timeToTimeOfDay #-} 584 | timeToTimeOfDay :: DiffTime -> TimeOfDay 585 | timeToTimeOfDay = view timeOfDay 586 | 587 | -- | Convert a 'TimeOfDay' to a 'DiffTime' of the duration since midnight. 588 | -- 'TimeOfDay' greater than 24 hours will be treated as leap-seconds. 589 | -- 590 | -- @ 591 | -- 'timeOfDayToTime' = 'review' 'timeOfDay' 592 | -- 'timeOfDayToTime' tod ≡ 'timeOfDay' 'Control.Lens.#' tod 593 | -- @ 594 | {-# INLINE timeOfDayToTime #-} 595 | timeOfDayToTime :: TimeOfDay -> DiffTime 596 | timeOfDayToTime = review timeOfDay 597 | 598 | -- | Convert a fraction of a day since midnight to a 'TimeOfDay'. 599 | -- 600 | -- @ 601 | -- 'dayFractionToTimeOfDay' = 'review' 'dayFraction' 602 | -- @ 603 | {-# INLINE dayFractionToTimeOfDay #-} 604 | dayFractionToTimeOfDay :: Rational -> TimeOfDay 605 | dayFractionToTimeOfDay = review dayFraction 606 | 607 | -- | Convert a 'TimeOfDay' to a fraction of a day since midnight. 608 | -- 609 | -- @ 610 | -- 'timeOfDayToDayFraction' = 'view' 'dayFraction' 611 | -- @ 612 | {-# INLINE timeOfDayToDayFraction #-} 613 | timeOfDayToDayFraction :: TimeOfDay -> Rational 614 | timeOfDayToDayFraction = view dayFraction 615 | 616 | -- | Convert a 'UTCTime' to a 'LocalTime' in the given 'TimeZone'. 617 | -- 618 | -- @ 619 | -- 'utcToLocalTime' = 'view' '.' 'utcLocalTime' 620 | -- @ 621 | {-# INLINE utcToLocalTime #-} 622 | utcToLocalTime :: TimeZone -> UTCTime -> LocalTime 623 | utcToLocalTime tz = view (utcLocalTime tz) 624 | 625 | -- | Convert a 'LocalTime' in the given 'TimeZone' to a 'UTCTime'. 626 | -- 627 | -- @ 628 | -- 'localTimeToUTC' = 'review' '.' 'utcLocalTime' 629 | -- @ 630 | {-# INLINE localTimeToUTC #-} 631 | localTimeToUTC :: TimeZone -> LocalTime -> UTCTime 632 | localTimeToUTC tz = review (utcLocalTime tz) 633 | 634 | -- | Convert a 'UniversalTime' to a 'LocalTime' at the given medidian in 635 | -- degrees East. 636 | -- 637 | -- @ 638 | -- 'ut1ToLocalTime' = 'view' '.' 'ut1LocalTime' 639 | -- @ 640 | {-# INLINE ut1ToLocalTime #-} 641 | ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime 642 | ut1ToLocalTime l = view (ut1LocalTime l) 643 | 644 | -- | Convert a 'LocalTime' at the given meridian in degrees East to 645 | -- a 'UniversalTime'. 646 | -- 647 | -- @ 648 | -- 'localTimeToUT1' = 'review' '.' 'ut1LocalTime' 649 | -- @ 650 | {-# INLINE localTimeToUT1 #-} 651 | localTimeToUT1 :: Rational -> LocalTime -> UniversalTime 652 | localTimeToUT1 l = review (ut1LocalTime l) 653 | 654 | -- | Convert a 'UTCTime' and the given 'TimeZone' into a 'ZonedTime'. 655 | -- 656 | -- @ 657 | -- 'utcToZonedTime' z t = 'view' 'zonedTime' (z, t) 658 | -- @ 659 | {-# INLINE utcToZonedTime #-} 660 | utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime 661 | utcToZonedTime z t = view zonedTime (z, t) 662 | 663 | -- | Converts a 'ZonedTime' to a 'UTCTime'. 664 | -- 665 | -- @ 666 | -- 'zonedTimeToUTC' = 'snd' '.' 'review' 'zonedTime' 667 | -- @ 668 | {-# INLINE zonedTimeToUTC #-} 669 | zonedTimeToUTC :: ZonedTime -> UTCTime 670 | zonedTimeToUTC = snd . review zonedTime 671 | 672 | -------------------------------------------------------------------------------- /src/Data/Thyme/Calendar/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | #if SHOW_INTERNAL 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | #endif 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | {-# OPTIONS_HADDOCK hide #-} 15 | 16 | #include "thyme.h" 17 | #if HLINT 18 | #include "cabal_macros.h" 19 | #endif 20 | 21 | module Data.Thyme.Calendar.Internal where 22 | 23 | import Prelude 24 | #if !MIN_VERSION_base(4,8,0) 25 | import Control.Applicative 26 | #endif 27 | import Control.Arrow 28 | import Control.DeepSeq 29 | import Control.Lens 30 | import Control.Monad 31 | import Data.AffineSpace 32 | import Data.Bits 33 | import Data.Data 34 | import Data.Hashable 35 | import Data.Int 36 | import Data.Ix 37 | import Data.Thyme.Format.Internal 38 | #if __GLASGOW_HASKELL__ == 704 39 | import qualified Data.Vector.Generic 40 | import qualified Data.Vector.Generic.Mutable 41 | #endif 42 | import qualified Data.Vector.Unboxed as VU 43 | import Data.Vector.Unboxed.Deriving 44 | import GHC.Generics (Generic) 45 | import System.Random 46 | import Test.QuickCheck hiding ((.&.)) 47 | 48 | -- | A duration/count of years. 49 | type Years = Int 50 | 51 | -- | A duration/count of months. 52 | type Months = Int 53 | 54 | -- | A duration/count of days. 55 | type Days = Int 56 | 57 | -- | A calendar-agnostic day, internally represented as a count of days 58 | -- since /1858-11-17/, the 59 | -- 60 | -- (MJD) epoch. 61 | -- 62 | -- To convert a 'Day' to the corresponding 'YearMonthDay' in the W_GREGORIAN 63 | -- calendar, see 'gregorian'. 64 | -- 65 | -- @ 66 | -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 67 | -- 2016-03-01 68 | -- @ 69 | -- 70 | -- 'Day' is an instance of 'AffineSpace' where @'Diff' 'Day' = 'Days'@, so 71 | -- arithmetic on 'Day' and 'Days' can be performed with the '.-.', '.+^', 72 | -- and '.-^' operators. 73 | -- 74 | -- @ 75 | -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-.' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 2 1 76 | -- 29 77 | -- @ 78 | -- 79 | -- @ 80 | -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-^' 1 81 | -- 2016-02-29 82 | -- @ 83 | -- 84 | -- Other ways of viewing a 'Day' include 'ordinalDate', and 'weekDate'. 85 | newtype Day = ModifiedJulianDay 86 | { toModifiedJulianDay :: Int 87 | } deriving (INSTANCES_NEWTYPE, CoArbitrary) 88 | 89 | instance AffineSpace Day where 90 | type Diff Day = Days 91 | {-# INLINE (.-.) #-} 92 | (.-.) = \ (ModifiedJulianDay a) (ModifiedJulianDay b) -> a - b 93 | {-# INLINE (.+^) #-} 94 | (.+^) = \ (ModifiedJulianDay a) d -> ModifiedJulianDay (a + d) 95 | 96 | -- | Convert between a 'Day' and the corresponding count of days from 97 | -- 1858-11-17, the MJD epoch. 98 | -- 99 | -- @ 100 | -- 'modifiedJulianDay' = 'iso' 'toModifiedJulianDay' 'ModifiedJulianDay' 101 | -- @ 102 | -- 103 | -- @ 104 | -- > 'modifiedJulianDay' 'Control.Lens.#' 0 105 | -- 1858-11-17 106 | -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '&' 'modifiedJulianDay' '%~' 'subtract' 1 107 | -- 2016-02-29 108 | -- @ 109 | {-# INLINE modifiedJulianDay #-} 110 | modifiedJulianDay :: Iso' Day Int 111 | modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay 112 | 113 | -- | Conversion between a W_GREGORIAN 'OrdinalDate' and the corresponding 114 | -- 'YearMonthDay'. 115 | -- 116 | -- @ 117 | -- > 'OrdinalDate' 2016 32 '^.' 'yearMonthDay' 118 | -- 'YearMonthDay' {ymdYear = 2016, ymdMonth = 2, ymdDay = 1} 119 | -- @ 120 | -- 121 | -- @ 122 | -- > 'yearMonthDay' 'Control.Lens.#' 'YearMonthDay' 2016 2 1 123 | -- 'OrdinalDate' {odYear = 2016, odDay = 32} 124 | -- @ 125 | {-# INLINE yearMonthDay #-} 126 | yearMonthDay :: Iso' OrdinalDate YearMonthDay 127 | yearMonthDay = iso fromOrdinal toOrdinal where 128 | 129 | {-# INLINEABLE fromOrdinal #-} 130 | fromOrdinal :: OrdinalDate -> YearMonthDay 131 | fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where 132 | MonthDay m d = yd ^. monthDay (isLeapYear y) 133 | 134 | {-# INLINEABLE toOrdinal #-} 135 | toOrdinal :: YearMonthDay -> OrdinalDate 136 | toOrdinal (YearMonthDay y m d) = OrdinalDate y $ 137 | monthDay (isLeapYear y) # MonthDay m d 138 | 139 | -- | Conversion between a 'Day' and its 'YearMonthDay'. 140 | -- 141 | -- @ 142 | -- 'gregorian' = 'ordinalDate' . 'yearMonthDay' 143 | -- @ 144 | -- 145 | -- @ 146 | -- > 'ModifiedJulianDay' 0 '^.' 'gregorian' 147 | -- 'YearMonthDay' {ymdYear = 1858, ymdMonth = 11, ymdDay = 17} 148 | -- @ 149 | -- 150 | -- @ 151 | -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 1858 11 17 152 | -- 1858-11-17 153 | -- @ 154 | {-# INLINE gregorian #-} 155 | gregorian :: Iso' Day YearMonthDay 156 | gregorian = ordinalDate . yearMonthDay 157 | 158 | -- | Conversion between a 'YearMonthDay' and the corresponding 'Day'. 159 | -- Returns 'Nothing' for invalid input. 160 | -- 161 | -- @ 162 | -- > 'gregorianValid' ('YearMonthDay' 2015 2 28) 163 | -- 'Just' 2015-02-28 164 | -- @ 165 | -- 166 | -- @ 167 | -- > 'gregorianValid' ('YearMonthDay' 2015 2 29) 168 | -- 'Nothing' 169 | -- @ 170 | {-# INLINEABLE gregorianValid #-} 171 | gregorianValid :: YearMonthDay -> Maybe Day 172 | gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y 173 | <$> monthDayValid (isLeapYear y) (MonthDay m d) 174 | 175 | -- | Shows a 'Day' in 176 | -- 177 | -- /YYYY-MM-DD/ format. 178 | -- 179 | -- See "Data.Thyme.Format" for other possibilities. 180 | {-# INLINEABLE showGregorian #-} 181 | showGregorian :: Day -> String 182 | showGregorian (view gregorian -> YearMonthDay y m d) = 183 | showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ "" 184 | 185 | #if SHOW_INTERNAL 186 | deriving instance Show Day 187 | #else 188 | instance Show Day where show = showGregorian 189 | #endif 190 | 191 | ------------------------------------------------------------------------ 192 | 193 | -- | Calendar year. 194 | type Year = Int 195 | 196 | -- | Calendar month. /January = 1/ 197 | type Month = Int 198 | 199 | -- | Calendar day-of-month, starting from /1/. 200 | type DayOfMonth = Int 201 | 202 | -- | A strict triple of a 'Year', a 'Day', and a 'Month'. 203 | data YearMonthDay = YearMonthDay 204 | { ymdYear :: {-# UNPACK #-}!Year 205 | , ymdMonth :: {-# UNPACK #-}!Month 206 | , ymdDay :: {-# UNPACK #-}!DayOfMonth 207 | } deriving (INSTANCES_USUAL, Show) 208 | 209 | LENS(YearMonthDay,ymdYear,Year) 210 | LENS(YearMonthDay,ymdMonth,Month) 211 | LENS(YearMonthDay,ymdDay,DayOfMonth) 212 | 213 | instance Hashable YearMonthDay 214 | instance NFData YearMonthDay 215 | 216 | ------------------------------------------------------------------------ 217 | 218 | -- | Is it a leap year according to the W_GREGORIAN calendar? 219 | isLeapYear :: Year -> Bool 220 | isLeapYear y = y .&. 3 == 0 && (r100 /= 0 || q100 .&. 3 == 0) where 221 | (q100, r100) = y `quotRem` 100 222 | 223 | -- | The day of the year, with /1 = January 1st/. 224 | type DayOfYear = Int 225 | 226 | -- | An 227 | -- . 228 | data OrdinalDate = OrdinalDate 229 | { odYear :: {-# UNPACK #-}!Year 230 | , odDay :: {-# UNPACK #-}!DayOfYear 231 | } deriving (INSTANCES_USUAL, Show) 232 | 233 | LENS(OrdinalDate,odYear,Year) 234 | LENS(OrdinalDate,odDay,DayOfYear) 235 | 236 | instance Hashable OrdinalDate 237 | instance NFData OrdinalDate 238 | 239 | -- | Conversion between the MJD 'Day' and 'OrdinalDate'. 240 | -- 241 | -- @ 242 | -- > 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32 243 | -- 2016-02-01 244 | -- @ 245 | -- 246 | -- @ 247 | -- > 'toModifiedJulianDay' $ 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32 248 | -- 57419 249 | -- @ 250 | -- 251 | -- @ 252 | -- > 'ModifiedJulianDay' 57419 '^.' 'ordinalDate' 253 | -- 'OrdinalDate' {odYear = 2016, odDay = 32} 254 | -- @ 255 | {-# INLINE ordinalDate #-} 256 | ordinalDate :: Iso' Day OrdinalDate 257 | ordinalDate = iso toOrd fromOrd where 258 | 259 | -- Brief description of the toOrd computation 260 | -- 261 | -- The length of the years in the Gregorian calendar is periodic with period 262 | -- of /400/ years. There are /100 - 4 + 1 = 97/ leap years in a period, so 263 | -- the average length of a year is /365 + 97\/400 = 146097\/400/ days. 264 | -- 265 | -- Now, if you consider these — let's call them nominal — years, 266 | -- then for any point in time, for any linear day number we can 267 | -- determine which nominal year does it fall into by a single 268 | -- division. Moreover, if we align the start of the calendar year /1/ 269 | -- with the start of the nominal year /1/, then the calendar years and 270 | -- nominal years never get too much out of sync. Specifically: 271 | -- 272 | -- * The start of the first day of a calendar year might fall into the 273 | -- preceding nominal year, but never more than by /1.5/ days (/591\/400/ 274 | -- days, to be precise). 275 | -- 276 | -- * The start of the last day of a calendar year always falls into 277 | -- its nominal year (even for the leap years). 278 | -- 279 | -- So, to find out the calendar year for a given day, we calculate 280 | -- on which nominal year does its start fall. And, if we are not too 281 | -- close to the end of year, we have the right calendar 282 | -- year. Othewise, we just check whether it falls within the next 283 | -- calendar year. 284 | -- 285 | -- Notes: to make the reasoning simpler and more efficient ('quot' is 286 | -- faster than 'div') we do the computation directly only for positive 287 | -- years (days after /0001-01-01/). For earlier dates we translate by an 288 | -- integral number of /400/ year periods, do the computation and 289 | -- translate back. 290 | 291 | {-# INLINEABLE toOrd #-} 292 | toOrd :: Day -> OrdinalDate 293 | toOrd (ModifiedJulianDay mjd) 294 | | dayB0 <= 0 = case toOrdB0 dayInQC of 295 | OrdinalDate y yd -> OrdinalDate (y + quadCent * 400) yd 296 | | otherwise = toOrdB0 dayB0 297 | where 298 | dayB0 = mjd + 678575 299 | (quadCent, dayInQC) = dayB0 `divMod` 146097 300 | 301 | -- Input: days since 0001-01-01. Precondition: has to be positive! 302 | {-# INLINE toOrdB0 #-} 303 | toOrdB0 :: Int -> OrdinalDate 304 | toOrdB0 dayB0 = res 305 | where 306 | (y0, r) = (400 * dayB0) `quotRem` 146097 307 | d0 = dayInYear y0 dayB0 308 | d1 = dayInYear (y0 + 1) dayB0 309 | res = if r > 146097 - 600 && d1 > 0 310 | then OrdinalDate (y0 + 1 + 1) d1 311 | else OrdinalDate (y0 + 1) d0 312 | 313 | -- Input: (year - 1) (day as days since 0001-01-01) 314 | -- Precondition: year is positive! 315 | {-# INLINE dayInYear #-} 316 | dayInYear :: Int -> Int -> Int 317 | dayInYear y0 dayB0 = dayB0 - 365 * y0 - leaps + 1 318 | where 319 | leaps = y0 `shiftR` 2 - centuries + centuries `shiftR` 2 320 | centuries = y0 `quot` 100 321 | 322 | {-# INLINEABLE fromOrd #-} 323 | fromOrd :: OrdinalDate -> Day 324 | fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where 325 | years = year - 1 326 | centuries = years `div` 100 327 | leaps = years `shiftR` 2 - centuries + centuries `shiftR` 2 328 | mjd = 365 * years + leaps - 678576 329 | + clip 1 (if isLeapYear year then 366 else 365) yd 330 | clip a b = max a . min b 331 | 332 | ------------------------------------------------------------------------ 333 | -- Lookup tables for Data.Thyme.Calendar.MonthDay 334 | 335 | {-# NOINLINE monthLengths #-} 336 | {-# NOINLINE monthLengthsLeap #-} 337 | monthLengths, monthLengthsLeap :: VU.Vector Days 338 | monthLengths = VU.fromList [31,28,31,30,31,30,31,31,30,31,30,31] 339 | monthLengthsLeap = VU.fromList [31,29,31,30,31,30,31,31,30,31,30,31] 340 | -- J F M A M J J A S O N D 341 | 342 | {-# ANN monthDays "HLint: ignore Use fromMaybe" #-} 343 | {-# NOINLINE monthDays #-} 344 | monthDays :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8) 345 | monthDays = VU.generate 365 go where 346 | dom01 = VU.prescanl' (+) 0 monthLengths 347 | go yd = (fromIntegral m, fromIntegral d) where 348 | m = maybe 12 id $ VU.findIndex (yd <) dom01 349 | d = succ yd - VU.unsafeIndex dom01 (pred m) 350 | 351 | {-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-} 352 | {-# NOINLINE monthDaysLeap #-} 353 | monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8) 354 | monthDaysLeap = VU.generate 366 go where 355 | dom01 = VU.prescanl' (+) 0 monthLengthsLeap 356 | go yd = (fromIntegral m, fromIntegral d) where 357 | m = maybe 12 id $ VU.findIndex (yd <) dom01 358 | d = succ yd - VU.unsafeIndex dom01 (pred m) 359 | 360 | -- | No good home for this within the current hierarchy. This will do. 361 | {-# INLINEABLE randomIsoR #-} 362 | randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g) 363 | randomIsoR l (x, y) = first (^. l) . randomR (l # x, l # y) 364 | 365 | ------------------------------------------------------------------------ 366 | 367 | -- | A strict pair of a 'Month' and a 'DayOfMonth'. 368 | data MonthDay = MonthDay 369 | { mdMonth :: {-# UNPACK #-}!Month 370 | , mdDay :: {-# UNPACK #-}!DayOfMonth 371 | } deriving (INSTANCES_USUAL, Show) 372 | 373 | LENS(MonthDay,mdMonth,Month) 374 | LENS(MonthDay,mdDay,DayOfMonth) 375 | 376 | instance Hashable MonthDay 377 | instance NFData MonthDay 378 | 379 | instance Bounded MonthDay where 380 | minBound = MonthDay 1 1 381 | maxBound = MonthDay 12 31 382 | 383 | instance Random MonthDay where 384 | randomR r g = randomIsoR (monthDay leap) r g' where 385 | (isLeapYear -> leap, g') = random g 386 | random = randomR (minBound, maxBound) 387 | 388 | instance Arbitrary MonthDay where 389 | arbitrary = choose (minBound, maxBound) 390 | shrink md = view (monthDay True) <$> shrink (monthDay True # md) 391 | 392 | instance CoArbitrary MonthDay where 393 | coarbitrary (MonthDay m d) = coarbitrary m . coarbitrary d 394 | 395 | -- | Predicated on whether or not it's a leap year, convert between an 396 | -- ordinal 'DayOfYear' and the corresponding 'Month' and 'DayOfMonth'. 397 | -- 398 | -- @ 399 | -- > 60 '^.' 'monthDay' ('isLeapYear' 2015) 400 | -- 'MonthDay' {'mdMonth' = 3, 'mdDay' = 1} 401 | -- @ 402 | -- 403 | -- @ 404 | -- > 60 '^.' 'monthDay' ('isLeapYear' 2016) 405 | -- 'MonthDay' {'mdMonth' = 2, 'mdDay' = 29} 406 | -- @ 407 | -- 408 | -- @ 409 | -- > 'monthDay' ('isLeapYear' 2016) 'Control.Lens.#' 'MonthDay' 2 29 410 | -- 60 411 | -- @ 412 | -- 413 | -- @ 414 | -- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 28 415 | -- 59 416 | -- @ 417 | -- 418 | -- Note that 'monthDay' is an improper 'Iso', as the following example 419 | -- shows. To handle this case correctly, use 'monthDayValid'. 420 | -- 421 | -- @ 422 | -- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 29 423 | -- 59 424 | -- @ 425 | {-# INLINE monthDay #-} 426 | monthDay 427 | :: Bool -- ^ 'isLeapYear'? 428 | -> Iso' DayOfYear MonthDay 429 | monthDay leap = iso fromOrdinal toOrdinal where 430 | (lastDay, lengths, table, ok) = if leap 431 | then (365, monthLengthsLeap, monthDaysLeap, -1) 432 | else (364, monthLengths, monthDays, -2) 433 | 434 | {-# INLINE fromOrdinal #-} 435 | fromOrdinal :: DayOfYear -> MonthDay 436 | fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where 437 | (fromIntegral -> m, fromIntegral -> d) = VU.unsafeIndex table i 438 | 439 | {-# INLINE toOrdinal #-} 440 | toOrdinal :: MonthDay -> DayOfYear 441 | toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where 442 | m = max 1 . min 12 $ month 443 | l = VU.unsafeIndex lengths (pred m) 444 | d = max 1 . min l $ day 445 | k = if m <= 2 then 0 else ok 446 | 447 | -- | Predicated on whether or not it's a leap year, convert a 'MonthDay' to 448 | -- an ordinal 'DayOfYear'. 449 | -- 450 | -- @ 451 | -- > 'monthDayValid' ('isLeapYear' 2016) ('MonthDay' 2 29) 452 | -- 'Just' 60 453 | -- @ 454 | -- 455 | -- @ 456 | -- > 'monthDayValid' ('isLeapYear' 2015) ('MonthDay' 2 29) 457 | -- 'Nothing' 458 | -- @ 459 | {-# INLINEABLE monthDayValid #-} 460 | monthDayValid 461 | :: Bool -- ^ 'isLeapYear'? 462 | -> MonthDay 463 | -> Maybe DayOfYear 464 | monthDayValid leap md@(MonthDay m d) = monthDay leap # md 465 | <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m) 466 | 467 | -- | Predicated on whether or not the year is a leap year, return the number 468 | -- of 'Days' in the given 'Month'. 469 | -- 470 | -- @ 471 | -- > monthLength ('isLeapYear' 2015) 2 472 | -- 28 473 | -- @ 474 | -- 475 | -- @ 476 | -- > monthLength ('isLeapYear' 2016) 2 477 | -- 29 478 | -- @ 479 | {-# INLINEABLE monthLength #-} 480 | monthLength 481 | :: Bool -- ^ 'isLeapYear'? 482 | -> Month 483 | -> Days 484 | monthLength leap = VU.unsafeIndex ls . max 0 . min 11 . pred where 485 | ls = if leap then monthLengthsLeap else monthLengths 486 | 487 | ------------------------------------------------------------------------ 488 | 489 | -- | Week of the year. 490 | -- 491 | -- Meaning of values depends on context; see 'wdWeek', 'swWeek', 'mwWeek'. 492 | type WeekOfYear = Int 493 | 494 | -- | Day of the week. 495 | -- 496 | -- [/0/] /Sunday/ for 'SundayWeek' 497 | -- 498 | -- [/1/…/6/] /Monday/…/Saturday/ 499 | -- 500 | -- [/7/] /Sunday/ for 'WeekDate', 'MondayWeek', and 'Data.Thyme.Calendar.WeekdayOfMonth.WeekdayOfMonth' 501 | type DayOfWeek = Int 502 | 503 | -- | . 504 | -- 505 | -- Note that week /01/ is defined as the week with the first Thursday, thus 506 | -- 'wdYear' may differ from the Gregorian year between /December 29th/ and 507 | -- /January 3rd/. 508 | data WeekDate = WeekDate 509 | { wdYear :: {-# UNPACK #-}!Year 510 | , wdWeek :: {-# UNPACK #-}!WeekOfYear 511 | -- ^ Numbered /01/ to /53/. Days before week /01/ are considered to 512 | -- belong to the previous year. 513 | , wdDay :: {-# UNPACK #-}!DayOfWeek 514 | -- ^ /1 = Monday/ … /7 = Sunday/. 515 | } deriving (INSTANCES_USUAL, Show) 516 | 517 | LENS(WeekDate,wdYear,Year) 518 | LENS(WeekDate,wdWeek,WeekOfYear) 519 | LENS(WeekDate,wdDay,DayOfWeek) 520 | 521 | instance Hashable WeekDate 522 | instance NFData WeekDate 523 | 524 | -- | Convert between a 'Day' and an ISO 8601 'WeekDate'. 525 | -- 526 | -- @ 527 | -- > 'YearMonthDay' 2016 1 1 '^.' 'from' 'gregorian' '.' 'weekDate' 528 | -- 'WeekDate' {'wdYear' = 2015, 'wdWeek' = 53, 'wdDay' = 5} 529 | -- @ 530 | {-# INLINE weekDate #-} 531 | weekDate :: Iso' Day WeekDate 532 | weekDate = iso toWeek fromWeek where 533 | 534 | {-# INLINEABLE toWeek #-} 535 | toWeek :: Day -> WeekDate 536 | toWeek = join (toWeekOrdinal . view ordinalDate) 537 | 538 | {-# INLINEABLE fromWeek #-} 539 | fromWeek :: WeekDate -> Day 540 | fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd 541 | 542 | {-# INLINE toWeekOrdinal #-} 543 | toWeekOrdinal :: OrdinalDate -> Day -> WeekDate 544 | toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) = 545 | WeekDate y1 (w1 + 1) (d7mod + 1) where 546 | -- pilfered and refactored; no idea what foo and bar mean 547 | d = mjd + 2 548 | (d7div, d7mod) = divMod d 7 549 | foo :: Year -> {-WeekOfYear-1-}Int 550 | foo y = bar $ ordinalDate # OrdinalDate y 6 551 | bar :: Day -> {-WeekOfYear-1-}Int 552 | bar (ModifiedJulianDay k) = d7div - div k 7 553 | w0 = bar $ ModifiedJulianDay (d - yd + 4) 554 | (y1, w1) = case w0 of 555 | -1 -> (y0 - 1, foo (y0 - 1)) 556 | 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0) 557 | _ -> (y0, w0) 558 | 559 | {-# INLINE lastWeekOfYear #-} 560 | lastWeekOfYear :: Year -> WeekOfYear 561 | lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where 562 | wd = OrdinalDate y 365 ^. from ordinalDate . weekDate 563 | 564 | {-# INLINE fromWeekLast #-} 565 | fromWeekLast :: WeekOfYear -> WeekDate -> Day 566 | fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where 567 | -- pilfered and refactored 568 | ModifiedJulianDay k = ordinalDate # OrdinalDate y 6 569 | mjd = k - mod k 7 - 10 + clip 1 7 d + clip 1 wMax w * 7 570 | clip a b = max a . min b 571 | 572 | -- | Convert a 'WeekDate' to a 'Day', or 'Nothing' for invalid 'WeekDate'. 573 | {-# INLINEABLE weekDateValid #-} 574 | weekDateValid :: WeekDate -> Maybe Day 575 | weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) = 576 | fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) 577 | 578 | -- | Shows a 'Day' using the @yyyy-Www-d@ ISO 8601 Week Date format. 579 | -- 580 | -- @ 581 | -- > 'showWeekDate' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2006 11 15) 582 | -- "2006-W46-3" 583 | -- @ 584 | {-# INLINEABLE showWeekDate #-} 585 | showWeekDate :: Day -> String 586 | showWeekDate (view weekDate -> WeekDate y w d) = 587 | showsYear y . (++) "-W" . shows02 w . (:) '-' $ show d 588 | 589 | ------------------------------------------------------------------------ 590 | 591 | -- | Week-based calendar date with the first /Sunday/ of the year as the first 592 | -- day of week /01/. This corresponds to @%U@ and @%w@ of 593 | -- @@. 594 | -- 595 | -- The final week of a given year and week /00/ of the next both refer to 596 | -- the same week. 597 | data SundayWeek = SundayWeek 598 | { swYear :: {-# UNPACK #-}!Year 599 | -- ^ Coincides with that of 'gregorian'. 600 | , swWeek :: {-# UNPACK #-}!WeekOfYear 601 | -- ^ Weeks numbered from /00/ to /53/, starting with the first 602 | -- /Sunday/ of the year as the first day of week /01/. 603 | , swDay :: {-# UNPACK #-}!DayOfWeek 604 | -- ^ /0 = Sunday/. 605 | } deriving (INSTANCES_USUAL, Show) 606 | 607 | LENS(SundayWeek,swYear,Year) 608 | LENS(SundayWeek,swWeek,WeekOfYear) 609 | LENS(SundayWeek,swDay,DayOfWeek) 610 | 611 | instance Hashable SundayWeek 612 | instance NFData SundayWeek 613 | 614 | -- | Conversion between 'Day' and 'SundayWeek'. 615 | -- 616 | -- @ 617 | -- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'sundayWeek' 618 | -- 'SundayWeek' {'swYear' = 2016, 'swWeek' = 1, 'swDay' = 0} 619 | -- @ 620 | {-# INLINE sundayWeek #-} 621 | sundayWeek :: Iso' Day SundayWeek 622 | sundayWeek = iso toSunday fromSunday where 623 | 624 | {-# INLINEABLE toSunday #-} 625 | toSunday :: Day -> SundayWeek 626 | toSunday = join (toSundayOrdinal . view ordinalDate) 627 | 628 | {-# INLINEABLE fromSunday #-} 629 | fromSunday :: SundayWeek -> Day 630 | fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where 631 | ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 632 | -- following are all 0-based year days 633 | firstSunday = mod (4 - firstDay) 7 634 | yd = firstSunday + 7 * (w - 1) + d 635 | 636 | {-# INLINE toSundayOrdinal #-} 637 | toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek 638 | toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = 639 | SundayWeek y (d7div - div k 7) d7mod where 640 | d = mjd + 3 641 | k = d - yd 642 | (d7div, d7mod) = divMod d 7 643 | 644 | -- | Convert a 'SundayWeek' to a 'Day', or 'Nothing' for invalid 'SundayWeek'. 645 | {-# INLINEABLE sundayWeekValid #-} 646 | sundayWeekValid :: SundayWeek -> Maybe Day 647 | sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) 648 | <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where 649 | ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 650 | -- following are all 0-based year days 651 | firstSunday = mod (4 - firstDay) 7 652 | yd = firstSunday + 7 * (w - 1) + d 653 | lastDay = if isLeapYear y then 365 else 364 654 | 655 | ------------------------------------------------------------------------ 656 | 657 | -- | Week-based calendar date with the first /Monday/ of the year as the first 658 | -- day of week /01/. This corresponds to @%W@ and @%u@ of 659 | -- @@. 660 | -- 661 | -- The final week of a given year and week /00/ of the next both refer to 662 | -- the same week. 663 | data MondayWeek = MondayWeek 664 | { mwYear :: {-# UNPACK #-}!Year 665 | -- ^ Coincides with that of 'gregorian'. 666 | , mwWeek :: {-# UNPACK #-}!WeekOfYear 667 | -- ^ Weeks numbered from /00/ to /53/, starting with the first 668 | -- /Monday/ of the year as the first day of week /01/. 669 | , mwDay :: {-# UNPACK #-}!DayOfWeek 670 | -- ^ /7 = Sunday/. 671 | } deriving (INSTANCES_USUAL, Show) 672 | 673 | LENS(MondayWeek,mwYear,Year) 674 | LENS(MondayWeek,mwWeek,WeekOfYear) 675 | LENS(MondayWeek,mwDay,DayOfWeek) 676 | 677 | instance Hashable MondayWeek 678 | instance NFData MondayWeek 679 | 680 | -- | Conversion between 'Day' and 'MondayWeek'. 681 | -- 682 | -- @ 683 | -- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'mondayWeek' 684 | -- 'MondayWeek' {'mwYear' = 2016, 'mwWeek' = 0, 'mwDay' = 7} 685 | -- @ 686 | {-# INLINE mondayWeek #-} 687 | mondayWeek :: Iso' Day MondayWeek 688 | mondayWeek = iso toMonday fromMonday where 689 | 690 | {-# INLINEABLE toMonday #-} 691 | toMonday :: Day -> MondayWeek 692 | toMonday = join (toMondayOrdinal . view ordinalDate) 693 | 694 | {-# INLINEABLE fromMonday #-} 695 | fromMonday :: MondayWeek -> Day 696 | fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where 697 | ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 698 | -- following are all 0-based year days 699 | firstMonday = mod (5 - firstDay) 7 700 | yd = firstMonday + 7 * (w - 1) + d - 1 701 | 702 | {-# INLINE toMondayOrdinal #-} 703 | toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek 704 | toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = 705 | MondayWeek y (d7div - div k 7) (d7mod + 1) where 706 | d = mjd + 2 707 | k = d - yd 708 | (d7div, d7mod) = divMod d 7 709 | 710 | -- | Convert a 'MondayWeek' to a 'Day', or 'Nothing' for invalid 'MondayWeek'. 711 | {-# INLINEABLE mondayWeekValid #-} 712 | mondayWeekValid :: MondayWeek -> Maybe Day 713 | mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) 714 | <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where 715 | ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 716 | -- following are all 0-based year days 717 | firstMonday = mod (5 - firstDay) 7 718 | yd = firstMonday + 7 * (w - 1) + d - 1 719 | lastDay = if isLeapYear y then 365 else 364 720 | 721 | ------------------------------------------------------------------------ 722 | -- Unbox instances at the end avoids TH-related declaration order issues 723 | 724 | derivingUnbox "Day" [t| Day -> Int |] 725 | [| toModifiedJulianDay |] [| ModifiedJulianDay |] 726 | 727 | derivingUnbox "YearMonthDay" [t| YearMonthDay -> Int |] 728 | [| \ YearMonthDay {..} -> shiftL ymdYear 9 .|. shiftL ymdMonth 5 .|. ymdDay |] 729 | [| \ n -> YearMonthDay (shiftR n 9) (shiftR n 5 .&. 0xf) (n .&. 0x1f) |] 730 | 731 | derivingUnbox "OrdinalDate" [t| OrdinalDate -> Int |] 732 | [| \ OrdinalDate {..} -> shiftL odYear 9 .|. odDay |] 733 | [| \ n -> OrdinalDate (shiftR n 9) (n .&. 0x1ff) |] 734 | 735 | derivingUnbox "MonthDay" [t| MonthDay -> Int |] 736 | [| \ MonthDay {..} -> shiftL mdMonth 5 .|. mdDay |] 737 | [| \ n -> MonthDay (shiftR n 5) (n .&. 0x1f) |] 738 | 739 | derivingUnbox "WeekDate" [t| WeekDate -> Int |] 740 | [| \ WeekDate {..} -> shiftL wdYear 9 .|. shiftL wdWeek 3 .|. wdDay |] 741 | [| \ n -> WeekDate (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] 742 | 743 | derivingUnbox "SundayWeek" [t| SundayWeek -> Int |] 744 | [| \ SundayWeek {..} -> shiftL swYear 9 .|. shiftL swWeek 3 .|. swDay |] 745 | [| \ n -> SundayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] 746 | 747 | derivingUnbox "MondayWeek" [t| MondayWeek -> Int |] 748 | [| \ MondayWeek {..} -> shiftL mwYear 9 .|. shiftL mwWeek 3 .|. mwDay |] 749 | [| \ n -> MondayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] 750 | 751 | --------------------------------------------------------------------------------